Trailing-Edge
-
PDP-10 Archives
-
decuslib10-11
-
43,50544/contrl.bli
There is 1 other file named contrl.bli in the archive. Click here to see a list.
!<BLF/lowercase_user>
!<BLF/uppercase_key>
MODULE contrl ( !
IDENT = '8.2'
) =
BEGIN
!++
! Facility:
!
! BLISS Language Formatter.
! Abstract:
!
! This module contains routines which provide for optional control
! of PRETTY, by means of full-line comments of the form
! !<Blf/...>.
!
! REVISION HISTORY
!
! 12-Feb-82 TT This reinstated Xport version had spelling
! mistakes in the macros for Noformat, Error,
! and Noerror in CTL$COMMAND. Noformat was not
! being recognized. Error seemed to work okay
! but it was fixed as well.
!
! 12-Feb-82 TT Set up to handle the new /LOG /NOLOG switch.
!
! END OF REVISION HISTORY
!--
!<blf/page>
!
! Table of contents:
!--
FORWARD ROUTINE
ctl$command : NOVALUE,
ctl$init : NOVALUE,
ctl$switch,
get_dec;
!
! Include files:
!--
REQUIRE 'BLFCSW'; ! Defines control switches, i.e. 'sw_...'
REQUIRE 'BLFIOB'; ! XPORT i-o blocks
REQUIRE 'BLFMAC'; ! Defines macros 'lex', 'msg', 'write'
REQUIRE 'TOKTYP'; ! Defines 'token' and the token type values 's_...'
REQUIRE 'UTLCOD'; ! Defines error codes, i.e. 'er_...'
!
! Macros:
!--
!
! Equated symbols:
!--
LITERAL
true = 1 EQL 1,
false = 1 NEQ 1;
!
! Global storage
!--
EXTERNAL
log_flag;
!
! Own storage:
!--
OWN
!+
! All the items here are initialized in ctl$init.
!-
debug_flag :, !
error, ! Flag for messages.
macro_flag, ! Flag for macro-formatting
page_width, ! Width of printed page
plit_flag, ! Flag for PLIT-formatting
rem_tabs, ! Number of tabs to remark column
!+
! The following two switches can take on the values
! 0 = No converison, 1 = Force lower case, 2 = Force upper case.
! 0 is the default value.
!-
user_case, ! Case switch for user names
key_case; ! Case switch for keywords
!
! External references:
!--
EXTERNAL ROUTINE
lex$def_synonym,
out$eject,
out$ntbreak,
out$set_tab,
scn$fin_verb,
scn$init,
scn$set_in_unit,
scn$strt_verb,
utl$error;
GLOBAL ROUTINE ctl$command (cp) : NOVALUE = !
!++
! Functional description:
!
! This routine analyses input comments of the form
! !<Blf/...>
! which are used to provide controls to the Formatter.
!
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
!<Blf/page>
BEGIN
LOCAL
ccp; ! Char pointer
MACRO
blf_text =
'!<BLF/'%,
blf_text_len = %CHARCOUNT (blf_text)%,
debug_text = 'DEBUG'%,
debug_text_len = %CHARCOUNT (debug_text)%,
nodbg_text = 'NODEBUG'%,
nodbg_text_len = %CHARCOUNT (nodbg_text)%,
req_text = 'REQUIRE'%,
req_text_len = %CHARCOUNT (req_text)%,
fmt_text = 'FORMAT'%,
fmt_text_len = %CHARCOUNT (fmt_text)%,
nofmt_text = 'NOFORMAT'%,
nofmt_text_len = %CHARCOUNT (nofmt_text)%,
PAGE_text = 'PAGE'%,
PAGE_text_len = %CHARCOUNT (PAGE_text)%,
rem_text = 'REMARK:'%,
rem_text_len = %CHARCOUNT (rem_text)%,
error_text = 'ERROR'%,
error_text_len = %CHARCOUNT (error_text)%,
noerr_text = 'NOERROR'%,
noerr_text_len = %CHARCOUNT (noerr_text)%,
MACRO_text = 'MACRO'%,
MACRO_text_len = %CHARCOUNT (MACRO_text)%,
nomac_text = 'NOMACRO'%,
nomac_text_len = %CHARCOUNT (nomac_text)%,
PLIT_text = 'PLIT'%,
PLIT_text_len = %CHARCOUNT (PLIT_text)%,
NOPLIT_text = 'NOPLIT'%,
NOPLIT_text_len = %CHARCOUNT (NOPLIT_text)%,
syn_text = 'SYNONYM'%,
syn_text_len = %CHARCOUNT (syn_text)%,
WIDTH_text = 'WIDTH:'%,
WIDTH_text_len = %CHARCOUNT (WIDTH_text)%,
UC_text = 'UPPERCASE'%,
UC_text_len = %CHARCOUNT (UC_text)%,
LC_text = 'LOWERCASE'%,
LC_text_len = %CHARCOUNT (LC_text)%,
NOC_text = 'NOCASE'%,
NOC_text_len = %CHARCOUNT (NOC_text)%,
KEY_text = '_KEY'%,
KEY_text_len = %CHARCOUNT (KEY_text)%,
USER_text = '_USER'%,
USER_text_len = %CHARCOUNT (USER_text)%;
!+
! A comment line of appropriate form has been found by
! lex$getsym. CP is a char pointer which points to a command
! line (full-line comment) whose first 6 chars are assured to be
! "!<BLF/".
!-
ccp = CH$PLUS (.cp, BLF_TEXT_LEN); ! Skip over "!<BLF/"
IF CH$EQL (debug_text_len, .ccp, !
debug_text_len, CH$PTR (UPLIT(debug_text))) ! 'DEBUG'
THEN
debug_flag = true;
IF CH$EQL (nodbg_text_len, .ccp, !
nodbg_text_len, CH$PTR (UPLIT(nodbg_text))) ! 'NODEBUG'
THEN
debug_flag = false;
!------------
IF CH$EQL (req_text_len, .ccp, !
req_text_len, CH$PTR (UPLIT(req_text))) ! 'REQUIRE'
THEN
BEGIN
LOCAL
ch,
cccp,
len;
ccp = CH$PLUS (.ccp, req_text_len);
ch = 0;
UNTIL .ch EQL %C'''' DO
ch = CH$RCHAR_A (ccp); ! Find the first quote
cccp = .ccp; ! Mark start of file name
ch = len = 0;
UNTIL .ch EQL %C'''' DO
(ch = CH$RCHAR_A (cccp); len = .len + 1; );
$xpo_iob_init ( !
default = (4, CH$PTR (UPLIT ('.REQ'))), !
iob = req_iob);
IF XPO$_normal NEQ $xpo_open ( !
file_spec = (.len - 1, .ccp), !
options = input,
iob = req_iob)
THEN
utl$error (er_file_spec)
ELSE
BEGIN
scn$set_in_unit (req_iob);
scn$init ();
END;
END;
!------------
IF CH$EQL (page_text_len, .ccp, !
page_text_len, CH$PTR (UPLIT(page_text))) ! 'PAGE'
THEN
BEGIN
scn$fin_verb (); ! Resume automatic formatting
out$ntbreak ();
out$eject (0); ! New page starts
out$set_tab (true);
END;
!------------
IF CH$EQL (nofmt_text_len, .ccp, ! Check for beginning
nofmt_text_len,
CH$PTR (UPLIT(nofmt_text))) ! 'NOFORMAT'
THEN
scn$strt_verb ();
IF CH$EQL (fmt_text_len, .ccp, ! and end of
fmt_text_len,
CH$PTR (UPLIT(fmt_text))) ! 'FORMAT'
THEN
scn$fin_verb ();
!------------
IF CH$EQL (rem_text_len, .ccp, ! Check for remark tabs
rem_text_len, CH$PTR (UPLIT(rem_text))) ! 'REMARK:'
THEN
BEGIN
ccp = CH$PLUS (.ccp, rem_text_len);
rem_tabs = get_dec (ccp);
IF .rem_tabs LSS 3 OR .rem_tabs GTR 15 THEN rem_tabs = 6;
END;
!------------
IF CH$EQL (error_text_len, .ccp, !
error_text_len, CH$PTR (UPLIT(error_text))) ! 'ERROR'
THEN
error = true;
IF CH$EQL (noerr_text_len, .ccp, !
noerr_text_len, CH$PTR (UPLIT(noerr_text))) ! 'NOERROR'
THEN
error = false;
!------------
IF CH$EQL (macro_text_len, .ccp, !
macro_text_len, CH$PTR (UPLIT(macro_text))) ! 'MACRO'
THEN
macro_flag = true;
IF CH$EQL (nomac_text_len, .ccp, !
nomac_text_len, CH$PTR (UPLIT(nomac_text))) ! 'NOMACRO'
THEN
macro_flag = false;
!------------
IF CH$EQL (plit_text_len, .ccp, !
plit_text_len, CH$PTR (UPLIT(plit_text))) ! 'PLIT'
THEN
PLIT_flag = true;
IF CH$EQL (noplit_text_len, .ccp, !
noplit_text_len, CH$PTR (UPLIT(noplit_text))) ! 'NOPLIT'
THEN
PLIT_flag = false;
!------------
IF CH$EQL (syn_text_len, .ccp, !
syn_text_len, CH$PTR (UPLIT(syn_text))) ! 'SYNONYM'
THEN
lex$def_synonym (CH$PLUS (.ccp, syn_text_len));
!------------
IF CH$EQL (width_text_len, .ccp, ! Check for page width
width_text_len, CH$PTR (UPLIT(width_text))) ! 'WIDTH:'
THEN
BEGIN
ccp = CH$PLUS (.ccp, width_text_len);
page_width = get_dec (ccp);
IF .page_width LSS 40 OR .page_width GTR 140 THEN page_width = 110;
END;
!------------
IF CH$EQL (lc_text_len, .ccp, !
lc_text_len, CH$PTR (UPLIT(lc_text))) ! 'LOWERCASE'
THEN
BEGIN
ccp = CH$PLUS (.ccp, lc_text_len);
IF CH$EQL (key_text_len, .ccp, key_text_len, !
CH$PTR (UPLIT(key_text))) ! '_KEY'
THEN
key_case = sw_locase;
IF CH$EQL (user_text_len, .ccp, !
user_text_len, CH$PTR (UPLIT(user_text))) ! '_USER'
THEN
user_case = sw_locase;
IF CH$EQL (1, .ccp, 1, CH$PTR (UPLIT('>'))) THEN user_case = key_case = sw_locase;
END;
!------------
IF CH$EQL (uc_text_len, .ccp, !
uc_text_len, CH$PTR (UPLIT(uc_text))) ! 'UPPERCASE'
THEN
BEGIN
ccp = CH$PLUS (.ccp, uc_text_len);
IF CH$EQL (key_text_len, .ccp, !
key_text_len, CH$PTR (UPLIT(key_text))) ! '_KEY'
THEN
key_case = sw_upcase;
IF CH$EQL (user_text_len, .ccp, !
user_text_len, CH$PTR (UPLIT(user_text))) ! '_USER'
THEN
user_case = sw_upcase;
IF CH$EQL (1, .ccp, 1, CH$PTR (UPLIT('>'))) THEN user_case = key_case = sw_upcase;
END;
!------------
IF CH$EQL (noc_text_len, .ccp, !
noc_text_len, CH$PTR (UPLIT(noc_text))) ! 'NOCASE'
THEN
BEGIN
ccp = CH$PLUS (.ccp, noc_text_len);
IF CH$EQL (key_text_len, .ccp, !
key_text_len, CH$PTR (UPLIT(key_text))) ! '_KEY'
THEN key_case = sw_nocase;
IF CH$EQL (user_text_len, .ccp, !
user_text_len, CH$PTR (UPLIT(user_text))) ! '_USER'
THEN user_case = sw_nocase;
IF CH$EQL (1, .ccp, 1, CH$PTR (UPLIT('>'))) THEN user_case = key_case = sw_nocase;
END;
END; ! End of routine 'ctl$command'
GLOBAL ROUTINE ctl$init : NOVALUE = !
!++
! Functional description:
!
! This routine initializes the default values of the control
! variables.
! Formal parameters:
!
! None
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
debug_flag = false;
error = true;
rem_tabs = 6;
page_width = 110;
key_case = user_case = sw_nocase;
macro_flag = false;
plit_flag = false;
END; ! End of routine 'ctl$init'
GLOBAL ROUTINE ctl$switch (switch) = !
!++
! Functional description:
!
! This routine returns the current value of the control
! switch specified in the argument.
!
! Formal parameters:
!
! Switch is the name of a control switch.
! Available options for switch are:
! sw_debug
! sw_error
! sw_key_case
! sw_user_case
! sw_rem_tabs
! sw_page_width
! sw_macro
! sw_log
!
! Implicit inputs:
!
! None
!
! Implicit outputs:
!
! None
!
! Routine value:
!
! None
!
! Side effects:
!
! None
!
!--
BEGIN
SELECTONE .switch OF
SET
[sw_debug] :
RETURN .debug_flag;
[sw_macro] :
RETURN .macro_flag;
[sw_error] :
RETURN .error;
[sw_key_case] :
RETURN .key_case;
[sw_user_case] :
RETURN .user_case;
[sw_plit] :
RETURN .plit_flag;
[sw_rem_tabs] :
RETURN .rem_tabs;
[sw_page_width] :
RETURN .page_width;
[sw_log] :
RETURN .log_flag;
TES;
RETURN 0; ! Default
END; ! End of routine 'ctl$switch'
ROUTINE get_dec (cpin) = !
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine converts a digit string into a number.
! It is used in the interpretation of control commands
! for PRETTY.
!
! FORMAL PARAMETERS:
!
! cpin = the character pointer to the first (expected) digit.
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
!
! The value in decimal of the digit string.
!
! SIDE EFFECTS:
!
! The character pointer is advanced beyond the first nondigit
! character encountered.
!
!--
BEGIN
LOCAL
ch,
num;
num = 0;
ch = CH$RCHAR_A (.cpin);
WHILE .ch GEQ %C'0' AND !
.ch LEQ %C'9' DO
BEGIN
num = .num*10 + (.ch - %C'0');
ch = CH$RCHAR_A (.cpin);
END;
RETURN .num;
END; ! End of routine 'get_dec'
%TITLE 'Last page of CONTRL.BLI'
END ! End of module 'contrl'
ELUDOM