! File:   IO.BLI
!
Module IO =
Begin

Require 'Bliss';
Require 'Rms';

External Routine
	STR$COPY_DX,
	LIB$STOP,
	SYS$GET,
	SYS$PUT,
	SYS$OPEN,
	SYS$CREATE,
	SYS$CLOSE,
	SYS$CONNECT,
	SYS$DISCONNECT,
	CLI$GET_VALUE,
	CLI$PRESENT;

Bind
	STR_P1		= %Ascid 'P1',
	STR_LIST	= %Ascid 'LIST',
	STR_DEBUG	= %Ascid 'DEBUG',
	STR_ZIP		= %Ascid 'ZIP',
	STR_OPTIMIZE	= %Ascid 'OPTIMIZE',
	STR_PIC		= %Ascid 'PIC',
	STR_UNAMES	= %Ascid 'UNAMES',
	STR_EXPAND	= %Ascid 'EXPAND',
	STR_I_D		= %Ascid 'I_D',
	STR_FINAL	= %Ascid 'FINAL',
	STR_HYDRA	= %Ascid 'HYDRA',
	STR_QUICK	= %Ascid 'QUICK',
	STR_ERRORS	= %Ascid 'ERRORS',
	STR_STATISTICS	= %Ascid 'STATISTICS',
	STR_MARK	= %Ascid 'MARK',
	STR_PEEP	= %Ascid 'PEEP',
	STR_DUMP	= %Ascid 'DUMP',
	STR_DUMP_FLOWAN	= %Ascid 'DUMP.FLOWAN',
	STR_DUMP_DELAY	= %Ascid 'DUMP.DELAY',
	STR_DUMP_TNBIND	= %Ascid 'DUMP.TNBIND',
	STR_DUMP_ALL	= %Ascid 'DUMP.ALL',
	STR_PAGE	= %Ascid 'PAGE',
	STR_OUTPUT	= %Ascid 'SYS$OUTPUT';

Own
	src_buff	: Vector[256,Byte],
	lst_buff	: Vector[256,Byte],
	tty_buff	: Vector[256,Byte],
	tty_ptr		: Ref Vector[,Byte] Initial(tty_buff),
	lst_ptr		: Ref Vector[,Byte] Initial(lst_buff),
	lineno		: Integer,
	pageno		: Integer,
	flg_page	: Boolean,
	flg_valid	: Boolean,
	str_lstfile	: Block[8,Byte],
	str_srcfile	: Block[8,Byte],
	srcfile		: Vector[256,Byte],
	srcfab		: $fab(dnm='.b11'),
	lstfab		: $fab(dnm='.lis',rat=CR),
	ttyfab		: $fab(fnm='sys$output',rat=CR),
	srcrab		: $rab(fab=srcfab,ubf=src_buff,usz=256),
	lstrab		: $rab(fab=lstfab,rbf=lst_buff),
	ttyrab		: $rab(fab=ttyfab,rbf=tty_buff);

Global Routine ParseCcl : Novalue =
Begin
    $init_dyndesc(str_lstfile);
    $init_dyndesc(str_srcfile);
    swit_debug      = CLI$PRESENT(STR_DEBUG);
    swit_zip        = CLI$PRESENT(STR_ZIP);
    swit_unames     = CLI$PRESENT(STR_UNAMES);
    swit_expand     = CLI$PRESENT(STR_EXPAND);
    swit_optimize   = CLI$PRESENT(STR_OPTIMIZE);
    swit_hydra      = CLI$PRESENT(STR_HYDRA);
    swit_quick      = CLI$PRESENT(STR_QUICK);
    swit_mark       = CLI$PRESENT(STR_MARK);
    swit_i_d        = CLI$PRESENT(STR_I_D);
    swit_pic        = CLI$PRESENT(STR_PIC);
    swit_peep       = CLI$PRESENT(STR_PEEP);
    swit_final      = CLI$PRESENT(STR_FINAL);
    swit_errors     = CLI$PRESENT(STR_ERRORS);
    swit_page       = CLI$PRESENT(STR_PAGE);
    swit_statistics = CLI$PRESENT(STR_STATISTICS);
    swit_list       = CLI$PRESENT(STR_LIST);
    If CLI$PRESENT(STR_DUMP) Then
	Begin
	swit_dump_flowan = CLI$PRESENT(STR_DUMP_FLOWAN);
	swit_dump_delay  = CLI$PRESENT(STR_DUMP_DELAY);
	swit_dump_tnbind = CLI$PRESENT(STR_DUMP_TNBIND);
	If CLI$PRESENT(STR_DUMP_ALL) Then
	    swit_dump = -1
	End;
    If .swit_list Then
	CLI$GET_VALUE(STR_LIST,str_lstfile)
    Else
	str$copy_dx(str_lstfile,STR_OUTPUT);
    CLI$GET_VALUE(STR_P1,str_srcfile);
    ch$move(.str_srcfile[dsc$w_length],
		.str_srcfile[dsc$a_pointer],
		srcfile)
End;

