Google
 

Trailing-Edge - PDP-10 Archives - bb-4157h-bm_fortran20_v10_16mt9 - fortran-compiler/scan0.bli
There are 12 other files named scan0.bli in the archive. Click here to see a list.
!COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1976, 1985
!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 WHICH IS NOT SUPPLIED BY DIGITAL.

! Author: *

MODULE SCAN0=
BEGIN

GLOBAL BIND SCAN0V = #10^24 + 0^18 + 0;	! Version Date: 21-Nov-80

%(

***** Begin Revision History *****

***** End Revision History *****

)%



%(
	HERE WE DEFINE THE MACROS THAT ALLOW THE
	SCANNER TO PERATE:
)%
%(
	THE VARIABLE "ZPROD" CONTAINS A POINTER TO THE
	PRODUCTION TABLE VECTOR

	  ........................................
	  .                                      .
	0 .      BUFFER ADDRESS                  .
	  .                                      .
	  ........................................
	  .                   .                  .
	1 . TRACE TBL         .   PROD TBL       .
	  .                   .                  .
	  ........................................
	  .                   .                  .
	2 .  EXPLAIN TABLE    .   SWITCHES       .
	  .                   .                  .
	  ........................................

	IN ADDITION, THE FOLLOWING EXTERNAL DATA
	ITEMS MUST BE SAVED:

	N-REGISTER		QN
	A-REGISTER		QA[4]
	CHARACTER REGISTER	QCHAR
	MACHINE STATE		QSTATE
	SCAN POSITION		ZPOS

)%
	MACRO QBIND=BIND VECTOR QPROD=.ZPROD$,
		TBIND=BIND TRACET QTRACET=(.QPROD[1]<18,18>)<0,36>$,
		MBIND=BIND MACHINE QMACH=.QPROD[1]<0,18>$;

	MACRO	QBUFF=QPROD[0]$,	% ADDRESS OF BUFFER %
		QTRSW=QPROD[2]<0,2>$,	% TRACE SWITCH %
		QFIX=QPROD[2]<2,1>$,	% FIX SWITCH %
		QMSGX=QPROD[2]<3,1>$,	% MESSAGE SWITCH %
		QHALTS=QPROD[2]<4,1>$;	% HALT SWITCH %
	MACRO	QEXPL=QPROD[2]<18,18>$;
	GLOBAL ZPROD, QN, QCHAR, QSTATE, ZPOS, VECTOR QA[4];
	STRUCTURE MACHINE [S,E]=[S*5]((.MACHINE+(.S*5)+.E)<0,36>);
	MACRO	QLABEL=0$,
		QTRY=1$,
		QACT=2$,
		QSNA=3$,
		QERR=3$,
		QNEXT=4$;
	MACRO	LABLE=QMACH[.QSTATE,QLABEL]$,
		CHAR=QMACH[.QSTATE,QTRY]$,
		ACTION=QMACH[.QSTATE,QACT]$,
		NEXT=QMACH[.QSTATE,QNEXT]<18,18>$,
		SNEXT=QMACH[.QSTATE,QNEXT]<0,18>$,
		SNA=QMACH[.QSTATE,QSNA]$,
		ERRCOD=QMACH[.QSTATE,QERR]$,
		SUBDO=3,1$,	% SUBROUTINE CALL %
		SDO=0,1$,
		NDO=2,1$,
		ADO=1,1$;
	MACRO	TRALL=QTRSW<0,1>$,
		TRMATCH=QTRSW<1,1>$;

EXTERNAL WRITE,TTYPUTS;
EXTERNAL PUTMSG;
EXTERNAL BINOUT,DECOUT,OCTOUT;
EXTERNAL INT2ASC;
EXTERNAL VECTOR IOZERROR;
EXTERNAL IOERR,IOPANIC;
EXTERNAL QTRCA,QTRCB,QTRCC;
EXTERNAL CRLF;

FORWARD

QSCAN,		%( 2
		)%
QPARSE,		%(
		)%
QLOOP,		%(
		)%
QSUBR,		%(
		)%
QRETURN,	%(
		)%
QMATCH,		%(
		)%
QERROR,		%(
		)%
QERRS,		%(
		)%
QFIXMACH,	%(
		)%
QSETBIN,	%(
		)%
QSETOCT,	%(
		)%
QSETDIG,	%(
		)%
QPACK,	%(
		)%
QHALT,		%(
		)%
QEXPLAIN,	%(
		)%
QALPHA,		%(
		)%
QNUM,		%(
		)%
QNULL;		%(
		)%
ROUTINE QSCAN=
    BEGIN
