! File:   IO.BLI
!
Module IO =
Begin

Library 'sys$library:starlet.l64';
Require 'Bliss';

Literal
	SZ_INCLUDE	= 10 + 256/8,
	SZ_FAB		= FAB$K_BLN / 8,
	SZ_RAB		= RAB$K_BLN / 8;

Macro
	SZ_C_STRING(n)	= ((n+8) / 8) %;

External Routine
	STR$COPY_DX,
	LIB$STOP,
	CLI$GET_VALUE,
	CLI$PRESENT;

Forward Routine
	file_finished	: Novalue;

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_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';

!
! character class codes:
!	0	digit
!	1	letter
!	2	quote
!	3	punctuation
!	4	white space
!	5	end-of-line
!	6	invalid
!
! note:	digit and letter must be 0,1 respectively.
!

Bind
    TYPETAB = Uplit Byte (
		5,6,6,6,6,6,6,6,6,4,4,6,4,4,6,6,
		6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
		4,5,6,6,1,7,6,2,3,3,3,3,3,3,3,3,
		0,0,0,0,0,0,0,0,0,0,3,3,3,3,3,6,
		3,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
		1,1,1,1,1,1,1,1,1,1,1,3,3,3,3,1,
		6,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
		1,1,1,1,1,1,1,1,1,1,1,6,6,6,6,6
	) : Vector[,Byte];

! notes:
!	flg_eject	set when the maximum number of lines
!			per page is reached in OutCrlf().
!			cleared by Page().
!			tested by OutCrlf() to see if Page()
!			should be called.
!
!	flg_form	set when a formfeed in a source line
!			is seen.
!			cleared by Page().
!			tested by ForceLine() to see if Page
!			should be called.
!
!	lineno		count of number of lines written to
!			the list file for the current page.
!			reset at the start of each page.
!
!	pageno		page number incremented each time a
!			page eject is performed.
!
!	flg_valid	indicates that the current source line
!			in src_buff has not yet been written
!			out to the listing file.
!
!	device		mask of devices to write to.
!			device<0,1> = TTY
!			device<1,1> = LST
!
!	pos_char	encoded source file line number and column.
!			pos_char<16,16> = line number
!			pos_char< 0,16> = column
!
!	tty_ptr,	pointers into tty_buff, lst_buff,
!	lst_ptr,	and src_buff respectively
!	src_ptr
!
!	ttyfab,ttyrab	VMS control blocks for terminal and list file
!	lstfab,lstrab
!
!	srcrab		pointer to VMS control blocks for the
!			source file.  this is a pointer because
!			source files may be stacked up due to
!			includes.
!
!	srcfile		name of source file for page titles and errors

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),
	src_ptr		: Ref Vector[,Byte],
	lineno		: Integer,
	pageno		: Integer,
	flg_eject	: Boolean,
	flg_form	: Boolean,
	flg_valid	: Boolean,
	str_lstfile	: Block[8,Byte],
	str_srcfile	: Block[8,Byte],
	srcfile		: Vector[256,Byte],
	lstfab		: $fab(dnm='.lis',rat=CR),
	ttyfab		: $fab(fnm='sys$output',rat=CR),
	srcrab		: Ref Block[,Byte],
	lstrab		: $rab(FAB=lstfab,rbf=lst_buff),
	ttyrab		: $rab(FAB=ttyfab,rbf=tty_buff),
	pos_char	: Integer,
	schar		: Integer;

! routine to parse the command line switches.  DCL really did all the
! work for us so all we have to do is ask DCL for their values.

Global Routine ParseCcl : Novalue =
Begin

! initialize strings

    $init_dyndesc(str_lstfile);
    $init_dyndesc(str_srcfile);

! check for yes/no switches

    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_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);

! check for /DUMP options

    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;

! get the name of the listing file, defaulting to SYS$OUTPUT

    If .swit_list Then
	CLI$GET_VALUE(STR_LIST,str_lstfile)
    Else
	str$copy_dx(str_lstfile,STR_OUTPUT);

! get the name of the source file

    CLI$GET_VALUE(STR_P1,str_srcfile)
End;

! open the primary source or a require file

Routine OpenSource(fns : Ref Vector[,Byte],n,dns : Ref Vector[,Byte]) =
Begin
    Local
	sts		: Integer,
	pRab		: Ref Block[,Byte],
	pFab		: Ref Block[,Byte];

    ch$move(.n,.fns,srcfile);
    srcfile[.n] = 0;
    pFab = GETSPACE(SZ_FAB);
    pRab = GETSPACE(SZ_RAB);
    $FAB_INIT(FAB=.pFab,
		FNA = .fns,
		FNS = .n,
		DNA = .dns,
		DNS = 4);
    $RAB_INIT(RAB=.pRab,
		UBF = src_buff,
		USZ = 256,
		FAB = .pFab);
    sts = $open(FAB=.pFab);
    If Not .sts Then
	lib$stop(.sts,.pFab[fab$l_stv]);
    $connect(RAB=.pRab);
    schar = 0;
    Return .pRab