Global Routine OpenFiles : Novalue =
Begin
    Local
	STS;

! initialize the FAB's

    srcfab[fab$l_fna] = .str_srcfile[dsc$a_pointer];
    srcfab[fab$b_fns] = .str_srcfile[dsc$w_length];
    lstfab[fab$l_fna] = .str_lstfile[dsc$a_pointer];
    lstfab[fab$b_fns] = .str_lstfile[dsc$w_length];

! open the source file

    sts = sys$open(srcfab);
    If Not .sts Then
	lib$stop(.sts,.srcfab[fab$l_stv]);
    sys$connect(srcrab);

! create the list file

    sts = sys$create(lstfab);
    If Not .sts Then
	lib$stop(.sts,.lstfab[fab$l_stv]);
    sys$connect(lstrab);

! note whether the list file is a terminal and if so, turn off
! paging

    flg_tty = (.lstfab[fab$l_dev] And DEV$M_TRM) Neq 0;
    If .flg_tty Then
	flg_page = FALSE;

! open the terminal

    sts = sys$create(ttyfab);
    If Not .sts Then
	lib$stop(.sts,.ttyfab[fab$l_stv]);
    sys$connect(ttyrab);

! initialize the source buffer

    src_buff[0] = 0;
    pbuff = src_buff
End;

Global Routine CloseFiles : Novalue =
Begin
    SYS$DISCONNECT(LSTRAB);
    SYS$CLOSE(LSTFAB);
    SYS$DISCONNECT(SRCRAB);
    SYS$CLOSE(SRCFAB);
    SYS$DISCONNECT(TTYRAB);
    SYS$CLOSE(TTYFAB)
End;

! OUTPUT A CHUNK (WORD OR CHAR) TO THE PLACE SPECIFIED
! BY THE VALUE OF THE GLOBAL VARIABLE DEVICE.
! DEVICE= 1 --> TTY (TTYDEV)
!	  2 --> BINARY DEVICE (BINDEV)
!	  4 --> LISTING DEVICE (LSTDEV)
!	  5 --> LISTING DEVICE AND TTY (ERRDEV)

Global Routine OUTPUT(ch) : Novalue =
Begin
    If .DEVICE<0,1> Then
	ch$wchar_a(.ch,tty_ptr);
    If .DEVICE<1,1> Then
	ch$wchar_a(.ch,lst_ptr)
End;

Global Routine PUNT(NUM) : Novalue =
Begin
    Print(AZ('%3mPUNT! #%d\n\n'),.NUM);
    lib$stop(1)
End;

Global Routine QUIT(NUM) : Novalue =
Begin
    Print(AZ('%3mQUIT! #%d\n\n'),.NUM);
    lib$stop(1)
End;

Global Routine STOP(NUM) : Novalue =
Begin
    Print(AZ('%3mSTOP! #%d\n\n'),.NUM);
    lib$stop(1)
End;

Global Routine PAGE : Novalue =
Begin
    flg_page = FALSE;
    pageno = .pageno+1;
    NLINES = 0;
    If .swit_list And .swit_page Then
	Print(AZ('%b%2m\f; BLISS-11 V1.0\t\t%s\tPage %d\n\n%e'),
		srcfile,.pageno)
End; ! OF PAGE

Global Routine DELNAME(DTIND) =
Begin
    Literal
	SELECTOFI=%x'7fffffff',
	OFINDEX=15;		! SEE DETREMAIN AND OF1
    Local
	P		: Ref ST;
    Own
	TEMP		: Vector[2,Byte];

    If .DTIND Eql SELECTOFI Then
	DTIND = OFINDEX;
    DTIND<lex_reswd> = FALSE;
    P = .DTPF[.DTIND];
    If .P NEQA 0 Then
	Return .P[st_name];
    TEMP[0] = .DTIND;
    TEMP[1] = 0;
    Return TEMP
End;

