Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
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