!<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