Global Routine OUTSYM(S : Ref GT) : Novalue =
Begin
    Local
	P		: Ref NT;

    Case .S<lex_type> From 0 To 12 Of Set
	[0]: ! DELIMITER LEXEME
	    ;

	[1]: ! LITERAL--PRINT AS OCTAL
	    Print(AZ('#%d'),.S<lex_value>);

	[2]: ! BOUND VARIABLE--PRINT NAME
	    Print(AZ('%s'),.S[st_name]);

	[3]: ! GT TYPE--PRINT ADDRESS IN BRACKETS
	    Print(AZ('[%x]'),.S<lex_addr>);

	[4]: ! ERROR LEXEME
	    Print(AZ('ERR-LEX'));

	[5]: ! LONG STRING
	    Begin
	    OUTPUT('''');
	    OUT11STR(.S);
	    OUTPUT('''')
	    End;

	[6]: ! SHORT STRING
	    Print(AZ('''%c%c'''),.S<lex_value> And 127,.S<lex_value> ^ (-8));

	[7]: ! STRUCTURE ACTUAL
	    Print(AZ('STRACT-%d'),.S<lex_addr>);

	[8]: ! UNBOUND VARIABLE
	    Print(AZ('%s'),S[nt_data]);

	[9]: ! SPECIAL FUNCTION LEXEME--STE IN ADDF
	    Print(AZ('%s'),.S[st_name]);

	[10]: ! MACRO LEXEME--UNBOUND VARIABLE IN ADDF
	    Print(AZ('MACRO-%s'),.S[st_name]);

	[11]: ! SPECIAL FUNCTION LEXEME (EXPANSION)
	    Print(AZ('%s'),.S[st_name]);

	[12]: ! MACRO ACTUAL
	    Print(AZ('MACRACT-%d'),.S<lex_addr>)
    Tes
End;

!
! ROUTINE TO OUTPUT BLIS11 STRING.
!
!  LEXEME ASSUMED OF TYPE LSLEXTYP OR LITTYP.
!  NOTE:  BLIS11 CHARACTER SEQUENCE IS LOW-ORDER 8 BITS
!  FOLLOWED BY HIGH-ORDER 8 BITS.
!
Global Routine OUT11STR(LEX : Ref GT) : Novalue =
Begin
    Local
        HEAD            : Ref ST,
        CUR             : Ref ST;

    If .LEX<lex_type> Eql T_LITERAL Then
	Print(AZ('%c%c'),.LEX<lex_value> And 127,.LEX<lex_value> ^ (-8))
    Else
        Begin
        HEAD = .LEX<lex_addr>;
        CUR = .HEAD[cel_top];
        Incr I From 1 To .HEAD[plit_length] Do
            Begin
	    LEX = .CUR[plit_lexeme];
	    Print(AZ('%c%c'),.LEX<lex_value> And 127,.LEX<lex_value> ^ (-8));
            CUR = .CUR[cel_next]
            End
        End
End;

! OUTPUT CR,LF SEQUENCE AND SKIP TO TOP OF PAGE IF NECESSARY

Global Routine OUTCRLF : Novalue =
Begin
    If .DEVICE<0,1> Then
	Begin
	TTYRAB[RAB$W_RSZ] = .tty_ptr - tty_buff;
	SYS$PUT(TTYRAB);
	tty_ptr = tty_buff
	End;
    If .DEVICE<1,1> Then
	Begin
	LSTRAB[RAB$W_RSZ] = .lst_ptr - lst_buff;
	SYS$PUT(LSTRAB);
	lst_ptr = lst_buff
	End;
    If .swit_list Then
	Begin
	NLINES = .NLINES+1;
	If .NLINES Gtr 51 Then
	    PAGE()
	End
End;

! THIS ROUTINE FORCES OUT THE CURRENT INPUT BUFFER LINE
! IF IT IS VALID (IE, IT HASN'T BEEN PRINTED ALREADY.
! THE GLOBAL VARIABLE DEVICE SPECIFIES THE OUTPUT DEVICE.

Global Routine FORCELINE : Novalue =
Begin
    If .flg_valid Then
	Begin
	flg_valid = FALSE;
	If .flg_page Then
	    PAGE();
	flg_page = FALSE;
	Print(AZ('; %4d%c\t\t%s\n'),.lineno,.SCANTYPE,src_buff)
        End
End;

!
! READ THE NEXT INPUT LINE INTO 'src_buff', PRINTING THE PREVIOUS
! LINE IF THIS HAS NOT ALREADY BEEN DONE (EG., BY AN ERROR
! MESSAGE. A LINE NUMBER IS ASSIGNED TO THE INPUT LINE.
!
Global Routine READALINE : Novalue =
Begin
    Local
	STS;

    FORCELINE();
    If Not .flg_eof Then
	Begin
	lineno = .lineno + 1;
	STS = SYS$GET(SRCRAB);
	If Not .STS Then
	    Begin
	    If .STS Neq RMS$_EOF Then
		LIB$STOP(.STS,.SRCRAB[RAB$L_STV]);
	    flg_eof = TRUE
	    End
	Else
	    Begin
	    flg_valid = TRUE;
	    src_buff[.SRCRAB[RAB$W_RSZ]] = 0
	    End
	End;
    If .flg_eof Then
	Begin
	src_buff[0] = ' ';
	src_buff[1] = ';';
	src_buff[2] = ')';
	src_buff[3] = 0;
	Selectone .SCANTYPE Of Set
	    ['C']:
		Begin
		ERRPRNT(0,.pos_scan,ERUNTCOM);
		src_buff[0] = '%';
		ERRLEVEL = 1
		End;
	    ['M']:
		Begin
		ERRPRNT(.pos_open,.pos_scan,ERUNTMAC);
		src_buff[0] = '$';
		ERRLEVEL = 1
		End
	Tes
	End;
    pos_char = .lineno^16;
    PBUFF = src_buff
End;

Global Routine FIRSTONE(N) =
Begin
    If .N Eql 0 Then
	Return -1;
    Incr I From 0 To 63 Do
	If .N<.I,1> Then
	    Return .I;
    Return -1
End;

End
Eludom