End;

Global Routine OpenFiles : Novalue =
Begin
    Local
	STS		: Integer;

! initialize the FAB's

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

! open the source file

    srcrab = OpenSource(.str_srcfile[dsc$a_pointer],
			.str_srcfile[dsc$w_length],AZ('.b11'));

! create the list file

    sts = $create(FAB=lstfab);
    If Not .sts Then
	lib$stop(.sts,.lstfab[fab$l_stv]);
    $connect(RAB=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_eject = FALSE;

! open the terminal

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

! initialize the source buffer

    src_buff[0] = 0;
    src_ptr = src_buff
End;

Global Routine CloseFiles : Novalue =
Begin
    $DISCONNECT(RAB=LSTRAB);
    $CLOSE(FAB=LSTFAB);
    $DISCONNECT(RAB=.srcrab);
    $CLOSE(FAB=.srcrab[rab$l_fab]);
    $DISCONNECT(RAB=TTYRAB);
    $CLOSE(FAB=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 --> LISTING DEVICE (LSTDEV)
!	  3 --> 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;

! fatal internal compiler errors come here

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;

! start a new page

Global Routine PAGE : Novalue =
Begin
    flg_eject = FALSE;
    flg_form  = 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;

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

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

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

Global Routine FORCELINE : Novalue =
Begin
    If .flg_valid Then
	Begin
	flg_valid = FALSE;
	If .flg_form Then
	    PAGE();
	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		: Integer,
	n		: Integer;

! flush out the last source line to the listing file

    FORCELINE();

! if not in an end-of-file condition...

    If Not .flg_eof Then
	Begin

! bump the line number and read the next line

	lineno = .lineno + 1;
	STS = $GET(RAB=.srcrab);

! on error, check for end-of-file and note it

	If Not .STS Then
	    Begin
	    If .STS Neq RMS$_EOF Then
		LIB$STOP(.STS,.srcrab[RAB$L_STV]);
	    flg_eof = TRUE
	    End
	Else

! on no error, note that we have a line and have not
! written it out to the list file.  also, terminate the
! line with a null and scan the line for formfeeds

	    Begin
	    flg_valid = TRUE;
	    n = .srcrab[rab$w_rsz];
	    src_buff[.n] = 0;
	    Incr i From 0 To .n-1 Do
		If .src_buff[.i] Eql 12 Then
		    Begin
		    src_buff[.i] = ' ';
		    flg_form = TRUE
		    End
	    End
	End;
    If .flg_eof Then
	Begin
	If .mac_next Neqa 0 Then
	    Begin
	    file_finished();
	    Return
	    End;
	src_buff[0] = ' ';		! may be changed to '%' or '$'
	src_buff[1] = ';';
	src_buff[2] = ')';
	src_buff[3] = 0;
	Selectone .SCANTYPE Of Set
	    ['C']:
		Begin
		ERRPRNT(0,.pos_scan,B11$_UNTERMINATED_COMMENT);
		src_buff[0] = '%';
		ERRLEVEL = TRUE
		End;
	    ['M']:
		Begin
		ERRPRNT(.pos_open,.pos_scan,B11$_UNTERMINATED_MACRO);
		src_buff[0] = '$';
		ERRLEVEL = TRUE
		End
	Tes
	End;
    pos_char = .lineno^16;
    src_ptr = src_buff
End;

Global Routine file_require(s : Ref GT) =
Begin
    Local
	p		: Ref Vector,
	n		: Integer;

    OpenSource(s[tx_data],.s[tx_size],AZ('.req'));
    p = GETSPACE(SZ_INCLUDE);
    p[0] = .pos_char;
    p[1] = .src_ptr;
    p[2] = .schar;
    p[4] = .flg_form;
    p[5] = .flg_valid;
    p[6] = (If .flg_eject Then -1 Else .pageno);
    p[7] = .srcrab;
    n = strlen(srcfile);
    p[8] = .n;
    p[9] = GETSPACE(SZ_C_STRING(.n));
    ch$move(.n+1,srcfile,.p[9]);
    ch$move(256,src_buff,p[10]);
    flg_form  = FALSE;
    flg_eject = TRUE;
    flg_valid = FALSE;
    Return .p
End;

! called by READALINE when the end of a require file is reached

Global Routine file_finished(p : Ref Vector) : Novalue =
Begin

! close the current source file

    $close(FAB=.srcrab[rab$l_fab]);
    RELEASESPACE(.srcrab[rab$l_fab],SZ_FAB);
    RELEASESPACE(.srcrab,SZ_RAB);

! restore the context of the old source file

    p = .mac_file;
    pos_char  = .p[0];
    src_ptr     = .p[1];
    schar     = .p[2];
    flg_form  = .p[4];
    flg_valid = .p[5];
    flg_eject = (.p[6] Neq .pageno);
    srcrab    = .p[7];
    flg_eof   = FALSE;
    ch$move(.p[8]+1,.p[9],srcfile);
    RELEASESPACE(.p[9],SZ_C_STRING(.p[8]));
    ch$move(256,p[10],src_buff);
    RELEASESPACE(.p,SZ_INCLUDE);
    macro_finis()
End;

! VERY LOW LEVEL INPUT. GETS A CHARACTER FROM INPUT
! BUFFER ('BUFF', POINTER 'src_ptr'), PUTTING THE CHARACTER
! IN 'CHAR' AND ITS TYPE IN 'TYPE'.
!

Routine SCANNER(char) =
Begin
    If .CHAR Eql 0 Then
	READALINE();
    CHAR = ch$rchar_a(src_ptr);
    If .CHAR Eql 9 Then
	pos_char = .pos_char Or 7;
    pos_char = .pos_char + 1;
    Return .char
End;

!
! THIS ROUTINE DOES THE PRIMARY CHARACTER SCANNING FOR
! THE COMPILER. THE VALUE RETURNED BY THE ROUTINE IS A
! LEXEME TYPE CODE.
!

Global Routine SKAN(val) =
Begin
    Local
	I		: Integer,
	K		: Integer,
	char		: Integer,
	ACCUM		: Vector[128,Byte];

    CHAR = .schar;
    K = (While TRUE Do
	Begin
	While .TYPETAB[.char] Eql 4 Do
	    char = SCANNER(.char);
	pos_atom = .pos_char;
	Case .TYPETAB[.char] From 0 To 7 Of Set

	    [0]: ! 0 - DIGITS 0-9
		Begin
		I = 0;
		While .TYPETAB[.char] Eql 0 Do
		    Begin
		    I = .I * 10 + .CHAR - '0';
		    char = SCANNER(.char)
		    End;
		.val = .I;
		Exitloop T_LITERAL
		End;

	    [1]: ! 2 - LETTERS
		Begin
		Local
		    P : Ref GT;

		If .CHAR Eql '$' And .TYPETAB[.src_ptr[0]] Neq 1 Then
		    Begin
		    char = SCANNER(.char);
		    .val = '$';
		    Exitloop T_DELIMITER
		    End;
		I = 0;
		Do
		    Begin
		    If .CHAR Geq 'a' And .CHAR Leq 'z' Then
			CHAR = .CHAR - 32;
		    ACCUM[.I] = .CHAR;
		    I = .I + 1;
		    char = SCANNER(.char)
		    End
		While .TYPETAB[.char] Leq 1;
		ACCUM[.I] = 0;
		P = SEARCH(ACCUM);
		If .P[nt_code] Neq 0 Then
		    Begin
		    .val = .P[nt_code];
		    Exitloop T_DELIMITER
		    End
		Else
		    Begin
		    .val = .p;
		    Exitloop T_NAME
		    End
		End;

	    [2]: ! 3 - SINGLE QUOTE
		Begin
		Local
			N	: Integer;

		N = 0;
		While TRUE Do
		    Begin
		    char = SCANNER(.char);
		    If .CHAR Eql '''' Then
			Begin
			char = SCANNER(.char);
			If .CHAR Neq '''' Then
			    Exitloop
			End;
		    If .CHAR Eql 0 Then
			Begin
			WARNEM(.pos_atom,B11$_MISSING_QUOTE);
			Exitloop
			End;
		    ACCUM[.N] = .CHAR;
		    N = .N + 1
		    End;
		.val = SAVESTRING(ACCUM,.N);
		Exitloop T_STRING
		End;

	    [5]: ! 5 - ! (COMMENT TERMINATED BY EOL)
		Begin
		CHAR = 0;
		char = SCANNER(.char)
		End;

	    [7]: ! 6 - % (COMMENT TERMINATED BY ANOTHER %)
		Begin
		Local SAVSCT,SAVSCC;
		SAVSCT   = .SCANTYPE;
		SAVSCC   = .pos_scan;
		SCANTYPE = 'C';
		pos_scan = .pos_char;
		Do
		    char = SCANNER(.char)
		Until .CHAR Eql '%';
		SCANTYPE = .SAVSCT;
		pos_scan = .SAVSCC;
		char = SCANNER(.char)
		End;

	    [3]: ! 7 - DELIMITER CHARACTER
		Begin
		.val = .CHAR;
		char = SCANNER(.char);
		Exitloop T_DELIMITER
		End;

	    [Inrange]:
		0;

	    [6]: ! 15 - IGNORE CHARACTER
		char = SCANNER(.char)
	Tes
	End);
    schar = .CHAR;
    Return .K
End;

End
Eludom