%(	THE FUNCTION OF QSCAN IS TO DELIVER A CHARACTER TO THE
	PRODUCTION INTERPRETER VIA CELL ZCHAR.  THE CHAR IS
	OBTAINED FROM A STANDARD BUFFER WHICH CONTAINS
	PACKED OR UNPACKED 7-BIT CHARACTERS.
)%
	STRUCTURE LINE[I]=(..LINE+.I+3);
	QBIND;
	BIND LINE ZBUF1=QBUFF;
	MACRO	BSIZE=ZBUF1[-3]$,
		BCNT=ZBUF1[-2]$,
		BPTR=ZBUF1[-1]$;

	IF .ZPOS GEQ .BSIZE THEN 
	    BEGIN
		QCHAR_#015;
		ZPOS_.ZPOS+1;
		RETURN;
	    END;
	QCHAR_SCANI(BPTR);
	ZPOS_.ZPOS+1;
    END;
GLOBAL ROUTINE QPARSE(X,VECT)=
	BEGIN
%(
	THE FUNBTION OF THIS ROUTINE IS TO PARSE A 
	PARAMETER LIST AND SET UP CHNLTAB.  THE FORMAT OF
	THE PARAMETER LIST IS:

CHNL-NO = DEV: FILE .EXT [PROJ ,PROG] <STATUS> /S1 /S2 ... /SN

	ANY OR ALL OF THESE MAY BE OMITTED.  THOSE OMITTED
	WILL CAUSE THE DEFAULTS TO BE USED.  THE 
	SPECIFIC DEFAULTS ARE SET BY THE ROUTINE "DEFAULTS()"
	AND ARE DEPENDENT ON THE SPECIFIC SYSTEM USING
	THE I/O PACKAGE.

	IF CHNL-NO IS DEFAULTED, THE LAST CHANNEL NUMBER IS
	INCREMENTED BY 1.  IF DEVICE IS DEFAULTED, THE LAST
	SPECIFIED DEVICE IS USED.  THE INITIAL VALUES ARE
	CHNL_0, DEV_'DSK:'.

	NOTE THAT EITHER PART OF THE PPN MAY BE DEFAULTED.
	IF THE PROJ IS DEFAULTED THEN PROGM UST BE PRECEDED
	BY A ','  E.G.
		[1,2]
		[1]  (THE CURRENT PROG NO IS USED
		[1,]   ( SAME AS ABOVE)
		[,2]	   (THE CURRENT PORG NO IS USED)
		[]  A NULL PPN SPECIFIER USES THE LAST PPN GIVEN
			EXPLICITLY IN THE STRING

	THE PARSING IS DONE BY A PRODUCTION SCHEME WHERE
	PRODUCTIONS ARE OF THE FORM:
	
	LABEL  CHAR  ACTION  SNA  NEXT

	LABEL IS A NUMERIC LABEL OF THE PRODUCTION. 0 => NO LABEL
	CHAR IS THE CHARACTER WHICH IS TRYING FOR A MATCH
		THE SPECIAL META-CLASSES ARE:
		<SG>  MATCHES ANY CHAR   00
		<LT>  MATCHES A-Z        01
		<DG>  MATCHES 0-9        02
		<BI>  MATCHES 0 OR 1     03
		<AN>  MATCHES A-Z,0-9    04
		<CR>  MATCHES CR/LF      05

		VALUES #06-#37 ARE RESERVED FOR ADDITIONAL METACHARS
	
	ACTION CONTAINS THE NAME OF A BLISS ROUTINE

	SNA CONTAINS THE SCAN FLAGS AND CLEAR FLAGS
		#1 (TRUE)--SCAN FOR NEXT CHAR
		#2 (FALSE)-CLEAR THE A-ACCUMULATOR
		#4 (FALSE)-CLEAR THE N-ACCUMULATOR

		CLEARING IS DONE AFTER THE ACTION PART AND
		BEFORE THE NEXT IS TAKEN

	NEXT CONTAINS THE LABEL OF THE NEXT PRODUCTION. 0 =>
	     	TAKE THE SEQUENTIALLY NEXT PRODUCTION.
)%
		BIND VECTOR QPROD=.VECT; MBIND;
%(
	QSTATE: THE STATE THE MACHINE IS IN
	QHALTS: SET TO 1, INDICATES END OF SUCCESSFUL PARSE
	QA:     THE "A-REGISTER" USED TO ACCUMULATE ALPHA DATA
	QN:     THE "N-REGISTER" USED TO ACCUMULATE NUMERIC DATA
	QCHAR:  THE CHARACTER JUST PICKED UP BY THE SCANNER
	
	QTRSW:  THE TRACE SWITCH   1=> TRACE ALL, 2=> TRACE MATCHES
	QFIX:   INDICATES WHETHER PRODUCTIONS HAVE BEEN FIXED UP
		1=> NEED FIXING; 0=> DO NOT NEED FIXING

	QMSGX:	1=> QERRS OUTPUTS MESSAGES; 0=> DOES NOT
)%
	LOCAL T;
	LOCAL VECTOR SAVZ[10];
	MACRO QSAVE=SAVZ[1]_.ZPROD; SAVZ[3]_.QN;
		SAVZ[4]_.QA[0]; SAVZ[5]_.QA[1]; SAVZ[6]_.QA[2];
		SAVZ[7]_.QA[3]; SAVZ[8]_.QCHAR; SAVZ[9]_.QSTATE;
		SAVZ[10]_.ZPOS$,
	      QRESTORE=ZPROD_.SAVZ[1];  QN_.SAVZ[3];
		QA[0]_.SAVZ[4]; QA[1]_.SAVZ[5]; QA[2]_.SAVZ[6];
		QA[3]_.SAVZ[7]; QCHAR_.SAVZ[8]; QSTATE_.SAVZ[9];
		ZPOS_.SAVZ[10]$;
	
	QSAVE;
	ZPROD_.VECT;
	QMSGX_.X;
	ZPOS_QSTATE_QHALTS_0;
	IF NOT .QFIX THEN
	    BEGIN
		QFIXMACH(); QFIX_1;
	    END;
	IF NOT QLOOP() THEN (QRESTORE; RETURN 0);
	QRESTORE;
	RETURN 1;  % VALUE OF QPARSE IS TRUE %
END;
ROUTINE QLOOP=
BEGIN
	QBIND; MBIND;
	LOCAL T;
% THIS IS THE PRODUCTION INTERPRETER LOOP %
	UNTIL .QHALTS DO 
	BEGIN
	IF .TRALL THEN QTRCA();
	IF QMATCH() THEN
		% AT THIS POINT, WE HAVE MATCHED A PRODUCTION %
	    BEGIN
		IF .TRMATCH THEN QTRCA();
		IF .TRMATCH OR .TRALL THEN QTRCB();
		IF (.ACTION)() THEN  RETURN 0;
		% PERFORM ACTION PART.  IF ACTION RETURNS 1
		  THEN AN ERROR OCCURED.  QUIT AND RETURN FALSE
		  AS VALUE OF QPARSE %

		T_.SNA;
		IF .T<ADO> THEN 
			(QA[1]_QA[2]<36,7>;QA[0]_QA[2]_QA[3]_0);
		IF .T<NDO> THEN QN_0;
		IF .T<SDO> THEN QSCAN(0);
		IF .TRMATCH OR .TRALL THEN QTRCC();
		IF .T<SUBDO> THEN (IF QSUBR() THEN RETURN 0; QSTATE_.QSTATE+1) ELSE
			QSTATE_.NEXT;
	    END
	    ELSE
	    BEGIN
		% AT THIS POINT A PRODUCTION HAS FAILED %
		QSTATE_.QSTATE+1;
	    END;
	END;
	RETURN 1;
    END;
GLOBAL ROUTINE QSUBR=
     BEGIN
%(
       THIS  ROUTINE  ACCOMPLISHES  THE SUBROUTINE-PRODUCTION CALL BY
    SAVING THE STATE IN "QS" AND USING THE "NEXT" OF  THE  PRODUCTION
    WHICH  CALLED  IT  AS  THE  SUBROUTINE ADDRESS.  UUPON SUCCESSFUL
    RETURN (QRETURN) FROM THE  SUBROUTINE,  QSTATE  IS  RESTORED  AND
    CONTROL  GOES  TO  THE NEXT PRODUCTION AFTER THE SUBROUTINE CALL.
    UPON FAILURE, THE VALUE "1" IS RETURNED  TO  THE  INCARNATION  OF
    QLOOP  WHICH  CALLED  THE  SUBROUTINE.   HENCE SUBROUTINES MAY BE
    NESTED TO ANY DEPTH.  NOTE THAT QHALT MAY OCCUR ONLY AT  THE  TOP
    LEVEL OF SUBROUTINING AT THE MOMENT.
)%
	LOCAL QS,T;
	QBIND; MBIND;
	QS_.QSTATE; 	% SAVE CURRENT STATE %
	QSTATE_.NEXT;	% GO TO SUBROUTINE %
	T_QLOOP();	% GO EXECUTE THE SBUROUTINE %
	QHALTS_0;	% QHALTS GOT US BACK, RESET IT %
	QSTATE_.QS;
	NOT .T		% RETURN 1 IF FAILURE, 0 IF SUCCESS %
    END;
GLOBAL ROUTINE QRETURN=
%(
       THIS  ROUTINE IS USED TO ACCOMPLISH A RETURN FROM A PRODUCTION
    SUBROUTINE.   IT DOES THIS BY SETTING QHALTS AND THUS TERMINATING
    THE  PARTICULAR  INCARNATION  OF  THE  QLOOP  ROUTINE IN CONTROL.
    FUNCTIONALLY IT IS NO DIFFERENT THAT QHALT, BUT IT IS A  SEPARATE
    ROUTINE  SO  THAT  (1) WE ALWAYS KNOW WE ARE LEAVING A SUBROUTINE
    AND NOT THE MAIN PRODUCTION ROUTINE AND (2) IN CASE WE CONJURE UP
    A DIFFERENT SUBROUTINE SCHEME THE PRODUCTIONS WILL NOT HAVE TO BE
    CHANGED.
)%
     BEGIN
	QBIND;
	QHALTS_1;
    END;
ROUTINE QMATCH=
%(
       THIS ROUTINE IS USED BY THE PRODUCTION INTERPRETER  MAIN  LOOP
    TO  DECIDE  WHETHER  OR  NOT A PRODUCTION MATCHES.  IT TREATS THE
    CHARACTERS #000-#037 IN THE PRODUCTIONS AS  METACHARACTERS.   THE
    CURRENT LIST OF ACCEPTABLE METACHARACTERS IS GIVEN BELOW.  IF THE
    CHARACTER IS IN THE RANGE  #40-#177  THEN  AN  EXACT  COMPARE  IS
    REQUIRED  FOR A MATCH.  IF THE METACHARACTER IS OUT OF RANGE, AND
    ERROR CONDITION IS ASSUMED, AND IOERR(18) IS CALLED.  IF THIS  IS
    AN  IGNORED  MESSAGE,  THEN  QMATCH  RETURNS  ZERO, INDICATING NO
    MATCH.
)%
BEGIN
 QBIND; MBIND;
    LOCAL T;
    IF (T_.CHAR) EQL 0 THEN RETURN 1;
    % <SG> ALWAYS MATCHES  %
    IF .T LSS #040 THEN
	BEGIN
	IF .T GTR 5 THEN (QERRS(25); RETURN 0);
    	%WE NOW ATTEMPT TO MATCH METACHARACTERS %
	RETURN CASE .T-1 OF SET
	% .LT. % QALPHA();
	% .DI. % QNUM();
	% .BI. % 3 _ ( .QCHAR EQL "0" OR .QCHAR EQL "1");
	% .AN. % (QALPHA()) OR (QNUM());
	% .CR. % 3 _ ( .QCHAR EQL #015) OR (.QCHAR EQL 0);
	     TES;
	END
	ELSE
	% WE WANT TO MATCH A PARTICULAR CHARACTER %
( .T EQL .QCHAR  )
    END;
GLOBAL ROUTINE QERROR=
%(
       THIS  ROUTINE IS USED IN THE PRODUCTIONS TO FLAG AN ERROR.  IT
    CALLS QERRS() IN  THE  SAME  FASHION  AS  A  SEMANTICS  ERROR  IS
    HANDLED.  THE ERROR CODE IS OBTAINED FROM THE PRODUCTION WHICH IS
    CURRENTLY POINTED TO BY QSTATE, IN THE "ERRCOD" FIELD.
)%
	BEGIN
	QBIND; MBIND;
	QERRS(.ERRCOD);
	 1   % KILL PARSER %
    END;
ROUTINE QERRS(N)=
	BEGIN
	QBIND;
%(
       THIS  ROUTINE  WILL  PUT OUT AN ERROR MESSAGE IN THE FORM OF A
    POINTER TO THE CHARACTER POSITION IN WHICH  THE  ERROR  OCCURRED.
    THIS  MESSAGE FORMAT IS OPTIONAL AND IS PUT OUT ONLY IF QPARSE IS
    CALLED WITH ITS FIRST PARAMETER A  "1".   IF  "0"  IS  GIVEN,  NO
    MESSAGE  IS OUTPUT.  THIS IS TO ALLOW THE PARSER TO FUNCTION AS A
    COMPLETELY INTERNAL ROUTINE.

       THE FOLLOWING ERROR LIST APPLIES ONLY THE THE I/O PACKAGE  AND
    IS KEPT HERE FOR CONVENIENCE.  THE MESSAGES ARE OBTAINED BY THE ?
    REQUEST TO QEXPLAIN (WHICH MUST BE CODED IN THE PRODUCTIONS)  AND
    HENCE ARE NOT FIXED.

	ERROR	MEANING
	1
	2	ILLEGAL CHAR IN CHANNEL, DEVICE OR FILE PORTION
	3	ILLEGAL CHAR IN FILE SPECIFIER
	4	ILLEGAL CHAR IN EXTENSION PORTION
	5	ILLEGAL CHAR BETWEEN "[" AND "," OR "]"
	6	ILLEGAL CHAR BETWEEN "," AND "]"
	7	ILLEGAL CHAR AFTER "]"
	8	ILLEGAL CHAR BETWEEN "<" AND ">"
	9	ILLEGAL CHAR AFTER ">"
	10	MORE THAN 6 CHARS IN DEVICE, FILE, OR EXTENSION
	11	NUMBER (AS CHANNEL OR PPN) > 2**18-1
	12	CHANNEL (EXPLICIT OR IMPLICIT) >16 OR <1
	13	ILLEGAL CHARACTER IN SWITCH SPECIFICATION
	14	EXTENSION NAME > 3 CHARACTERS
	15	ILLEGAL CHARACTER FOLLOWING SWITCH SPECIFICATION
	16	ILLEGAL CHARACTER (8/9) IN PPN NO.
	17	ILLEGAL CMU PROJECT (ACCOUNT) NO.
	18	ILLEGAL CMU MAN NO.
	19	[] USED AND NO PPN PREVIOUSLY GIVEN
	20	ILLEGAL CHARACTER AFTER ?
	21	ILLEGAL VALUE FOR PROTECTION CODE
	22	ILLEGAL CHARACTER IN PROTECTION CODE
	23	ILLEGAL CHARACTER FOLLOWING "-" IN SWITCH
	24	UNABLE TO SET CHANNEL TABLE (!)
	25	ILLEGAL METACHARACTER (!)
	26	UNRESOLVABLE LABEL (!)
)%

	IF NOT .QMSGX THEN RETURN;
	IF .QTRSW NEQ 0 THEN CRLF(0);
	IF .ZPOS LSS 5 THEN
	    BEGIN
		DECR I FROM .ZPOS-1 TO 0 DO PUTMSG('.');
		PUTMSG(7^29) %DING!%;
		PUTMSG('^ ');
		DECOUT(0,0,.N);
	    END
	    ELSE
	    BEGIN
		PUTMSG('.');
		IF .N LSS 10 THEN PUTMSG('.');
		DECOUT(0,0,.N);
		DECR I FROM .ZPOS-4 TO 0 DO PUTMSG('.');
		PUTMSG(7^29); % DING! %
		PUTMSG('^');
	    END;
	CRLF(0);
	END;
ROUTINE QFIXMACH=
%(
       THE  FUNCTION  OF THIS ROUTINE IS TO RESOLVE THE "RELOCATABLE"
    ADDRESSES IN THE PRODUCTION TABLE. IT ACCOMPLISHES THIS BY MAKING
    ONE  PASS  OVER THE TABLE, COLLECTING LABEL/INDEX PAIRS, AND THEN
    MAKING A  SECOND  PASS  OVER  THE  TABLE  CHANGING  ALL  SYMBOLIC
    ADDRESSES  TO ABSOLUTE (INDEX) ADDRESSES. A SYMBOLIC ADDRESS OF 0
    WILL RESOLVE TO THE ADDRESS OF THE NEXT PRODUCTION.
)%
BEGIN
    STRUCTURE SYM[I,J]=[I*2]((.I*2+.J+.SYM)<0,36>);
    LOCAL SYM SYMTAB[50];
	MACRO	SYLAB(XX)=SYMTAB[XX,0]$,
		SYNDX(XX)=SYMTAB[XX,1]$;
	LOCAL PTR,MAX,I,MACHSZ,X;
	QBIND; MBIND;
    LOCAL T;
	LOCAL QSTATE;

% BUILD THE SYMBOL TABLE %
	QSTATE_PTR_0;
    WHILE (T_.LABLE) NEQ 999 DO
	BEGIN
	    IF .T NEQ 0 THEN % WE HAVE A LABEL %
		BEGIN
		SYLAB(.PTR)_.T;  %STORE  LABEL %
		SYNDX(.PTR)_.QSTATE;  % STORE ITS INDEX %
		PTR_.PTR+1;
		END;
	    QSTATE_.QSTATE+1;
	END;
    MACHSZ_.QSTATE;
%(
       WE  NOW  HAVE  RESOLVED  ALL THE SYMBOLS.  MACHSZ CONTAINS THE
    LENGTH OF THE PRODUCTIONS, AND  MAX  CONTAINS  THE  SIZE  OF  THE
    SYMBOL TABLE
)%
    MAX_.PTR-1;
    PTR_0;

    INCR QSTATE TO .MACHSZ DO
	BEGIN
	    NEXT_IF (T_.SNEXT) EQL 0 THEN
		% RESOLVE TO NEXT PRODUCTION %
		.QSTATE+1
		ELSE
		% LOOKUP IN SYMBOL TABLE %
		IF (X_INCR I TO .MAX DO
		    BEGIN
			IF .SYLAB(.I) EQL .T THEN EXITLOOP
			    (.SYNDX(.I));
		    END)
		      LSS 0 THEN (QERRS(26); .QSTATE+1) ELSE .X;
	END;
END;
GLOBAL ROUTINE QSETBIN=
%(
       THE FUNCTION OF THIS ROUTINE IS TO ACCUMULATE A  BINARY  VALUE
    IN THE N-REGISTER.  IT IS ASSUMED THAT THE METACHARACTER .BI. WAS
    USED IN THE PRODUCTION WHICH CALLED THIS ROUTINE, HENCE  NO  TEST
    FOR  VALIDITY  IS MADE.  NOTE THAT BINARY NUMBERS GREATER THAN 18
    BITS ARE CONSIDERED INVALID.
)%
    BEGIN
	QN_.QN*2+(.QCHAR-"0");
	IF .QN GTR #777777 THEN (QERRS(11); RETURN 1);
    END;
GLOBAL ROUTINE QSETOCT=
%(
       THE  FUNCTION  OF THIS ROUTINE IS TO ACCUMULATE AN OCTAL VALUE
    IN THE N-REGISTER.  SINCE THIS ROUTINE IS CALLED BY A  PRODUCTION
    MATCHING  THE METACHARACTER .DG. THE VALIDITY OF THE DIGIT (E.G.,
    8/9 ARE INVALID)  MUST  BE  CHECKED.   NOTE  THAT  OCTAL  NUMBERS
    REQUIRING MORE THAN 18 BITS ARE INVALID.
)%
    BEGIN
	IF .QCHAR GTR "7" THEN (QERRS(16); RETURN 1);
	QN_.QN*8+(.QCHAR-"0");
	IF .QN GTR #777777 THEN (QERRS(11); RETURN 1);
    END;
GLOBAL ROUTINE QSETDIG=
%(
       THE FUNCTION OF THIS ROUTINE IS TO ACCUMULATE A DECIMAL  VALUE
    IN  THE N-REGISTER.  SINCE THIS ROUTINE IS CALLED BY A PRODUCTION
    MATCHING THE  METACHARACTER  .DG.,  THE  VALIDITY  OF  THE  QCHAR
    REGISTER  IS  ASSUMED.   NOTE THAT DECIMAL NUMBERS REQUIRING MORE
    THAN 18 BITS ARE CONSIDERED INVALID.
)%
    BEGIN
	QN_.QN*10+(.QCHAR-"0");
	IF .QN GTR #777777 THEN 
	    BEGIN
		QERRS(11);
		RETURN 1;
	    END;
    END;
GLOBAL ROUTINE QPACK=
	BEGIN
%(

       THE  FUNCTION  OF  THIS  ROUTINE  IS TO ACCUMULATE A CHARACTER
    VALUE IN THE A-REGISTER.  ANY STRING OF UP TO SIX CHARACTERS  MAY
    BE ACCUMULATED.
  THE FORMAT OF QA IS AS FOLLOWS:
	QA[0] = COUNT OF CHARACTERS IN THE STRING
	QA[1] = BYTE POINTER FOR COMPRESSING CHARACTERS
	QA[2] = FIRST FIVE ASCII CHARACTERS
	QA[3] = NEXT FIVE ASCII CHARACTERS
 
)%
	IF (QA[0]_.QA[0]+1) GTR 6 THEN
	    BEGIN
		QERRS(10);
		RETURN 1;
	    END;
	REPLACEI(QA[1],.QCHAR);
	END;
GLOBAL ROUTINE QHALT=
%(
       THE  FUNCTION  OF  THIS  ROUTINE  IS  TO  TERMINATE  THE  MAIN
    PRODUCTION  LOOPP  (THIS  WOULD  BE  THE  HIGHEST  INCARNATION OF
    QLOOP).  IT ACCOMPLISHES THIS BY SETTING THE HALT  SWITCH.   NOTE
    THAT THIS OPERATION IMPLIES SUCCESSFUL COMPLETION OF A PARSE.
)%
	BEGIN
	QBIND;
	QHALTS_1;
	END;
GLOBAL ROUTINE QEXPLAIN=
%(
       THE FUNCTION OF  THIS  ROUTINE  IS  TO  LOOK  UP  THE  MESSAGE
    INDICATED  BY  THE N-REGISTER AND OUTPUT IT TO THE TELETYPE.  THE
    USUAL METHOD IS BY USING A ? FOLLOWED BY AN INTEGER.   NOTE  THAT
    THIS   ROUTINE  ALWAYS  INDICATES  AN  UNSUCCESSFUL  PARSE,  THUS
    ENABLING THE TTY SETUP ROUTINE TO RECALL THE PARSER  TO  GET  THE
    NEXT LINE (GLITCH! GLITCH! BUT A SNEAKY ONE!)
)%
    BEGIN
	QBIND;
	BIND VECTOR QMSG=(.QEXPL)<0,36>;
	IF QMSG EQL 0 THEN RETURN PUTMSG('!!!NO',' MESS','AGE T',
			'ABLE');
	IF .QN GTR .(QMSG-1) THEN QN_0;
	TTYPUTS(.QMSG[.QN]);
	1
    END;
ROUTINE QALPHA=
    BEGIN
%(
	WE RETURN TRUE IF QCHAR IS A-Z AND FALSE OTHERWISE
)%
	(.QCHAR GEQ "A" AND .QCHAR LEQ "Z" )
    END;
ROUTINE QNUM=
    BEGIN
%( 
	WE RETURN TRUE IF QCHAR IS 0-9 AND FALSE OTHERWISE
)%
	(.QCHAR GEQ "0" AND .QCHAR LEQ "9")
    END;
GLOBAL ROUTINE QNULL=BEGIN END;
%(
****************************************************************
*                                                              *
*   ALL ROUTINES BEYOND  THIS POINT BELONG TO THE              *
*   BLISS I/O ROUTINES                                         *
*                                                              *
****************************************************************
)%

GLOBAL ZEXT, ZPPN, ZCHAN, ZDEV[2], ZFILE[2], ZSTATUS, ZSWITCH,
	ZPPNL, ZPROT;
GLOBAL ZNSWITCH;
%(
	STATUS WORD BITS
)%
MACRO
	FUSER=0,18$,	% ENTIRE USER FIELD %
	FYEND=0,1$,	% ENDFILE ALLOWED %
	FYREW=1,1$,	% REWIND ALLOWED  %
	FYREAD=2,1$,	% READING ALLOWED %
	FYWRITE=3,1$,	% WRITING ALLOWED %
	FYUPDAT=4,1$,	% UPDATING ALLOWED %
	FYDUMMY=5,1$,	% DUMMY CHANNEL   %
	FYERR=6,1$,	% WRITE ERRORS NOT TRAPPED %
	FPRIMARY=7,1$,	% PRIMARY DEFAULT VALUE %

% SYSTEM BITS OF STATUS WORD %
	FSYS=18,18$,	% ENTIRE SYSTEM FIELD %
	FROPEN=18,1$,	% FILE OPEN FOR INPUT %
	FWOPEN=19,1$,	% FILE OPEN FOR OUTPUT %
	FEOF=20,1$,	% ENDFILE ENCOUNTERED %
	FIS35=21,1$,	% BIT 35 IS SET %
	FSET35=22,1$,	% SET BIT 35 ON NEXT WRITE %
	FSEQ=24,1$,	% PROCESSING SEQUENCE NO. %
	FPGMK=25,1$,	% PROCESSING PAGE MARK %
	FFISTAR=26,1$,	% FILE NAME IS "*" %
	FXSTAR=27,1$,	% EXTENSION NAME IS "*" %
	FUOPEN=28,1$,	% FILE OPEN FOR UPDATE %
	FNSET=35,1$;	% CHANNEL NOT SET %
MACRO
	XFYEND=1^0$,	% ENDFILE ALLOWED %
	XFYREW=1^1$,	% REWIND ALLOWED  %
	XFYREAD=1^2$,	% READING ALLOWED %
	XFYWRITE=1^3$,	% WRITING ALLOWED %
	XFYUPDAT=1^4$,	% UPDATE ALLOWED %
	XFYDUMMY=1^5$,	% DUMMY CHANNEL %
	XFYERR=1^6$,	% ALLOW WRITE ERROR TRAP %
	XFPRIMARY=1^7$;	% PRIMARY DEFAULT VALUE %
%(
	MACROS WHICH DEFINE THE CALLS TO SETTBL/GETTBL
)%
MACRO	UMAX=0$,	% MAXIMUM CHANNEL %
	UMODE=1$,	% DATA MODE %
	UDEV=2$,	% DEVICE IN SIXBIT %
	UOBUFF=3$,	% OUTPUT BUFFER HEADER POINTER %
	UIBUFF=4$,	% INPUT BUFFER HEADER POINTER %
	UOBUFFR=5$,	% ADDR OF OUTPUT BUFFER %
	UOPTR=6$,	% OUTPUT BUFFER BYTE POINTER %
	UOCNT=7$,	% OUTPUT BUFFER BYTE COUNT %
	UIBUFFR=8$,	% ADDR OF INPUT BUFFER %
	UIPTR=9$,	% INPUT BUFFER BYTE POINTER %
	UICNT=10$,	% INPUT BUFFER BYTE COUNT %
	UFILE=11$,	% FILE NAME IN SIXBIT %
	UEXT=12$,	% EXTENSION NAME IN SIXBIT %
	UBLK=13$,	% %
	UERR=14$,	% ERROR NUMBER %
	UPROT=15$,	% PROTECTION KEY %
	UDMODE=16$,	% CREATION DATA MODE %
	UTIME=17$,	% CREATION TIME %
	UDATE=18$,	% CREATION DATE %
	UPPN=19$,	% PPN %
	USTAT=20$,	% USER BITS OF STATUS WORD %
	USSTAT=21$,	% SYSTEM BITS OF STATUS WORD %
	USWITCH=22$,	% SWITCH WORD %
	UREPROT=23$;	% REPROTECTION WORD %
MACRO	USIZ=24$;	% FILE SIZE %

EXTERNAL SETTBL, GETTBL, SETCHN;
EXTERNAL CMUDEC;
EXTERNAL GETPPN;

FORWARD
QEXT,
QPROJ,
QPROG,
QSET,
QFIXSW,
QRESET,
QSETCHN,
QINCCHN,
QDEVICE,
QFILE,
QSETUP,
QDEFLTSTAT,
QSWITCH,
QNOTSW,
QPPNL,
QSETSTAT,
QCMUPJ,
QCMUPG,
QSETPROT;
GLOBAL ROUTINE QEXT=
	BEGIN
%(
 THIS ROUTIND SETS THE EXTENSION REGISTER ZEXT TO THE
  SPECIFIED EXTENSION NAME GIVEN IN QA 
)%
	IF .QA[0] GTR 3 THEN BEGIN 
		% THE EXTENSION NAME IS TOO LONG
		  Q E R R S   1 4    %
		QERRS(14);
		RETURN 1;   %CAUSE PARSING TO CEASE %
		END;
	ZEXT_IF .QA[2] EQL 0 THEN '   ' ELSE .QA[2];
	END;
GLOBAL ROUTINE QPROJ=
    BEGIN
	ZPPN<18,18> _ IF .QN EQL 0 THEN (GETPPN())^(-18) ELSE .QN<0,18>;
    END;
GLOBAL ROUTINE QPROG=
    BEGIN
     	ZPPN<0,18>_IF .QN EQL 0 THEN (GETPPN()) AND #777777 ELSE .QN<0,18>;
    END;
GLOBAL ROUTINE QSET=
    BEGIN
	IF .ZSTATUS EQL 0 THEN QDEFLTSTAT();
	IF .ZNSWITCH NEQ 0 THEN QFIXSW;
	(IF NOT SETCHN(.ZCHAN,0,ZDEV,ZFILE,ZEXT,.ZPPN<18,18>,.ZPPN<0,18>,.ZSTATUS,.ZSWITCH,.ZPROT) THEN (QERRS(24);1) ELSE 0)
    END;
ROUTINE QFIXSW=
     BEGIN
	SETTBL(.ZCHAN,USWITCH, GETTBL(.ZCHAN,USWITCH) AND .ZNSWITCH);
    END;
GLOBAL ROUTINE QRESET=
    BEGIN
	IF .ZPPN NEQ 0 THEN ZPPNL_.ZPPN;
	ZPROT_0;
	ZSWITCH_ZFILE[0]_ZFILE[1]_ZEXT_ZPPN_ZSTATUS_0;
	ZNSWITCH_-1;
    END;
GLOBAL ROUTINE QSETCHN=
    BEGIN
	IF .QN GTR 16 OR .QN LSS 1 THEN
	    BEGIN
		QERRS(12);
		RETURN 1;
	    END;
	ZCHAN_.QN;
    END;
GLOBAL ROUTINE QINCCHN=
    BEGIN
	IF (ZCHAN_.ZCHAN+1) GTR 16 OR .ZCHAN LSS 1 THEN
	    BEGIN
		QERRS(12);
		RETURN 1;
	    END;
    END;
GLOBAL ROUTINE QDEVICE=
    BEGIN
	IF .QA[0] EQL 0 % NULL DEVICE % THEN
	BEGIN
	ZDEV[0]_'DSK  ';
	ZDEV[1]_' ';
	END
	ELSE
	BEGIN
	ZDEV[0]_.QA[2];
	ZDEV[1]_.QA[3];
	END;
    END;
GLOBAL ROUTINE QFILE=
    BEGIN
	ZFILE[0]_.QA[2];
	ZFILE[1]_.QA[3];
    END;
GLOBAL ROUTINE QSETUP=
    BEGIN
	ZPPN_ZPPNL_0;     % SO WE START OFF ON RIGHT FOOT %
	QRESET();
	ZDEV[0]_ZDEV[1]_ZCHAN_0;
	ZDEV[0]_'DSK  ';
	ZDEV[1]_' ';
    END;
ROUTINE QDEFLTSTAT=
    BEGIN
	ZSTATUS_GETTBL(.ZCHAN,USTAT);  ZSTATUS<FPRIMARY>_0;
    END;
GLOBAL ROUTINE QSWITCH=
    BEGIN
	IF QALPHA() THEN ZSWITCH<.QCHAR-"A",1>_1 ELSE
		IF QNUM()  THEN ZSWITCH<.QCHAR-"0"+26,1>_1 ELSE
			(QERRS(13); RETURN 1);
    END;
GLOBAL ROUTINE QNOTSW=
    BEGIN
	IF QALPHA() THEN ZNSWITCH<.QCHAR-"A",1>_0
		ELSE IF QNUM() THEN  ZNSWITCH<.QCHAR-"0"+26,1>_0 ELSE
			(QERRS(23); RETURN 1);
    END;
GLOBAL ROUTINE QPPNL=
	BEGIN
	IF .ZPPNL EQL 0 THEN (QERRS(19);RETURN 1);
	ZPPN_.ZPPNL;
	END;
GLOBAL ROUTINE QSETSTAT=
    BEGIN
	ZSTATUS_.QN;
    END;
GLOBAL ROUTINE QCMUPJ=
    BEGIN
	LOCAL T,TL;
	T_CMUDEC(.QA[2],0);
	TL_.QN;
	QN_.T<18,18>;
	QPROJ();
	QN_.TL;
    END;
GLOBAL ROUTINE QCMUPG=
    BEGIN
	LOCAL T,TL;
	T_CMUDEC(0,.QA[2]);
	TL_.QN;
	QN_.T<0,18>;
	QPROG();
	QN_.TL;
    END;
GLOBAL ROUTINE QSETPROT=
	BEGIN
	IF .QN GTR #777 THEN (QERRS(21); RETURN 1);
	ZPROT_(.QN OR #1000);
END;
END ELUDOM