Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/lodcmd.b36
There are 3 other files named lodcmd.b36 in the archive. Click here to see a list.
!
! COPYRIGHT (C) DIGITAL EQUIPMENT 1986.
! 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.
!
%TITLE 'L O D C M D -- RMSLOD command script processor'
!<BLF/REQUIRE 'BLI:BLF.REQ'>
MODULE lodcmd =
BEGIN
LIBRARY 'bli:xport';
LIBRARY 'rmsint'; ! Get the RMS symbols
LIBRARY 'stsdef'; ! Get status code definitions
LIBRARY 'comand'; ! Use the COMAND package
LIBRARY 'bli:tops20'; ! Get monitor symbols and JSYSes
LIBRARY 'bli:fao';
!+
! COMMAND_STATUS block
!
! The command status block (CMDSTS) is the data structure
! used to transfer command parsing status to and from action
! routines.
!
! COMMAND_STATUS fields
!
! STATUS - Status of the parse action. This field
! is used to flag that a "backup" or "display"
! action has been requested, for instance.
! NEXT ROUTINE - Next routine to be called. Option used
! when a choice of keywords determines a
! branch in the script tree, as choice of
! file organization would do.
! CONTEXT - Extra word for internal routine use. This
! could pass FAB$K_SEQ (_REL, _IDX) as a
! value to be set in the ORG field of a FAB.
!
! The address of the command status block is passed to action
! routines in the CONTEXT field of the $COMAND_FLDDB and
! $COMAND_OPTION macros.
!
! The block is declared as a $CMDSTS_BLOCK attribute. A command
! status "literal" may be created with the $COMMAND_STATUS macro, which
! returns the address of an appropriately initialized UPLIT.
!
! EDIT HISTORY
!
! 20-Sep-85 asp Add Ron Lusk's final pieces for first working version.
!-
FIELD
cmdsts$r_fields =
SET
cmdsts$g_status = [0, 0, 36, 0], ! Status of operation
cmdsts$a_next_routine = [1, 0, 36, 0], ! Next routine to call
cmdsts$g_context = [2, 0, 36, 0] ! Locally used value
TES;
MACRO
$cmdsts_block =
BLOCK [3] FIELD (cmdsts$r_fields) %;
KEYWORDMACRO
$command_status (
status = 0,
next = 0,
context = 0 ) =
UPLIT (status, next, context)
%;
!+
! Generally useful macros
!-
MACRO
!
! CH$SEQUENCE -- allocates a buffer
!
ch$sequence (n) =
VECTOR [CH$ALLOCATION (n)] %,
!
! XWD -- performs MACRO XWD pseudo-op
!
$xwd (lh, rh) =
((lh)^18 OR ((rh) AND %O'777777')) %,
!
! $STPTR -- returns pointer to literal ASCIZ string
!
$stptr [] =
CH$PTR (UPLIT (%ASCIZ %STRING (%REMAINING))) %,
!
! $$STRTBL_ENT -- internal macro for $STRTBL
!
$$strtbl_ent [strings] =
$stptr (%REMOVE (strings)) %,
!
! $STRTBL -- returns address of a vector of
! character pointers to literal strings
!
$strtbl [] =
UPLIT ( !
$$strtbl_ent (%REMAINING)) : VECTOR %,
!
! $CRLF -- puts a CRLF into a string
!
$crlf =
%CHAR($chcrt,$chlfd) %;
LITERAL
!
! Assorted constants
!
max_bucket_size = 7, ! Maximum of 7 pages
minimum_records_per_bucket = 6, ! Fit at least 6 recs/bkt
buffer_length = 80, ! Command/atom buffer length
bigbuf_length = 500, ! For DISPLAY, error buffers
!
! Format word for JFNS output
!
jfns$k_format = fld ($jsssd, js_dev) OR ! Device
fld ($jsssd, js_dir) OR ! Directory
fld ($jsaof, js_nam) OR ! Filename
fld ($jsaof, js_typ) OR ! Filetype
fld ($jsaof, js_gen) OR ! Generation
js_paf, ! Punctuate all the above
!
! Operation values
!
lod$k_load = 1, ! Load a file
lod$k_reorg = 2, ! Reorganize a file
lod$k_unload = 3, ! Unload a file
!
! Fields to display (bits in DISP_FLAGS)
!
dsp$k_operation = 0, ! Operation has been chosen
dsp$k_injfn = 1, ! We have an input JFN
dsp$k_unload_key = 2, ! Key to unload upon
dsp$k_outjfn = 3, ! Output file
dsp$k_org = 4, ! Output organization
dsp$k_rfm = 5, ! Record format
dsp$k_bsz = 6, ! Output bytesize
dsp$k_mrs = 7, ! Maximum record size
dsp$k_blk = 8, ! BLK record attribute
dsp$k_key = 9, ! Keys are defined
dsp$k_class = 10, ! File class
dsp$k_inrfm = 11, ! Input format
dsp$k_inmrs = 12, ! Input record size
dsp$k_inbls = 13, ! Input blocking factor
!
! Status codes
!
lod$k_fac = 4, ! "Facility" for RMSLOD
true = 1,
false = 0,
ss$_jsys_error_return = sts$value (CODE = 1, !
severity = error, fac_no = lod$k_fac),
ss$_jsys_error_quit = sts$value (CODE = 1, !
severity = severe, fac_no = lod$k_fac),
ss$_reparse = sts$value (CODE = 2, !
severity = info, fac_no = lod$k_fac),
ss$_rms_error = sts$value (CODE = 3, !
severity = error, fac_no = lod$k_fac),
ss$_exit = sts$value (CODE = 4, !
severity = info, fac_no = lod$k_fac),
ss$_backup = sts$value (CODE = 5, !
severity = info, fac_no = lod$k_fac),
ss$_success = sts$value (CODE = 6, !
severity = success, fac_no = lod$k_fac),
ss$_display = sts$value (CODE = 7, !
severity = info, fac_no = lod$k_fac),
ss$_out_of_range = sts$value (CODE = 8, !
severity = warning, fac_no = lod$k_fac),
ss$_record_too_large = sts$value (CODE = 9, !
severity = severe, fac_no = lod$k_fac),
ss$_input_not_indexed = sts$value (CODE = 11, !
severity = error, fac_no = lod$k_fac);
!+
! Table of contents
!-
FORWARD ROUTINE
display : NOVALUE, ! Display status
dspkey : NOVALUE,
setup_stateblock : NOVALUE, ! Initialize stateblock
top_handler, ! Top condition handler for LODCMD
lodcmd, ! Entry into LODCMD
set_backup : NOVALUE, ! Set status to perform backup
set_display : NOVALUE, ! Set status to perform display
operation, ! Get RMSLOD operation to perform
l_ifile, ! Get input file to load
l_ofile, ! Get RMS file to be loaded
organization, ! Get organization of new RMS file
format, ! Get record format
bytesize, ! Get file bytesize
recordsize, ! Get record length in bytes
primary_key, ! Get primary key data
key_6, ! Key def's for 6-bit-bytes
key_7, ! Key def's for 7-bit bytes
key_9, ! Key def's for 9-bit bytes
key_36, ! Key def's for other bytesizes
key_prompt : NOVALUE, ! Set KEY_n prompt
position, ! Key position in record
size, ! Key size
setdup, ! Are duplicates allowed?
setchg, ! Are changes allowed?
setdfl, ! Set data fill limit
setifl, ! Set index fill limit
nxtkey, ! Get alternate key data
spanned_records, ! Get BLK record attribute
file_language, ! Get language of foreign file
isam_bsz, ! Get bytesize of ISAM file
ebc_rsz, ! Get RSZ for fixed EBC file
blocking_factor, ! Get blocking factor, EBC file
confirm, ! Get confirmation of order
r_ifile, ! Get file to be reorganized
r_ofile, ! Get new index file
u_ifile, ! Get file to be unloaded
u_ofile, ! Get file to unload into
u_getkey; ! Key to unload file by
EXTERNAL ROUTINE
getmem,
fremem;
EXTERNAL LITERAL
ss$unw; ! Status of UNWIND from CHF
OWN
!
! Flag word for display of file definition fields
!
disp_flags : BITVECTOR [36], ! Fields to display
!
! Buffers and variables for $FAO output and DISPLAY
!
control, ! Pointer to control string
fprm : VECTOR [10], ! Parameter list for FAO
dspbuf : ch$sequence [bigbuf_length], ! Immense buffer for DISPLAY
dspdsc : $str_descriptor (class = fixed, ! Buffer descriptor for
string = (bigbuf_length, CH$PTR (dspbuf))), ! DISPLAY routines
errbuf : ch$sequence [bigbuf_length], ! Error message buffer
errdsc : $str_descriptor (class = fixed, ! Buffer descriptor for
string = (bigbuf_length, CH$PTR (errbuf))), ! error messages
rtybuf : ch$sequence [buffer_length], ! Prompt buffer
rtydsc : $str_descriptor (class = fixed, ! Buffer descriptor for
string = (buffer_length, CH$PTR (rtybuf))), ! prompts
hlpbuf : ch$sequence [buffer_length], ! Help buffer
hlpdsc : $str_descriptor (class = fixed, ! Buffer descriptor for
string = (buffer_length, CH$PTR (hlpbuf))), ! help messages
!
! Assorted variables
!
op_choice, ! Desired operation
databucket_size, ! Size of primary data bucket
!
! COMND state block and buffers
!
stateblock : VECTOR [$cmgjb + 1], ! COMND stateblock
command_buffer : ch$sequence [buffer_length],
atom_buffer : ch$sequence [buffer_length],
!
! JFN blocks and default filespec buffers
!
injfn : VECTOR [$gjatr + 1], ! Input JFN block
outjfn : VECTOR [$gjatr + 1], ! Output JFN block
outdev : ch$sequence [30], ! Default device
outdir : ch$sequence [200], ! Default directory
outnam : ch$sequence [40], ! Default filename
outtyp : ch$sequence [40], ! Default file extension
!
! RMS argument blocks
!
outfab : REF $fab_decl,
summary : $xabsum (), ! Summary for unload key
infab : REF $fab_decl,
intyp : REF $typ_decl;
ROUTINE display : NOVALUE =
BEGIN
IF .disp_flags EQL 0 ! Nothing set?
THEN
BEGIN
psout ($stptr ('%You have not answered any questions yet', $crlf));
RETURN;
END;
IF .disp_flags [dsp$k_operation] !
THEN
BEGIN
BIND
ops = $strtbl ('Load', 'Reorganize', 'Unload');
control = $fao_ctl ('!2(/)!28<Operation:!> !AZ!/!%^@');
fprm [0] = .ops [.op_choice - 1];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm);
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_injfn] ! Input file chosen?
THEN
BEGIN
control = $fao_ctl ('!/!28<Input file:!> !J!/!%^@');
fprm [0] = .infab [fab$h_jfn];
IF NOT $faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm)
!
THEN
SIGNAL (ss$_jsys_error_quit);
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_unload_key] ! Key for unloading specified?
THEN
BEGIN
control = $fao_ctl ('!28< Key for unloading file:!> !UL!/!%^@');
fprm [0] = .infab [fab$g_ctx];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_outjfn] ! Output file chosen?
THEN
BEGIN
control = $fao_ctl ('!/!28<Output file:!> !J!/!%^@');
fprm [0] = .outfab [fab$h_jfn];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_org] !
THEN
BEGIN
BIND
orgs = $strtbl ('Sequential', 'Relative', 'Indexed');
control = $fao_ctl ('!28< Organization:!> !AZ!/!%^@');
fprm [0] = .orgs [.outfab [fab$v_org] - 1];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_rfm] !
THEN
BEGIN
BIND
rfms = $strtbl ( !
'Variable', !
'Stream', !
'Line-Sequenced ASCII', !
'Fixed');
control = $fao_ctl ('!28< Record format:!> !AZ!/!%^@');
fprm [0] = .rfms [.outfab [fab$v_rfm]];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_bsz] ! Bytesize given?
THEN
BEGIN
control = $fao_ctl ('!28< File bytesize:!> !UL!/!%^@');
fprm [0] = .outfab [fab$v_bsz];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_mrs] ! Record size given?
THEN
BEGIN
IF .outfab [fab$h_mrs] EQL 0 ! No maximum?
THEN
BEGIN
control = $fao_ctl ('!28< Maximum record size:!> ', !
'No maximum specified!/!%^@');
END
ELSE
BEGIN
control = $fao_ctl ('!28< Maximum record size:!> !UL!/!%^@');
END;
fprm [0] = .outfab [fab$h_mrs];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .disp_flags [dsp$k_blk] !
THEN
BEGIN
BIND
ratblks = $strtbl ('No', 'Yes');
control = $fao_ctl ('!28< Record blocking:!> !AZ!/!%^@');
fprm [0] = .ratblks [.outfab [fab$v_blk]];
$faol (ctrstr = .control, outbuf = dspdsc, prmlst = fprm); !
psout (CH$PTR (dspbuf));
END;
IF .outfab [fab$a_xab] NEQ 0 ! XAB to display?
THEN
dspkey (.outfab [fab$a_xab]); ! Display it
psout ($stptr ($crlf));
END; ! End DISPLAY
ROUTINE dspkey (key_xab : REF $xabkey_decl) : NOVALUE =
BEGIN
BIND
dtypes = $strtbl ( !
'ASCII', !
'EBCDIC', !
'SIXBIT', !
'Packed decimal', !
'One-word integer', !
'Floating point', !
'Double floating point', !
'G-floating point', !
'Two-word integer', !
'Eight-bit ASCII', !
'Unsigned integer'), !
noyes = $strtbl ('No', 'Yes'); !
IF .key_xab [xab$v_cod] EQL xab$k_key ! Display key XABs only
THEN
BEGIN
control = $fao_ctl ('!/!28< Key !UL:!> !AZ!/', !
'!28< Position:!> !AZ !UL!/', !
'!28< Size:!> !UL !AZ!%S!/', !
'!28< Duplicates allowed:!> !AZ!/', !
'!28< Changes allowed:!> !AZ!/', !
'!28< Data fill:!> !3UL%!/', !
'!28< Index fill:!> !3UL%!/!%^@');
fprm [0] = .key_xab [xab$b_ref]; ! Key of reference
fprm [1] = .dtypes [.key_xab [xab$v_dtp]]; ! Datatype
SELECTONE .key_xab [xab$v_dtp] OF
SET
[xab$k_stg, xab$k_ebc, xab$k_six, xab$k_pac, xab$k_as8] :
BEGIN
fprm [2] = $stptr ('Byte');
fprm [3] = .key_xab [xab$h_pos0];
fprm [4] = .key_xab [xab$h_siz0];
fprm [5] = $stptr ('byte');
END;
[xab$k_in4, xab$k_uin, xab$k_fl1] :
BEGIN
fprm [2] = $stptr ('Word');
fprm [3] = .key_xab [xab$h_pos0];
fprm [4] = 1;
fprm [5] = $stptr ('word');
END;
[xab$k_in8, xab$k_fl2, xab$k_gfl] :
BEGIN
fprm [2] = $stptr ('Word');
fprm [3] = .key_xab [xab$h_pos0];
fprm [4] = 2;
fprm [5] = $stptr ('word');
END;
TES;
!
! Display the CHANGE and DUPLICATES attributes
!
fprm [6] = .noyes [.key_xab [xab$v_dup]];
fprm [7] = .noyes [.key_xab [xab$v_chg]];
!
! Calculate the data fill percentage. This
! is dependent upon whether this is the primary
! key (in which case we use the value in
! DATABUCKET_SIZE) or a secondary key (which
! uses the default bucket size of the file).
!
IF .key_xab [xab$b_ref] EQL 0
THEN
fprm [8] = .key_xab [xab$h_dfl]*100/(.databucket_size*%O'1000' - 3)
ELSE
fprm [8] = .key_xab [xab$h_dfl]*100/(.outfab [fab$v_bks]*%O'1000' -
3);
!
! Get the index fill percentage
!
fprm [9] = .key_xab [xab$h_ifl]*100/(.outfab [fab$v_bks]*%O'1000' - 3);
$faol (ctrstr = .control, prmlst = fprm, outbuf = dspdsc);
psout (CH$PTR (dspbuf));
END;
IF .key_xab [xab$a_nxt] NEQ 0 ! Next XAB
THEN
dspkey (.key_xab [xab$a_nxt]);
END; ! End DSPKEY
ROUTINE setup_stateblock : NOVALUE =
BEGIN
stateblock [$cmflg] = 0; ! Default to no flags
stateblock [$cmioj] = $xwd ($priin, $priou); ! TTY: I/O
!
! Set up pointer to prompt buffer. The calling routine
! will set this to a string literal pointer if the
! prompt buffer is not used.
!
stateblock [$cmrty] = CH$PTR (rtybuf);
!
! Set up buffer pointers and lengths
!
stateblock [$cmptr] = stateblock [$cmbfp] = CH$PTR (command_buffer);
stateblock [$cmcnt] = stateblock [$cmabc] = buffer_length;
stateblock [$cminc] = 0;
stateblock [$cmabp] = CH$PTR (atom_buffer);
stateblock [$cmgjb] = 0; ! No default GTJFN block
END; ! End SETUP_STATEBLOCK
ROUTINE top_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF VECTOR) =
BEGIN
LOCAL
hndbuf : ch$sequence [bigbuf_length], ! Large message buffer
hnddsc : $str_descriptor (class = fixed);
BIND
cond = sig [1] : $condition_value, ! Value passed by SIGNAL
return_value = mech [1]; ! Value to be returned
!
! Initialize our buffer descriptor
!
$str_desc_init (class = fixed, descriptor = hnddsc, !
string = (bigbuf_length, CH$PTR (hndbuf)));
!+
! Take appropriate action for the condition we received.
!-
SELECTONE .cond OF
SET
[ss$_exit] :
BEGIN
! Close files
psout ($stptr ($crlf, '[Exiting]'));
haltf ();
INCR i FROM 1 TO 3 DO
BEGIN
esout ($stptr ('Cannot continue RMSLOD'));
haltf ();
END;
psout ($stptr ($crlf, '[Continuing]'));
RETURN true;
END;
[ss$_backup] :
BEGIN
psout ($stptr ('% You cannot backup any further', $crlf));
return_value = false;
RETURN true;
END;
[ss$unw] :
BEGIN
! Probably shouldn't get here
! Close files?
psout ($stptr ($crlf, '[Exiting (from UNWIND)]'));
haltf ();
INCR i FROM 1 TO 3 DO
BEGIN
esout ($stptr ('Cannot continue RMSLOD'));
haltf ();
END;
psout ($stptr ($crlf, '[Continuing]'));
RETURN true;
END;
[ss$_display] :
BEGIN
display ();
RETURN true; ! Keep on going
END;
[ss$_jsys_error_return, ss$_jsys_error_quit] :
BEGIN
!+
! The format of the signal vector is
!
! |---------------------------|
! 0 | n = length of vector |
! |---------------------------|
! 1 | Condition value |
! |---------------------------|
! 2 | Error code 1 |
! |---------------------------|
! 3 | Error code 2 |
! |---------------------------|
! / .... /
! |---------------------------|
! n-1 | Error code n-2 |
! |---------------------------|
!
! This block of code will determine the number
! of error messages passed in the signal vector.
! If no error message is passed, it defaults to
! printing the message for the last error
! encountered. Otherwise, it prints the message
! for each error code passed. If any error code
! is -1, the message for the last error is used.
!
! The first message is output with an ESOUT,
! and so is preceded with a "?". Any subsequent
! messages are output on a new line, preceded
! by a "-<TAB>" sequence.
!
! After the messages are output, the program is
! halted if the severity field of the condition
! value is SEVERE, otherwise the handler continues
! the interrupted routine.
!-
LOCAL
number_of_messages;
number_of_messages = .sig [0] - 1; ! Number of messages
IF .number_of_messages EQL 0 ! Implicit last error
THEN
BEGIN
control = $fao_ctl ('!E!/!%^@');
fprm [0] = 0; ! Last error
$faol (ctrstr = .control, prmlst = fprm, outbuf = hnddsc);
esout (CH$PTR (hndbuf));
END
ELSE
BEGIN ! Give explicit error message
!
! Put out the primary error message
!
control = $fao_ctl ('!E!/!%^@');
fprm [0] = .sig [2]; ! Given error
$faol (ctrstr = .control, prmlst = fprm, outbuf = hnddsc);
esout (CH$PTR (hndbuf));
!+
! If there are secondary messages, put
! them out, too.
!-
INCR i FROM 3 TO .sig [0] DO ! Output others
BEGIN
!
! Put out the secondary error message
!
control = $fao_ctl ('-!E!/!%^@');
fprm [0] = .sig [.i]; ! Message
$faol (ctrstr = .control, prmlst = fprm, outbuf = hnddsc);
psout (CH$PTR (hndbuf));
END;
END;
!+
! If this was a severe error, then we don't
! return to the user. Just halt.
!-
IF .cond [sts$v_severity] EQL sts$k_severe ! Severe error?
THEN
WHILE 1 DO
BEGIN
haltf ();
psout ($stptr ('?Cannot continue', $crlf));
END;
RETURN true;
END;
[ss$_rms_error] :
BEGIN
!+
! This code assumes that the third element of
! the signal vector (SIG [2]) contains the
! address of the RMS argument block which was
! used in the call which received the error.
!-
BIND
errblk = .sig [2] : $fab_decl;
control = $fao_ctl ('RMS error - STS: !OW STV: !OW!%^@');
fprm [0] = .errblk [fab$h_sts];
fprm [1] = .errblk [fab$h_stv];
$faol (ctrstr = .control, prmlst = fprm, outbuf = hnddsc);
esout (CH$PTR (hndbuf));
WHILE 1 DO
BEGIN
haltf ();
psout ($stptr ('?Cannot continue', $crlf));
END;
RETURN false;
END;
[ss$_record_too_large] :
BEGIN
psout ($stptr ($crlf, '%Record size too large'));
RETURN true;
END;
[ss$_input_not_indexed] :
BEGIN
psout ($stptr ($crlf, '%Input file must be RMS indexed file'));
RETURN true;
END;
[ss$_out_of_range] :
BEGIN
BIND
lo_range = sig [2], ! Low end of range
hi_range = sig [3]; ! High end of range
control = $fao_ctl ('!/%Value must be between !UL and !UL!/!%^@');
fprm [0] = .lo_range;
fprm [1] = .hi_range;
$faol (ctrstr = .control, prmlst = fprm, outbuf = hnddsc);
psout (CH$PTR (hndbuf));
RETURN true;
END;
[OTHERWISE] :
BEGIN
esout ($stptr ('Unknown condition code encountered', $crlf));
RETURN false; ! Resignal to default CHF
END;
TES;
END; ! End TOP_HANDLER
GLOBAL ROUTINE lodcmd (p_infab, p_outfab) =
BEGIN
ENABLE
top_handler;
MAP
disp_flags;
disp_flags = 0; ! Zero display flags
infab = .p_infab;
intyp = .infab [fab$a_typ];
outfab = .p_outfab;
operation ();
RETURN .op_choice;
END; ! End DRIVER
ROUTINE set_backup (a, b, status : REF $cmdsts_block) : NOVALUE =
BEGIN
status [cmdsts$g_status] = ss$_backup;
END; ! End SET_BACKUP
ROUTINE set_display (a, b, status : REF $cmdsts_block) : NOVALUE =
BEGIN
status [cmdsts$g_status] = ss$_display;
END; ! End SET_DISPLAY
ROUTINE set_exit (a, b, status : REF $cmdsts_block) : NOVALUE =
BEGIN
status [cmdsts$g_status] = ss$_exit;
END; ! End SET_EXIT
%SBTTL 'OPERATION - get RMSLOD operation'
ROUTINE operation =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
op_question_handler, ! Condition handler for this routine
op_initialize : NOVALUE, ! Called by .CMINI function
op_take_action : NOVALUE; ! Called by parser
OWN
op_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
op_kwords : $comand_key ( !
$comand_option ( !
opt = 'Load', !
action = op_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ifile, !
context = lod$k_load), !
next = 1), !
$comand_option ( !
opt = 'Reorganize', !
action = op_take_action, !
context = $command_status ( !
status = ss$_success, !
next = r_ifile, !
context = lod$k_reorg), !
next = 1),
$comand_option ( !
opt = 'Unload', !
action = op_take_action, !
context = $command_status ( !
status = ss$_success, !
next = u_ifile, !
context = lod$k_unload), !
next = 1)),
!
! Parsing states and transitions
!
op_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = op_initialize, !
context = op_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = op_kwords, ! Load, Reorg, or Unload
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = op_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = op_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = op_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ifile, !
context = lod$k_load), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE op_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = l_ifile;
info [cmdsts$g_context] = lod$k_load;
control = $fao_ctl (
'That is not an operation RMSLOD can perform. Please choose one!/',
' of the following operations:!/', !
'!_!11<LOAD!> -- make an RMS indexed file from another file!/',
'!_!11<REORGANIZE!> -- copy an RMS indexed file, making it more efficient!/'
,
'!_!11<UNLOAD!> -- make an RMS sequential file from an RMS indexed file!/!%^@'
);
$faol (ctrstr = .control, prmlst = 0, outbuf = errdsc);
cmderp = CH$PTR (errbuf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE op_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
op_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
op_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
op_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE op_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
disp_flags [dsp$k_operation] = 0;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
op_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('Operation [Load]: '); ! Set prompt
comand (0, stateblock, op_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .op_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
BIND ROUTINE
routine_to_call = .op_status [cmdsts$a_next_routine];
op_choice = .op_status [cmdsts$g_context]; ! Set operation code
disp_flags [dsp$k_operation] = 1;
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF routine_to_call () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
disp_flags [dsp$k_operation] = 0;
op_choice = 0; ! No operation (for DISPLAY)
SIGNAL (.op_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; !End OPERATION
%SBTTL 'Load script routines'
ROUTINE l_ifile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
li_question_handler, ! Condition handler for this routine
li_initialize : NOVALUE, ! Called by .CMINI function
li_take_action : NOVALUE; ! Called by parser
OWN
li_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
li_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = li_initialize, !
context = li_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMIFI
function = $cmifi, !
flags = cm_sdh, !
help = 'input file',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = li_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = li_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = li_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE li_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End li_INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE li_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
li_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE li_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
disp_flags [dsp$k_injfn] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
disp_flags [dsp$k_injfn] = 0;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
li_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = injfn; ! Point to GTJFN block
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('Input file: '); ! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, li_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if we have one
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .li_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! We have a JFN. If this is an RMS record file, we
! can get the output file info. If it is COBOL,
! FORTRAN, or RMS-STREAM/RMS-LSA, then we need the
! user's additional info to read it.
!-
LOCAL
file_class : monword;
IF NOT gtfdb (.infab [fab$h_jfn], ! JFN
$xwd (1, $fbctl), ! One word at .FBCTL
file_class) ! Put it here
THEN
SIGNAL (ss$_jsys_error_quit, -1); ! Msg and halt
IF .file_class [fb_fcf] EQL $fbrms ! RMS record file?
THEN
BEGIN ! RMS record file
disp_flags [dsp$k_injfn] = 1;
!+
! $OPEN the file to get the bytesize, etc.
!-
IF NOT $open (fab = .infab)
THEN
SIGNAL (ss$_rms_error, .infab)
ELSE
BEGIN
infab [fab$v_drj] = 1; ! Keep the JFN
IF NOT $close (fab = .infab) ! Close it now
THEN
SIGNAL (ss$_rms_error, .infab);
infab [fab$v_drj] = 0; ! Toss JFN next time
END;
IF l_ofile () EQL ss$_success ! Next routine OK?
THEN
EXITLOOP; ! Exit and return
disp_flags [dsp$k_injfn] = 0;
END
ELSE
BEGIN ! Foreign (non-RMS) or STM/LSA file
disp_flags [dsp$k_injfn] = 1;
IF file_language () EQL ss$_success ! Next routine OK?
THEN
EXITLOOP; ! Exit and return
disp_flags [dsp$k_injfn] = 0;
END;
END
ELSE
BEGIN
disp_flags [dsp$k_injfn] = 0;
SIGNAL (.li_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End L_IFILE
ROUTINE l_ofile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
lo_question_handler, ! Condition handler for this routine
lo_initialize : NOVALUE, ! Called by .CMINI function
lo_take_action : NOVALUE; ! Called by parser
OWN
lo_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
lo_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = lo_initialize, !
context = lo_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMOFI
function = $cmofi, !
flags = cm_sdh, !
help = 'RMS file to be created',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = lo_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = lo_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = lo_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE lo_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE lo_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
lo_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
outfab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE lo_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_outjfn] = 0;
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
lo_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = outjfn; ! Point to GTJFN block
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('Output file: '); ! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, lo_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .lo_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
disp_flags [dsp$k_outjfn] = 1;
IF organization () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! Leave and return success
disp_flags [dsp$k_outjfn] = 0;
END
ELSE
BEGIN
disp_flags [dsp$k_outjfn] = 0;
SIGNAL (.lo_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End L_OFILE
ROUTINE organization =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
org_question_handler, ! Condition handler for this routine
org_initialize : NOVALUE, ! Called by .CMINI function
org_take_action : NOVALUE; ! Called by parser
OWN
org_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
org_kwords : $comand_key ( !
$comand_option ( !
opt = 'Indexed', !
action = org_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_idx), !
next = 1), !
$comand_option ( !
opt = 'Relative', !
action = org_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_rel), !
next = 1),
$comand_option ( !
opt = 'Sequential', !
action = org_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_seq), !
next = 1)),
!
! Parsing states and transitions
!
org_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = org_initialize, !
context = org_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = org_kwords, ! Load, Reorg, or Unload
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = org_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = org_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = org_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_idx), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE org_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = fab$k_idx;
cmderp = $stptr (
'That is not a valid RMS file organization. Please enter one',
$crlf, !
' of the following organizations:', $crlf, !
' Indexed Relative Sequential', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE org_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
org_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
org_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
org_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE org_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_org] = 0;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
org_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('File organization [Indexed]: ');
! Set prompt
comand (0, stateblock, org_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .org_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
disp_flags [dsp$k_org] = 1;
outfab [fab$v_org] = .org_status [cmdsts$g_context];
! Set organization
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF format () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_org] = 0;
END
ELSE
BEGIN
disp_flags [dsp$k_org] = 0;
outfab [fab$v_org] = 0; ! No organization (for DISPLAY)
SIGNAL (.org_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; !End ORGANIZATION
ROUTINE format =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
fmt_question_handler, ! Condition handler for this routine
fmt_initialize : NOVALUE, ! Called by .CMINI function
fmt_take_action : NOVALUE; ! Called by parser
OWN
fmt_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
fmt_kwords : $comand_key ( !
$comand_option ( !
opt = 'Fixed', !
action = fmt_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_fix), !
next = 1), !
$comand_option ( !
opt = 'Variable', !
action = fmt_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = fab$k_var), !
next = 1)),
!
! Parsing states and transitions
!
fmt_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = fmt_initialize, !
context = fmt_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = fmt_kwords, ! Fixed or Variable
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = fmt_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = fmt_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = fmt_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = -1), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE fmt_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = .infab [fab$v_rfm];
cmderp = $stptr (
'That is not a valid RMS record format. Please enter either',
$crlf, !
' Fixed or Variable', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE fmt_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
fmt_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
if .returned_context [cmdsts$g_context] EQL -1 ! Use data?
then
fmt_status [cmdsts$g_context] = .infab [fab$v_rfm]
else
fmt_status [cmdsts$g_context] = !
.returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE fmt_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_rfm] = 0;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
fmt_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
!
! Set up the help message
!
control = $fao_ctl ('record format, default is !AZ-length!%^@');
if .infab [fab$v_rfm] neq fab$k_fix ! Set default type
then
fprm [0] = $stptr ('Variable')
else
fprm [0] = $stptr ('Fixed');
$faol (ctrstr = .control, prmlst = fprm, outbuf = hlpdsc);
!
! Reuse some of the help data in the prompt.
!
control = $fao_ctl ('Record format [!AZ]: !%^@');
$faol (ctrstr = .control, prmlst = fprm, outbuf = rtydsc);
stateblock [$cmrty] = CH$PTR (rtybuf); ! Set prompt
comand (0, stateblock, fmt_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .fmt_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
disp_flags [dsp$k_rfm] = 1;
outfab [fab$v_rfm] = .fmt_status [cmdsts$g_context];
! Set organization
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF bytesize () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_rfm] = 0;
END
ELSE
BEGIN
disp_flags [dsp$k_rfm] = 0;
outfab [fab$v_rfm] = 0; ! No format
SIGNAL (.fmt_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End FORMAT
ROUTINE bytesize =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
bsz_question_handler, ! Condition handler for this routine
bsz_initialize : NOVALUE, ! Called by .CMINI function
bsz_take_action : NOVALUE; ! Called by parser
OWN
bsz_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
bsz_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = bsz_initialize, !
context = bsz_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'bytesize from 1 to 36', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = bsz_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = bsz_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = bsz_status, ! Status variable
next = 1, !
more = !
$comand_flddb ( ! Default to 0
function = $cmcfm, !
action = bsz_take_action, !
flags = cm_sdh, !
help = 'Return for default',
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE bsz_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE bsz_take_action (bits_per_byte, b, returned_context : REF
$cmdsts_block) : NOVALUE =
BEGIN
bsz_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
IF .returned_context [cmdsts$g_context] EQL -1 ! Use data?
THEN
outfab [fab$v_bsz] = .bits_per_byte
ELSE
outfab [fab$v_bsz] = .infab [fab$v_bsz];
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE bsz_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_bsz] = 0;
outfab [fab$v_bsz] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
bsz_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
!
! Set up the help message
!
control = $fao_ctl ('number of bits per byte, default is !UL!%^@');
fprm [0] = .infab [fab$v_bsz];
$faol (ctrstr = .control, prmlst = fprm, outbuf = hlpdsc);
!
! Reuse some of the help data in the prompt.
!
control = $fao_ctl ('Bytesize [!UL]: !%^@');
$faol (ctrstr = .control, prmlst = fprm, outbuf = rtydsc);
stateblock [$cmrty] = CH$PTR (rtybuf);
comand (0, stateblock, bsz_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .bsz_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Make sure the value returned is within range
!-
IF .outfab [fab$v_bsz] LSS 1 OR .outfab [fab$v_bsz] GTR 36 !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 1, 36);
END
ELSE
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
disp_flags [dsp$k_bsz] = 1;
IF recordsize () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
END
ELSE
BEGIN
disp_flags [dsp$k_bsz] = 0;
outfab [fab$v_bsz] = 0; ! Zero it
SIGNAL (.bsz_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End BYTESIZE
ROUTINE recordsize =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
mrs_question_handler, ! Condition handler for this routine
mrs_initialize : NOVALUE, ! Called by .CMINI function
mrs_take_action : NOVALUE; ! Called by parser
OWN
mrs_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
mrs_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = mrs_initialize, !
context = mrs_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'record length in bytes', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = mrs_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = mrs_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = mrs_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE mrs_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE mrs_take_action (recsiz, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
mrs_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
outfab [fab$h_mrs] = .recsiz;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE mrs_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_mrs] = 0;
outfab [fab$h_mrs] = 0;
outfab [fab$v_bks] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
mrs_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
IF .outfab [fab$v_rfm] EQL fab$k_fix ! Fixed format?
THEN
stateblock [$cmrty] = $stptr ('Record length: ')
ELSE
BEGIN
SELECTONE .outfab [fab$v_org] OF
SET
[fab$k_idx] :
stateblock [$cmrty] = $stptr (
'Expected maximum record length: ');
[fab$k_rel] :
stateblock [$cmrty] = $stptr ('Maximum record length: ');
[fab$k_seq] :
stateblock [$cmrty] = $stptr ('Maximum record length or 0: '
);
TES;
END; ! Set prompt
comand (0, stateblock, mrs_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .mrs_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!
! Default bucketsize for the file is 1
!
outfab [fab$v_bks] = 1;
!+
! For indexed files, calculate the primary
! data bucket-size based on the length
! of the data records. The buckets must be large
! enough to contain MINIMUM_RECORDS_PER_BUCKET
! records, or 7 pages long, whichever is less.
!-
IF .outfab [fab$v_org] EQL fab$k_idx ! IDX only
THEN
BEGIN
LOCAL
bytes_per_word,
words_per_record,
records_per_bucket;
!
! Figure number of user's bytes in a word
!
bytes_per_word = %BPVAL/.outfab [fab$v_bsz];
!
! Now number of words in this record
!
words_per_record = !
(.outfab [fab$h_mrs] + .bytes_per_word - 1)/.bytes_per_word;
!
! Add in the length of the record header: fix=2, var=3.
!
IF .outfab [fab$v_rfm] EQL fab$k_fix ! Fixed headers?
THEN
words_per_record = .words_per_record + 2
ELSE
words_per_record = .words_per_record + 3;
!
! Find a bucket big enough to hold several records.
!
databucket_size = (minimum_records_per_bucket* !
.words_per_record + 3)/%O'1000' + 1;
IF .databucket_size GTR 7 ! Not enough room
THEN
SIGNAL (ss$_record_too_large)
ELSE
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
disp_flags [dsp$k_mrs] = 1;
IF primary_key () EQL ss$_success !
THEN
EXITLOOP;
disp_flags [dsp$k_mrs] = 0;
END;
END
ELSE
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
disp_flags [dsp$k_mrs] = 1;
IF spanned_records () EQL ss$_success !
THEN
EXITLOOP;
disp_flags [dsp$k_mrs] = 0;
END;
END
ELSE
BEGIN
disp_flags [dsp$k_mrs] = 0;
outfab [fab$h_mrs] = 0; ! Zero it
SIGNAL (.mrs_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End RECORDSIZE
ROUTINE file_language =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
fl_question_handler, ! Condition handler for this routine
fl_initialize : NOVALUE, ! Called by .CMINI function
fl_take_action : NOVALUE; ! Called by parser
OWN
fl_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
fl_kwords : $comand_key ( !
$comand_option ( !
opt = 'ASCII', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ofile, !
context = 0), !
next = 1), !
$comand_option ( !
opt = 'Fixed-EBCDIC', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = ebc_rsz, !
context = typ$k_ebcdic), !
next = 1),
$comand_option ( !
opt = 'FORTRAN-Binary', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ofile, !
context = typ$k_fortran_binary), !
next = 1),
$comand_option ( !
opt = 'LIBOL-ISAM', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = isam_bsz, !
context = typ$k_isam), !
next = 1),
$comand_option ( !
opt = 'SIXBIT', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ofile, !
context = typ$k_sixbit), !
next = 1),
$comand_option ( !
opt = 'Variable-EBCDIC', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = blocking_factor, !
context = typ$k_ebcdic), !
next = 1)),
!
! Parsing states and transitions
!
fl_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = fl_initialize, !
context = fl_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = fl_kwords, ! Load, Reorg, or Unload
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = fl_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = fl_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = fl_take_action, !
context = $command_status ( !
status = ss$_success, !
next = l_ofile, !
context = 0), ! ASCII
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE fl_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = l_ofile;
info [cmdsts$g_context] = 0; ! Default to ASCII
control = $fao_ctl (
'RMS does not know about that file type. Please choose one!/',
!
' of the following file types:!/', !
'!_!16<ASCII!> -- normal TOPS-20 text files!/',
'!_!16<Fixed EBCDIC!> -- COBOL''s "RECORDING MODE IS F"!/',
'!_!16<FORTRAN Binary!> -- written WITH "MODE = ''BINARY''"!/',
'!_!16<LIBOL ISAM!> -- COBOL''s old-style ISAM!/',
'!_!16<SIXBIT!> -- COBOL''s "RECORDING MODE IS SIXBIT"!/',
'!_!16<Variable EBCDIC!> -- COBOL''s "RECORDING MODE IS V"!/!%^@');
$faol (ctrstr = .control, prmlst = 0, outbuf = errdsc);
cmderp = CH$PTR (errbuf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE fl_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
fl_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
fl_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
fl_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE fl_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
disp_flags [dsp$k_class] = 0;
intyp [typ$h_class] = 0;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
fl_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('File type [ASCII]: '); ! Set prompt
comand (0, stateblock, fl_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .fl_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
BIND ROUTINE
routine_to_call = .fl_status [cmdsts$a_next_routine];
!
! Set the file class
!
intyp [typ$h_class] = .fl_status [cmdsts$g_context];
disp_flags [dsp$k_class] = 1;
!+
! Do any individual processing
!-
SELECTONE .fl_status [cmdsts$g_context] OF
SET
[typ$k_sixbit] : ! COBOL SIXBIT
BEGIN
infab [fab$v_bsz] = 6;
END;
[typ$k_ebcdic] : ! COBOL EBCDIC
BEGIN
!
! Default to variable format. If the format
! is really fixed, EBC_RSZ will be called,
! and the format will be set to FIX there.
! Likewise, blocking will be set later
!
infab [fab$v_rfm] = fab$k_var;
infab [fab$v_bsz] = 9;
infab [fab$v_bls] = 0;
END;
[typ$k_isam] : ! LIBOL ISAM
BEGIN
!+
! Have already gotten byte size. Bogosity to
! fake out ASCII label below.
!-
infab [fab$v_bsz] = 0;
END;
[typ$k_fortran_binary] : ! FORTRAN BINARY
BEGIN
infab [fab$v_bsz] = 36;
END;
[0] : ! ASCII
BEGIN
infab [fab$v_bsz] = 7;
END;
TES;
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF routine_to_call () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
disp_flags [dsp$k_class] = 0;
SIGNAL (.fl_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End FILE_LANGUAGE
ROUTINE isam_bsz =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
isbsz_question_handler, ! Condition handler for this routine
isbsz_initialize : NOVALUE, ! Called by .CMINI function
isbsz_take_action : NOVALUE; ! Called by parser
OWN
isbsz_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
isbsz_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = isbsz_initialize, !
context = isbsz_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'bytesize from 1 to 36', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = isbsz_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = isbsz_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = isbsz_status, ! Status variable
next = 1, !
more = !
$comand_flddb ( ! Default to 0
function = $cmcfm, !
action = isbsz_take_action, !
flags = cm_sdh, !
help = 'Return for default',
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE isbsz_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE isbsz_take_action (bits_per_byte, b, returned_context : REF
$cmdsts_block) : NOVALUE =
BEGIN
isbsz_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$v_bsz] = .bits_per_byte;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE isbsz_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_bsz] = 0;
infab [fab$v_bsz] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
isbsz_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
!
! Set up the help message
!
control = $fao_ctl ('number of bits per byte !%^@');
fprm[0] = 0;
$faol (ctrstr = .control, prmlst = fprm , outbuf = hlpdsc);
!
! Reuse some of the help data in the prompt.
!
control = $fao_ctl ('Bytesize : !%^@');
fprm[0] = 0;
$faol (ctrstr = .control, prmlst = fprm , outbuf = rtydsc);
stateblock [$cmrty] = CH$PTR (rtybuf);
comand (0, stateblock, isbsz_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .isbsz_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Make sure the value returned is within range
!-
IF .infab [fab$v_bsz] LSS 1 OR .infab [fab$v_bsz] GTR 36 !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 1, 36);
END
ELSE
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
!!asp disp_flags [dsp$k_bsz] = 1;
IF l_ofile () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
END
ELSE
BEGIN
!!asp disp_flags [dsp$k_bsz] = 0;
infab [fab$v_bsz] = 0; ! Zero it
SIGNAL (.isbsz_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End ISAM_BSZ
ROUTINE ebc_rsz =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
er_question_handler, ! Condition handler for this routine
er_initialize : NOVALUE, ! Called by .CMINI function
er_take_action : NOVALUE; ! Called by parser
OWN
er_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
er_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = er_initialize, !
context = er_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'record length in bytes', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = er_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = er_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = er_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE er_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE er_take_action (recsiz, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
er_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$h_mrs] = .recsiz;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE er_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
infab [fab$h_mrs] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
er_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
!
! If we got here, then the file format must be fixed.
!
infab [fab$v_rfm] = fab$k_fix; ! Fixed record format
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
stateblock [$cmrty] = $stptr ('Record length: ');
comand (0, stateblock, er_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .er_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF blocking_factor () EQL ss$_success !
THEN
EXITLOOP;
END
ELSE
BEGIN
infab [fab$v_rfm] = fab$k_var; ! Reset record format
infab [fab$h_mrs] = 0; ! Zero it
SIGNAL (.er_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End EBC_RSZ
ROUTINE blocking_factor =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
bf_question_handler, ! Condition handler for this routine
bf_initialize : NOVALUE, ! Called by .CMINI function
bf_take_action : NOVALUE; ! Called by parser
OWN
bf_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
bf_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = bf_initialize, !
context = bf_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'number of records in block (0 = unblocked)',
!
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = bf_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = bf_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = bf_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE bf_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE bf_take_action (blkfac, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
bf_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$v_bls] = .blkfac;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE bf_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
infab [fab$v_bls] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
bf_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
stateblock [$cmrty] = $stptr ('Blocking factor: ');
comand (0, stateblock, bf_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .bf_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF l_ofile () EQL ss$_success !
THEN
EXITLOOP;
END
ELSE
BEGIN
infab [fab$v_bls] = 0; ! Zero it
SIGNAL (.bf_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End BLOCKING_FACTOR
ROUTINE primary_key =
BEGIN
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE pkey_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
BIND
newkey = .enbl [1] : REF $xabkey_decl,
newarea = .enbl [2] : REF $xaball_decl;
!
! Zero the pointer in the FAB
!
outfab [fab$a_xab] = 0;
!
! Free the allocated Key XAB, if necessary
!
IF .newkey NEQ 0 !
THEN
BEGIN
fremem (.newkey, xab$k_keylen);
newkey = 0;
END;
!
! Free the allocated Area XAB, if necessary
!
IF .newarea NEQ 0 !
THEN
BEGIN
fremem (.newarea, xab$k_alllen);
newarea = 0;
END;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
LOCAL
newarea : REF $xaball_decl VOLATILE,
newkey : REF $xabkey_decl VOLATILE;
ENABLE
pkey_question_handler (newkey, newarea); ! Enable our handler
newkey = getmem (xab$k_keylen);
$xabkey_init (xab = .newkey, !
kref = 0, !
dfl = (.databucket_size*%O'1000' - 3), !
ifl = (%O'1000' - 3));
IF .databucket_size GTR 1 ! Do UDRs need separate area?
THEN
BEGIN
newarea = getmem (xab$k_alllen);
$xaball_init (xab = .newarea, aid = 1, bkz = .databucket_size);
newkey [xab$b_dan] = 1;
outfab [fab$a_xab] = .newarea;
newarea [xab$a_nxt] = .newkey;
END
ELSE
BEGIN
newarea = 0;
newkey [xab$b_dan] = 0;
outfab [fab$a_xab] = .newkey;
END;
SELECTONE .outfab [fab$v_bsz] OF
SET
[6] :
BEGIN
newkey [xab$v_dtp] = xab$k_six;
RETURN key_6 (.newkey);
END;
[7] :
BEGIN
newkey [xab$v_dtp] = xab$k_stg;
RETURN key_7 (.newkey);
END;
[9] :
BEGIN
newkey [xab$v_dtp] = xab$k_ebc;
RETURN key_9 (.newkey);
END;
[OTHERWISE] :
BEGIN
newkey [xab$v_dtp] = xab$k_in4;
RETURN key_36 (.newkey);
END;
TES;
END; ! End PRIMARY_KEY
ROUTINE key_6 (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
k6_question_handler, ! Condition handler for this routine
k6_initialize : NOVALUE, ! Called by .CMINI function
k6_take_action : NOVALUE; ! Called by parser
OWN
k6_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
k6_kwords : $comand_key ( !
$comand_option ( !
opt = 'Double-Floating', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl2), !
next = 1), !
$comand_option ( !
opt = 'Floating', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl1), !
next = 1), !
$comand_option ( !
opt = 'G-Floating', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_gfl), !
next = 1), !
$comand_option ( !
opt = 'One-Word-Integer', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in4), !
next = 1), !
$comand_option ( !
opt = 'SIXBIT', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_six), !
next = 1), !
$comand_option ( !
opt = 'Two-word-integer', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in8), !
next = 1), !
$comand_option ( !
opt = 'Unsigned-Integer', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_uin), !
next = 1) !
),
!
! Parsing states and transitions
!
k6_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = k6_initialize, !
context = k6_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = k6_kwords, ! Key datatype
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = k6_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = k6_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = k6_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_six), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE k6_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = xab$k_six;
cmderp = $stptr ('Invalid key datatype - use "?" for help');
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE k6_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
k6_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
k6_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE k6_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
k6_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
!
! Set up the prompt to look impressive
!
key_prompt (.key_xab [xab$b_ref], $stptr ('SIXBIT'));
stateblock [$cmrty] = CH$PTR (rtybuf); ! Set prompt
comand (0, stateblock, k6_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .k6_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_dtp] = .k6_status [cmdsts$g_context];
! Set datatype
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF position (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
SIGNAL (.k6_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End KEY_6
ROUTINE key_7 (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
k7_question_handler, ! Condition handler for this routine
k7_initialize : NOVALUE, ! Called by .CMINI function
k7_take_action : NOVALUE; ! Called by parser
OWN
k7_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
k7_kwords : $comand_key ( !
$comand_option ( !
opt = 'ASCII', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_stg), !
next = 1), !
$comand_option ( !
opt = 'Double-Floating', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl2), !
next = 1), !
$comand_option ( !
opt = 'Floating', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl1), !
next = 1), !
$comand_option ( !
opt = 'G-Floating', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_gfl), !
next = 1), !
$comand_option ( !
opt = 'One-Word-Integer', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in4), !
next = 1), !
$comand_option ( !
opt = 'Two-word-integer', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in8), !
next = 1), !
$comand_option ( !
opt = 'Unsigned-Integer', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_uin), !
next = 1) !
),
!
! Parsing states and transitions
!
k7_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = k7_initialize, !
context = k7_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = k7_kwords, ! Key datatype
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = k7_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = k7_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = k7_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_stg), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE k7_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = xab$k_stg;
cmderp = $stptr ('Invalid key datatype - use "?" for help');
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE k7_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
k7_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
k7_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE k7_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
k7_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
!
! Set up the prompt to look impressive
!
key_prompt (.key_xab [xab$b_ref], $stptr ('ASCII'));
stateblock [$cmrty] = CH$PTR (rtybuf); ! Set prompt
comand (0, stateblock, k7_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .k7_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_dtp] = .k7_status [cmdsts$g_context];
! Set datatype
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF position (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
SIGNAL (.k7_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End KEY_7
ROUTINE key_9 (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
k9_question_handler, ! Condition handler for this routine
k9_initialize : NOVALUE, ! Called by .CMINI function
k9_take_action : NOVALUE; ! Called by parser
OWN
k9_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
k9_kwords : $comand_key ( !
$comand_option ( !
opt = 'Double-Floating', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl2), !
next = 1), !
$comand_option ( !
opt = 'EBCDIC', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_ebc), !
next = 1), !
$comand_option ( !
opt = 'Floating', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl1), !
next = 1), !
$comand_option ( !
opt = 'G-Floating', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_gfl), !
next = 1), !
$comand_option ( !
opt = 'One-Word-Integer', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in4), !
next = 1), !
$comand_option ( !
opt = 'Packed-decimal', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_pac), !
next = 1), !
$comand_option ( !
opt = 'Two-word-integer', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in8), !
next = 1), !
$comand_option ( !
opt = 'Unsigned-Integer', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_uin), !
next = 1) !
),
!
! Parsing states and transitions
!
k9_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = k9_initialize, !
context = k9_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = k9_kwords, ! Key datatype
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = k9_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = k9_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = k9_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_ebc), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE k9_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = xab$k_ebc;
cmderp = $stptr ('Invalid key datatype - use "?" for help');
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE k9_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
k9_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
k9_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE k9_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
k9_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
!
! Set up the prompt to look impressive
!
key_prompt (.key_xab [xab$b_ref], $stptr ('EBCDIC'));
stateblock [$cmrty] = CH$PTR (rtybuf); ! Set prompt
comand (0, stateblock, k9_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .k9_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_dtp] = .k9_status [cmdsts$g_context];
! Set datatype
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF position (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
SIGNAL (.k9_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End KEY_6
ROUTINE key_36 (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
k36_question_handler, ! Condition handler for this routine
k36_initialize : NOVALUE, ! Called by .CMINI function
k36_take_action : NOVALUE; ! Called by parser
OWN
k36_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
k36_kwords : $comand_key ( !
$comand_option ( !
opt = 'Double-Floating', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl2), !
next = 1), !
$comand_option ( !
opt = 'Floating', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_fl1), !
next = 1), !
$comand_option ( !
opt = 'G-Floating', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_gfl), !
next = 1), !
$comand_option ( !
opt = 'One-Word-Integer', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in4), !
next = 1), !
$comand_option ( !
opt = 'Two-word-integer', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in8), !
next = 1), !
$comand_option ( !
opt = 'Unsigned-Integer', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_uin), !
next = 1) !
),
!
! Parsing states and transitions
!
k36_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = k36_initialize, !
context = k36_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = k36_kwords, ! Key datatype
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = k36_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = k36_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = k36_take_action, !
context = $command_status ( !
status = ss$_success, !
context = xab$k_in4), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE k36_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = xab$k_in4;
cmderp = $stptr ('Invalid key datatype - use "?" for help');
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE k36_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
k36_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
k36_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE k36_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
k36_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
!
! Set up the prompt to look impressive
!
key_prompt (.key_xab [xab$b_ref], $stptr ('One-word integer'));
stateblock [$cmrty] = CH$PTR (rtybuf); ! Set prompt
comand (0, stateblock, k36_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .k36_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_dtp] = .k36_status [cmdsts$g_context];
! Set datatype
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF position (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
SIGNAL (.k36_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End KEY_36
ROUTINE key_prompt (key_of_ref, default_dtype) : NOVALUE =
BEGIN
IF .key_of_ref EQL 0 ! Primary key
THEN
control = $fao_ctl ('Datatype of primary key [!AZ]: !%^@')
ELSE
BEGIN
LOCAL
suffix_code;
control = $fao_ctl ( !
'Datatype of !+!UL!AZ alternate key [!3(-)!AZ]: !%^@');
fprm [1] = .key_of_ref;
IF (.key_of_ref MOD 100) GTR 20 ! Allow for 10th-19th
THEN
suffix_code = .key_of_ref MOD 10
ELSE
suffix_code = .key_of_ref;
SELECTONE .suffix_code OF
SET
[1] :
fprm [2] = $stptr ('st');
[2] :
fprm [2] = $stptr ('nd');
[3] :
fprm [2] = $stptr ('rd');
[OTHERWISE] :
fprm [2] = $stptr ('th');
TES;
END;
fprm [0] = .default_dtype;
$faol (ctrstr = .control, prmlst = fprm, outbuf = rtydsc);
END; ! End KEY_PROMPT
ROUTINE position (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
pos_question_handler, ! Condition handler for this routine
pos_initialize : NOVALUE, ! Called by .CMINI function
pos_take_action : NOVALUE; ! Called by parser
OWN
pos_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
pos_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = pos_initialize, !
context = pos_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = CH$PTR (hlpbuf), !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = pos_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = pos_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = pos_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE pos_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE pos_take_action (keypos, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
pos_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
pos_status [cmdsts$g_context] = .keypos;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE pos_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
LOCAL
high_key_position;
ENABLE
pos_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
!
! Set up the help message
!
control = $fao_ctl ('!AZposition of key (in !AZ), between 0 and !UL!%^@'
);
SELECTONE .key_xab [xab$v_dtp] OF
SET
[xab$k_stg, xab$k_six, xab$k_ebc, xab$k_as8, xab$k_pac] :
BEGIN
!
! Byte mode keys, all have a "starting" position
!
fprm [0] = $stptr ('starting ');
fprm [1] = $stptr ('bytes');
high_key_position = fprm [2] = .outfab [fab$h_mrs] - 1;
END;
[xab$k_in4, xab$k_in8, xab$k_uin, xab$k_fl1, xab$k_fl2, xab$k_gfl] :
BEGIN
LOCAL
bytes_per_word,
words_per_record;
!
! Word mode keys
!
SELECTONE .key_xab [xab$v_dtp] OF
SET
[xab$k_in4, xab$k_uin, xab$k_fl1] :
! One-word keys do not "start"
fprm [0] = $stptr ('');
[OTHERWISE] :
! Two-word keys do "start"
fprm [0] = $stptr ('starting ');
TES;
fprm [1] = $stptr ('words'); ! These are all word mode
!
! Figure number of user's bytes in a word
!
bytes_per_word = %BPVAL/.outfab [fab$v_bsz];
!
! Now number of words in this record
!
words_per_record = !
(.outfab [fab$h_mrs] + .bytes_per_word - 1)/.bytes_per_word;
!
! Set up the maximum key position
!
high_key_position = fprm [2] = .words_per_record - ( !
SELECTONE .key_xab [xab$v_dtp] OF
SET
[xab$k_in4, xab$k_uin, xab$k_fl1] : 1; ! 1-word keys
[OTHERWISE] : 2; ! 2-word keys
TES);
END;
TES;
$faol (ctrstr = .control, prmlst = fprm, outbuf = hlpdsc);
!
! Reuse some of the information from the
! last $FAOL call in the prompt.
!
control = $fao_ctl ('!+Position of key in !AZ (0-!UL): !%^@');
$faol (ctrstr = .control, prmlst = fprm, outbuf = rtydsc);
stateblock [$cmrty] = CH$PTR (rtybuf);
comand (0, stateblock, pos_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .pos_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
IF .pos_status [cmdsts$g_context] LSS 0 OR !
.pos_status [cmdsts$g_context] GTR .high_key_position !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 0, .high_key_position);
END
ELSE
BEGIN
key_xab [xab$h_pos0] = .pos_status [cmdsts$g_context];
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
SELECTONE .key_xab [xab$v_dtp] OF
SET
[xab$k_stg, xab$k_six, xab$k_ebc, xab$k_as8, xab$k_pac] :
IF size (.key_xab) EQL ss$_success !
THEN
EXITLOOP;
[OTHERWISE] :
IF setdup (.key_xab) EQL ss$_success !
THEN
EXITLOOP;
TES;
END;
END
ELSE
BEGIN
SIGNAL (.pos_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End POSITION
ROUTINE size (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
siz_question_handler, ! Condition handler for this routine
siz_initialize : NOVALUE, ! Called by .CMINI function
siz_take_action : NOVALUE; ! Called by parser
OWN
siz_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
siz_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = siz_initialize, !
context = siz_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = CH$PTR (hlpbuf), !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = siz_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = siz_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = siz_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE siz_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE siz_take_action (keysiz, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
siz_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
siz_status [cmdsts$g_context] = .keysiz;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE siz_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
LOCAL
max_key_size,
high_key_position;
ENABLE
siz_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
!
! Set up the help message
!
control = $fao_ctl ('size of key (in bytes), between 1 and !UL!%^@');
max_key_size = .outfab [fab$h_mrs] - .key_xab [xab$h_pos0];
fprm [0] = max_key_size = MIN (.max_key_size, 255); ! Max key length
$faol (ctrstr = .control, prmlst = fprm, outbuf = hlpdsc);
!
! Reuse some of the help data in the prompt.
!
control = $fao_ctl ('Key size (1-!UL): !%^@');
$faol (ctrstr = .control, prmlst = fprm, outbuf = rtydsc);
comand (0, stateblock, siz_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .siz_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
IF .siz_status [cmdsts$g_context] LSS 1 OR !
.siz_status [cmdsts$g_context] GTR .max_key_size !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 1, .max_key_size);
END
ELSE
BEGIN
key_xab [xab$h_siz0] = .siz_status [cmdsts$g_context];
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF setdup (.key_xab) EQL ss$_success !
THEN
EXITLOOP;
END;
END
ELSE
BEGIN
SIGNAL (.siz_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SIZE
ROUTINE setdup (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
dup_question_handler, ! Condition handler for this routine
dup_initialize : NOVALUE, ! Called by .CMINI function
dup_take_action : NOVALUE; ! Called by parser
OWN
dup_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
dup_kwords : $comand_key ( !
$comand_option ( !
opt = 'No', !
action = dup_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = 1), !
$comand_option ( !
opt = 'Yes', !
action = dup_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 1), !
next = 1)),
!
! Parsing states and transitions
!
dup_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = dup_initialize, !
context = dup_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = dup_kwords, ! Fixed or Variable
flags = cm_sdh, ! Suppress normal help
help = 'Yes or No', !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = dup_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = dup_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = dup_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE dup_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
cmderp = $stptr ('Please answer "Yes" or "No"', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE dup_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
dup_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
dup_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE dup_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
dup_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('Allow duplicate keys [No]: ');
! Set prompt
comand (0, stateblock, dup_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .dup_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_dup] = .dup_status [cmdsts$g_context];
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF .key_xab [xab$b_ref] EQL 0 ! No changes on primary
THEN
BEGIN
IF setdfl (.key_xab) EQL ss$_success !
THEN
EXITLOOP;
END
ELSE
BEGIN
IF setchg (.key_xab) EQL ss$_success !
THEN
EXITLOOP;
END;
key_xab [xab$v_dup] = 0; ! No duplicate records
END
ELSE
BEGIN
key_xab [xab$v_dup] = 0; ! No duplicate records
SIGNAL (.dup_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SETDUP
ROUTINE setchg (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
chg_question_handler, ! Condition handler for this routine
chg_initialize : NOVALUE, ! Called by .CMINI function
chg_take_action : NOVALUE; ! Called by parser
OWN
chg_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
chg_kwords : $comand_key ( !
$comand_option ( !
opt = 'No', !
action = chg_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = 1), !
$comand_option ( !
opt = 'Yes', !
action = chg_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 1), !
next = 1)),
!
! Parsing states and transitions
!
chg_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = chg_initialize, !
context = chg_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = chg_kwords, ! Fixed or Variable
flags = cm_sdh, ! Suppress normal help
help = 'Yes or No', !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = chg_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = chg_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = chg_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE chg_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
cmderp = $stptr ('Please answer "Yes" or "No"', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE chg_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
chg_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
chg_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE chg_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
chg_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('Allow key change on UPDATE [No]: ');
! Set prompt
comand (0, stateblock, chg_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .chg_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
key_xab [xab$v_chg] = .chg_status [cmdsts$g_context];
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF setdfl (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
key_xab [xab$v_chg] = 0; ! No changes
END
ELSE
BEGIN
key_xab [xab$v_chg] = 0; ! No changes
SIGNAL (.chg_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SETCHG
ROUTINE setdfl (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
dfl_question_handler, ! Condition handler for this routine
dfl_initialize : NOVALUE, ! Called by .CMINI function
dfl_take_action : NOVALUE; ! Called by parser
OWN
dfl_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
dfl_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = dfl_initialize, !
context = dfl_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'number from 50 to 100', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = dfl_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = dfl_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = dfl_status, ! Status variable
next = 1, !
more = !
$comand_flddb ( ! Default to 0
function = $cmcfm, !
action = dfl_take_action, !
flags = cm_sdh, !
help = 'Return for default',
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 100), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE dfl_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE dfl_take_action (datafill, b, returned_context : REF $cmdsts_block)
: NOVALUE =
BEGIN
dfl_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
IF .returned_context [cmdsts$g_context] EQL -1 ! Use data?
THEN
dfl_status [cmdsts$g_context] = .datafill
ELSE
dfl_status [cmdsts$g_context] = 100;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE dfl_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
dfl_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
stateblock [$cmrty] = $stptr ('Data fill limit [100%]: ');
! Set prompt
comand (0, stateblock, dfl_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .dfl_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Make sure the value returned is within range
!-
IF .dfl_status [cmdsts$g_context] LSS 50 OR !
.dfl_status [cmdsts$g_context] GTR 100 !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 50, 100);
END
ELSE
BEGIN
LOCAL
words_per_bucket;
IF .key_xab [xab$b_ref] EQL 0 ! Primary key?
THEN
words_per_bucket = .databucket_size*%O'1000'
ELSE
words_per_bucket = .outfab [fab$v_bks]*%O'1000';
key_xab [xab$h_dfl] = !
(.words_per_bucket*.dfl_status [cmdsts$g_context])/100;
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF setifl (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
key_xab [xab$h_dfl] = 0;
END
END
ELSE
BEGIN
key_xab [xab$h_dfl] = 0;
SIGNAL (.dfl_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SETDFL
ROUTINE setifl (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
ifl_question_handler, ! Condition handler for this routine
ifl_initialize : NOVALUE, ! Called by .CMINI function
ifl_take_action : NOVALUE; ! Called by parser
OWN
ifl_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
ifl_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = ifl_initialize, !
context = ifl_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = 'number from 50 to 100', !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = ifl_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = ifl_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = ifl_status, ! Status variable
next = 1, !
more = !
$comand_flddb ( ! Default to 0
function = $cmcfm, !
action = ifl_take_action, !
flags = cm_sdh, !
help = 'Return for default',
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 100), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE ifl_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE ifl_take_action (indexfill, b, returned_context : REF $cmdsts_block)
: NOVALUE =
BEGIN
ifl_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
IF .returned_context [cmdsts$g_context] EQL -1 ! Use data?
THEN
ifl_status [cmdsts$g_context] = .indexfill
ELSE
ifl_status [cmdsts$g_context] = 100;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE ifl_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
ifl_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
stateblock [$cmrty] = $stptr ('Index fill limit [100%]: ');
! Set prompt
comand (0, stateblock, ifl_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .ifl_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Make sure the value returned is within range
!-
IF .ifl_status [cmdsts$g_context] LSS 50 OR !
.ifl_status [cmdsts$g_context] GTR 100 !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 50, 100);
END
ELSE
BEGIN
LOCAL
words_per_bucket;
words_per_bucket = .outfab [fab$v_bks]*%O'1000';
key_xab [xab$h_ifl] = !
(.words_per_bucket*.ifl_status [cmdsts$g_context])/100;
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF nxtkey (.key_xab) EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
key_xab [xab$h_ifl] = 0;
END
END
ELSE
BEGIN
key_xab [xab$h_ifl] = 0;
SIGNAL (.ifl_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SETIFL
ROUTINE nxtkey (key_xab : REF $xabkey_decl) =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
nxtk_question_handler, ! Condition handler for this routine
nxtk_initialize : NOVALUE, ! Called by .CMINI function
nxtk_take_action : NOVALUE; ! Called by parser
OWN
nxtk_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
nxtk_kwords : $comand_key ( !
$comand_option ( !
opt = 'No', !
action = nxtk_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = 1), !
$comand_option ( !
opt = 'Yes', !
action = nxtk_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 1), !
next = 1)),
!
! Parsing states and transitions
!
nxtk_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = nxtk_initialize, !
context = nxtk_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = nxtk_kwords, ! Fixed or Variable
flags = cm_sdh, ! Suppress normal help
help = 'Yes or No', !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = nxtk_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = nxtk_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = nxtk_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE nxtk_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
cmderp = $stptr ('Please answer "Yes" or "No"', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE nxtk_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
nxtk_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
nxtk_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
nxtk_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE nxtk_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1],
key_xab = .enbl [1] : REF $xabkey_decl,
newkey = .enbl [2] : REF $xabkey_decl;
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
key_xab [xab$a_nxt] = 0;
IF .newkey NEQ 0 !
THEN
BEGIN
fremem (.newkey, xab$k_keylen);
newkey = 0;
END;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
LOCAL
xab_pointer : REF $xabkey_decl VOLATILE, ! For handler to get at
newkey : REF $xabkey_decl VOLATILE;
ENABLE
nxtk_question_handler (xab_pointer, newkey); ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
xab_pointer = .key_xab; ! Pointer for handler
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('Do you want do define another key [No]: '
); ! Set prompt
comand (0, stateblock, nxtk_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .nxtk_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF .nxtk_status [cmdsts$g_context] ! Yes?
THEN
BEGIN
newkey = key_xab [xab$a_nxt] = getmem (xab$k_keylen);
$xabkey_init (xab = .newkey, !
kref = (.key_xab [xab$b_ref] + 1), dfl = 509, ifl = 509);
IF (SELECTONE .outfab [fab$v_bsz] OF
SET
[6] :
BEGIN
newkey [xab$v_dtp] = xab$k_six;
key_6 (.newkey)
END;
[7] :
BEGIN
newkey [xab$v_dtp] = xab$k_stg;
key_7 (.newkey)
END;
[9] :
BEGIN
newkey [xab$v_dtp] = xab$k_ebc;
key_9 (.newkey)
END;
[OTHERWISE] :
BEGIN
newkey [xab$v_dtp] = xab$k_in4;
key_36 (.newkey)
END;
TES) EQL ss$_success !
THEN
EXITLOOP;
key_xab [xab$a_nxt] = 0;
IF .newkey NEQ 0 !
THEN
BEGIN
fremem (.newkey, xab$k_keylen);
newkey = 0;
END;
END
ELSE
BEGIN
IF confirm () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
key_xab [xab$a_nxt] = 0;
IF .newkey NEQ 0 !
THEN
BEGIN
fremem (.newkey, xab$k_keylen);
newkey = 0;
END;
END;
END
ELSE
BEGIN
SIGNAL (.nxtk_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End NXTKEY
ROUTINE spanned_records =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
spn_question_handler, ! Condition handler for this routine
spn_initialize : NOVALUE, ! Called by .CMINI function
spn_take_action : NOVALUE; ! Called by parser
OWN
spn_status : $cmdsts_block, ! Status from this parse
!
! Keyword table
!
spn_kwords : $comand_key ( !
$comand_option ( !
opt = 'No', !
action = spn_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = 1), !
$comand_option ( !
opt = 'Yes', !
action = spn_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 1), !
next = 1)),
!
! Parsing states and transitions
!
spn_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = spn_initialize, !
context = spn_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMKEY
function = $cmkey, !
data = spn_kwords, ! Fixed or Variable
flags = cm_sdh, ! Suppress normal help
help = 'Yes or No', !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = spn_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = spn_status, ! Status variable
next = 1, more = !
$comand_flddb ( ! CRLF for default
function = $cmcfm, !
flags = cm_sdh, ! Suppress help
help = 'Return for default', !
action = spn_take_action, !
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE spn_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
cmderp = $stptr ('Please answer "Yes" or "No"', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE spn_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
spn_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
spn_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
spn_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE spn_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_blk] = 0;
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
spn_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('Blocked records [No]: ');
! Set prompt
comand (0, stateblock, spn_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .spn_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
disp_flags [dsp$k_blk] = 1;
outfab [fab$v_blk] = .spn_status [cmdsts$g_context];
! Set BLK bit
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF confirm () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_blk] = 0;
END
ELSE
BEGIN
disp_flags [dsp$k_blk] = 0;
outfab [fab$v_blk] = 0; ! Spanned records
SIGNAL (.spn_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End SPANNED_RECORDS
ROUTINE confirm =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
cfm_question_handler, ! Condition handler for this routine
cfm_initialize : NOVALUE, ! Called by .CMINI function
cfm_take_action : NOVALUE; ! Called by parser
OWN
cfm_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
cfm_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = cfm_initialize, !
context = cfm_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
flags = cm_sdh, ! Suppress normal help
help = 'RETURN to confirm operation', !
next = -1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = cfm_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to redisplay current status',
action = set_display, !
context = cfm_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE cfm_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success;
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
cmderp = $stptr ('Please confirm selected operation', $crlf);
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE cfm_take_action (a, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
cfm_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
cfm_status [cmdsts$a_next_routine] = .returned_context [
cmdsts$a_next_routine];
cfm_status [cmdsts$g_context] = .returned_context [cmdsts$g_context];
cmderp = $stptr ('Your answer was not followed by a carriage return');
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE cfm_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl :
REF VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
RETURN false;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
cfm_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
SIGNAL (ss$_display);
WHILE 1 DO
BEGIN
setup_stateblock (); ! Initialize the state block
cmderr = 0; ! Handle errors for us
cmdrpt = 2; ! Reparse from state after .CMINI
stateblock [$cmrty] = $stptr ('[Confirm with RETURN] ');
! Set prompt
comand (0, stateblock, cfm_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .cfm_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
EXITLOOP; ! The only way out
END
ELSE
BEGIN
SIGNAL (.cfm_status [cmdsts$g_status]); ! Parse not "success"
END;
END;
RETURN ss$_success; ! Return OK
END; ! End CONFIRM
%SBTTL 'Reorganization script routines'
ROUTINE r_ifile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
ri_question_handler, ! Condition handler for this routine
ri_initialize : NOVALUE, ! Called by .CMINI function
ri_take_action : NOVALUE; ! Called by parser
OWN
ri_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
ri_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = ri_initialize, !
context = ri_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMIFI
function = $cmifi, !
flags = cm_sdh, !
help = 'RMS indexed file to reorganize',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = ri_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = ri_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = ri_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE ri_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End RI_INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE ri_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
ri_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE ri_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_injfn] = 0;
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
ri_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = injfn; ! Point to GTJFN block
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('File to reorganize: '); ! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, ri_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if we have one
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .ri_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Check to make sure that the file we
! have been given is an RMS indexed file.
!-
IF NOT $open (fab = .infab) ! Check out the file
THEN
BEGIN
SIGNAL (ss$_rms_error, .infab);
END
ELSE
BEGIN
!+
! Check to make sure the file is indexed
!-
IF .infab [fab$v_org] NEQ fab$k_idx !
THEN
BEGIN
SIGNAL (ss$_input_not_indexed);
infab [fab$v_drj] = 0; ! Get rid of the JFN
IF NOT $close (fab = .infab) !
THEN
SIGNAL (ss$_rms_error, .infab);
END
ELSE
BEGIN
!+
! Close the input file, but
! keep a hold of the JFN.
!-
disp_flags [dsp$k_injfn] = 1;
infab [fab$v_drj] = 1; ! Do not release JFN
IF NOT $close (fab = .infab) !
THEN
SIGNAL (ss$_rms_error, .infab);
!+
! Parse out the filename into its
! component parts, and put them into
! the default fields of the output
! filename.
!-
IF NOT jfns ( !
CH$PTR (outdev), ! Default device name
.infab [fab$h_jfn], ! Input JFN
fld ($jsaof, js_dev)) !
THEN
SIGNAL (ss$_jsys_error_return);
!
! Now the directory
!
IF NOT jfns ( !
CH$PTR (outdir), ! Default directory name
.infab [fab$h_jfn], ! Input JFN
fld ($jsaof, js_dir)) !
THEN
SIGNAL (ss$_jsys_error_return);
!
! The filename
!
IF NOT jfns ( !
CH$PTR (outnam), ! Default filename
.infab [fab$h_jfn], ! Input JFN
fld ($jsaof, js_nam)) !
THEN
SIGNAL (ss$_jsys_error_return);
!
! The file extension
!
IF NOT jfns ( !
CH$PTR (outtyp), ! Default filetype
.infab [fab$h_jfn], ! Input JFN
fld ($jsaof, js_typ)) !
THEN
SIGNAL (ss$_jsys_error_return);
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF r_ofile () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_injfn] = 0;
END;
END;
END
ELSE
BEGIN
SIGNAL (.ri_status [cmdsts$g_status]); ! Parse not "success"
disp_flags [dsp$k_injfn] = 0;
END;
END;
RETURN ss$_success; ! Return OK
END; ! End R_IFILE
ROUTINE r_ofile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
ro_question_handler, ! Condition handler for this routine
ro_initialize : NOVALUE, ! Called by .CMINI function
ro_take_action : NOVALUE; ! Called by parser
OWN
ro_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
ro_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = ro_initialize, !
context = ro_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMFIL
function = $cmfil, !
flags = cm_sdh, !
help = 'new indexed file',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = ro_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = ro_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = ro_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE ro_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE ro_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
ro_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
outfab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE ro_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_outjfn] = 0;
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
ro_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = outjfn; ! Point to GTJFN block
outjfn [$gjdev] = CH$PTR (outdev);
outjfn [$gjdir] = CH$PTR (outdir);
outjfn [$gjnam] = CH$PTR (outnam);
outjfn [$gjext] = CH$PTR (outtyp);
!
! Set up for new file with next higher
! generation number.
!
outjfn [$gjgen] = gj_fou + gj_msg + gj_xtn;
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('New index file: '); ! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, ro_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .ro_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
disp_flags [dsp$k_outjfn] = 1;
IF confirm () EQL ss$_success !
THEN
EXITLOOP; ! Leave and return success
disp_flags [dsp$k_outjfn] = 0;
END
ELSE
BEGIN
SIGNAL (.ro_status [cmdsts$g_status]); ! Parse not "success"
disp_flags [dsp$k_outjfn] = 0;
END;
END;
RETURN ss$_success; ! Return OK
END; ! End R_OFILE
%SBTTL 'Unload script routines'
ROUTINE u_ifile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
ui_question_handler, ! Condition handler for this routine
ui_initialize : NOVALUE, ! Called by .CMINI function
ui_take_action : NOVALUE; ! Called by parser
OWN
ui_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
ui_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = ui_initialize, !
context = ui_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMIFI
function = $cmifi, !
flags = cm_sdh, !
help = 'RMS indexed file to unload',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = ui_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = ui_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = ui_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE ui_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE ui_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
ui_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
infab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE ui_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_injfn] = 0;
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
ui_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = injfn; ! Point to GTJFN block
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('File to unload: '); ! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, ui_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .infab [fab$h_jfn] NEQ 0 ! Release JFN if we have one
THEN
BEGIN
rljfn (.infab [fab$h_jfn]); ! Release it
infab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .ui_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Check to make sure that the file we
! have been given is an RMS indexed file.
!-
infab [fab$a_xab] = summary; ! Add summary XAB
IF NOT $open (fab = .infab) ! Check out the file
THEN
BEGIN
SIGNAL (ss$_rms_error, .infab);
END
ELSE
BEGIN
!+
! Check to make sure the file is indexed
!-
IF .infab [fab$v_org] NEQ fab$k_idx !
THEN
BEGIN
SIGNAL (ss$_input_not_indexed);
infab [fab$v_drj] = 0; ! Get rid of the JFN
IF NOT $close (fab = .infab) !
THEN
SIGNAL (ss$_rms_error, .infab);
END
ELSE
BEGIN
!+
! Close the input file, but
! keep a hold of the JFN.
!-
disp_flags [dsp$k_injfn] = 1;
infab [fab$v_drj] = 1; ! Do not release JFN
IF NOT $close (fab = .infab) !
THEN
SIGNAL (ss$_rms_error, .infab);
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF u_ofile () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_injfn] = 0;
END;
END;
END
ELSE
BEGIN
SIGNAL (.ui_status [cmdsts$g_status]); ! Parse not "success"
disp_flags [dsp$k_injfn] = 0;
END;
END;
RETURN ss$_success; ! Return OK
END; ! End U_IFILE
ROUTINE u_ofile =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
uo_question_handler, ! Condition handler for this routine
uo_initialize : NOVALUE, ! Called by .CMINI function
uo_take_action : NOVALUE; ! Called by parser
OWN
uo_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
uo_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = uo_initialize, !
context = uo_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMOFI
function = $cmofi, !
flags = cm_sdh, !
help = 'new sequential file',
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = 0), !
action = uo_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = uo_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = uo_status, ! Status variable
next = 1)))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE uo_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_jsys_error_return; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE uo_take_action (jfn, b, returned_context : REF $cmdsts_block) :
NOVALUE =
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Do we already have a JFN?
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
uo_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
outfab [fab$h_jfn] = .jfn;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE uo_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
disp_flags [dsp$k_outjfn] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN if needed
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
uo_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
setup_stateblock (); ! Initialize the state block
stateblock [$cmgjb] = outjfn; ! Point to GTJFN block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
cmderr = true; ! Handle our own errors
start_state = 0; ! Start here normally
stateblock [$cmrty] = $stptr ('Sequential output file: ');
! Set prompt
WHILE 1 DO
BEGIN
MAP
stateblock : monblock [];
comnd_error = comand (.start_state, stateblock, uo_states);
! Get the command
SELECTONE 1 OF
SET
[.stateblock [$cmflg, cm_nop]] :
BEGIN
start_state = 0;
SIGNAL (ss$_jsys_error_return, .comnd_error);
END;
[.stateblock [$cmflg, cm_rpt]] :
BEGIN
start_state = 2; ! Set reparse state
IF .outfab [fab$h_jfn] NEQ 0 ! Release JFN
THEN
BEGIN
rljfn (.outfab [fab$h_jfn]); ! Release it
outfab [fab$h_jfn] = 0; ! Zero it
END;
END;
[OTHERWISE] :
BEGIN
start_state = 0;
EXITLOOP;
END;
TES;
END;
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .uo_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
IF .summary [xab$b_nok] GTR 1 ! More than one key?
THEN
BEGIN
disp_flags [dsp$k_outjfn] = 1;
IF u_getkey () EQL ss$_success ! All OK?
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_outjfn] = 0;
END
ELSE
BEGIN
disp_flags [dsp$k_outjfn] = 1;
infab [fab$g_ctx] = 0; ! Default to 0
IF confirm () EQL ss$_success !
THEN
EXITLOOP; ! OK
END;
END
ELSE
BEGIN
SIGNAL (.uo_status [cmdsts$g_status]); ! Parse not "success"
disp_flags [dsp$k_outjfn] = 0;
END;
END;
RETURN ss$_success; ! Return OK
END; ! End U_OFILE
ROUTINE u_getkey =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS
!
! NONE.
!
! IMPLICIT INPUTS
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
FORWARD ROUTINE
ug_question_handler, ! Condition handler for this routine
ug_initialize : NOVALUE, ! Called by .CMINI function
ug_take_action : NOVALUE; ! Called by parser
OWN
ug_status : $cmdsts_block, ! Status from this parse
!
! Parsing states and transitions
!
ug_states : $comand_states ( !
$comand_state ( ! 0
$comand_flddb ( ! .CMINI
function = $cmini, !
action = ug_initialize, !
context = ug_status, !
next = 2)), !
$comand_state ( ! 1
$comand_flddb ( ! .CMCFM
function = $cmcfm, !
next = -1)),
$comand_state ( ! 2
$comand_flddb ( ! .CMNUM
function = $cmnum, !
flags = cm_sdh, !
help = CH$PTR (hlpbuf), !
data = 10, ! Key number in decimal
context = $command_status ( !
status = ss$_success, !
next = 0, ! No branching here
context = -1), ! Special instructions
action = ug_take_action,
! Do something w/ the JFN
next = 1, !
more = !
$comand_flddb ( ! Get the "<" with .CMTOK
function = $cmtok, !
data = '<', !
flags = cm_sdh, ! Suppress help
help = '"<" to go back to previous question',
action = set_backup, ! Signal a backup
context = ug_status,
! Address of status variable
next = 1, !
more = !
$comand_flddb ( ! Get a "*" with .CMTOK
function = $cmtok, !
data = '*', !
flags = cm_sdh, ! Suppress help
help = '"*" to display current status',
action = set_display, !
context = ug_status, ! Status variable
next = 1, !
more = !
$comand_flddb ( ! Default to 0
function = $cmcfm, !
action = ug_take_action, !
flags = cm_sdh, !
help = 'Return for default (key = 0)',
context = $command_status ( !
status = ss$_success, !
next = 0, !
context = 0), !
next = -1))))));
!+
! INITIALIZE is called by COMAND after the .CMINI function
! is called. It sets up the default status and "next routine"
! if necessary.
!-
ROUTINE ug_initialize (a, b, info : REF $cmdsts_block) : NOVALUE =
BEGIN
info [cmdsts$g_status] = ss$_success; ! Just in case
info [cmdsts$a_next_routine] = 0;
info [cmdsts$g_context] = 0;
RETURN;
END; ! End INITIALIZE
!+
! TAKE_ACTION is called when COMAND parses a field or keyword.
! It sets up the status block with the information from the
! context/command-status block of the FLDDB or keyword-entry.
!-
ROUTINE ug_take_action (key_number, b, returned_context : REF $cmdsts_block)
: NOVALUE =
BEGIN
ug_status [cmdsts$g_status] = .returned_context [cmdsts$g_status];
IF .returned_context [cmdsts$g_context] EQL -1 ! Use data?
THEN
infab [fab$g_ctx] = .key_number
ELSE
infab [fab$g_ctx] = 0;
RETURN;
END; ! End TAKE_ACTION
!+
! QUESTION_HANDLER is the condition handler for this particular
! routine. It handles backing up and unwinding.
!-
ROUTINE ug_question_handler (sig : REF VECTOR, mech : REF VECTOR, enbl : REF
VECTOR) =
BEGIN
BIND
cond = sig [1],
return_value = mech [1];
SELECTONE .cond OF
SET
[ss$_backup] :
BEGIN
return_value = ss$_backup;
SETUNWIND ();
RETURN true;
END;
[ss$unw] :
BEGIN
disp_flags [dsp$k_unload_key] = 0;
infab [fab$g_ctx] = 0;
RETURN false;
END;
[ss$_reparse] :
BEGIN
RETURN true;
END;
[OTHERWISE] : ! Resignal anything else
RETURN false;
TES;
END; ! End QUESTION_HANDLER
ENABLE
ug_question_handler; ! Enable our handler
!+
! Loop until the user gives us a valid response. The only
! two ways out of this loop are the EXITLOOP when a call
! successful and to signal an UNWIND one way or another.
!-
WHILE 1 DO
BEGIN
LOCAL
comnd_error, ! Status returned by COMAND
start_state; ! State to start/restart parse
!
! Set up the help message
!
control = $fao_ctl ('key number from 0 to !UL!%^@');
fprm [0] = .summary [xab$b_nok] - 1;
$faol (ctrstr = .control, prmlst = fprm, outbuf = hlpdsc);
setup_stateblock (); ! Initialize the state block
cmderp = 0; ! No special error message
cmdrpt = 2; ! Reparse after .CMINI
stateblock [$cmrty] = $stptr ('Key for unloading [0]: ');
! Set prompt
comand (0, stateblock, ug_states); ! Get the command
!+
! If the status returned is SUCCESS, then
! we call the next routine down; otherwise, we
! SIGNAL with the status we received.
!-
IF .ug_status [cmdsts$g_status] EQL ss$_success ! Everything OK?
THEN
BEGIN
!+
! Make sure the value returned is within range
!-
IF .infab [fab$g_ctx] LSS 0 OR !
.infab [fab$g_ctx] GTR (.summary [xab$b_nok] - 1) !
THEN
BEGIN
SIGNAL (ss$_out_of_range, 0, (.summary [xab$b_nok] - 1));
END
ELSE
!+
! Call the next routine below us. If the
! return is successful, then we can exit the
! loop and work our way back to the top of
! the stack of calls. If the return is not
! successful, it is a request for backing up,
! and we stay in the loop.
!-
disp_flags [dsp$k_unload_key] = 1;
IF confirm () EQL ss$_success !
THEN
EXITLOOP; ! The only way out
disp_flags [dsp$k_unload_key] = 0;
END
ELSE
BEGIN
SIGNAL (.ug_status [cmdsts$g_status]); ! Parse not "success"
disp_flags [dsp$k_unload_key] = 0;
END;
END;
RETURN ss$_success; ! Return OK
END; ! End U_GETKEY
END
ELUDOM