Trailing-Edge
-
PDP-10 Archives
-
AP-D471B-SB_1978
-
mgnutl.bli
There are no other files named mgnutl.bli in the archive.
!***COPYRIGHT (C) 1974, 1975, 1976, 1977 DIGITAL EQUIPMENT CORP., MAYNARD, MASS.***
MODULE UTL(SREG = #17, FREG = #16, VREG = #15, MLIST,TIMER=EXTERNAL(SIX12),FSAVE)=
BEGIN
! MCSGEN UTILITIES
! ====== =========
GLOBAL BIND UTL = 1;
FORWARD OUTN, ASKL, MOVE, LINK, UNLINK, COMPARE;
EXTERNAL
ZAPTRCODE,
ERROR,
WARN;
REQUIRE MGNMAC.BLI;
REQ (MGNGBL);
REQ (MGNMC2);
COMMENT;
!SOME ROUTINES TO BE ADDED
!ROUTINE SKPBLNKS=WHILE BLANK DO ADV;
!ROUTINE CMDEND=
!BEGIN
! IF EOL THEN RETURN TRUE;
! IF NEWCMD THEN RETURN TRUE;
! IF COMMENT THEN RETURN TRUE;
!END;
COMMENT;
! ROUTINE ZERO
! ======= ====
! THIS ROUTINE ZEROS LOCATIONS A THRU B INCLUSIVE
GLOBAL ROUTINE ZERO(A, %THRU% B)=
BEGIN
MACHOP BLT=#251;
REGISTER AC;
(.A)<0,36> _ 0;
IF .A GEQ .B THEN RETURN;
AC<LH> _ .A;
AC<RH> _ .A+1;
BLT(AC,.B);
END;
COMMENT;
! ROUTINE INPUT
! ======= =====
! THIS ROUTINE READS A LINE AND STORES IT IN THE BUFFER SPECIFIED IN THE
! CALL ARGUEMENTS
GLOBAL ROUTINE INPUT(BUFF,BPTR,NC,BUFFSIZE)=
BEGIN
REGISTER
X,
PBUFF,
Z;
OWN EFLAG;
EFLAG _ FALSE;
.BPTR _ PBUFF _ (.BUFF)[-1]<1,7>;
.NC_0;
Z _ .BUFFSIZE;
DO
BEGIN
X_INC;
IF .X GEQ %LOWER CASE% "a" AND .X LEQ %LOWER CASE% "z" THEN
X _ .X - #40; ! THEN MAKE IT UPPER CASE
IF (Z _ .Z - 1) GTR 0 THEN REPLACEI(PBUFF,.X)
ELSE IF .Z EQL 0 THEN ( ERROR(0); EFLAG _ TRUE )
END
WHILE .X NEQ #12;
REPLACEI( PBUFF, 0 );
ERRORFLG _ .EFLAG;
ADV(.BUFF,.BPTR,.NC,Z)
END;
COMMENT;
! ROUTINE GATHER
! ======= ======
! GATHER FORMS A WORD IN ATOM
! SIZE IS THE LENGTH OF THE STORAGE SPACE FOR THE ATOM IN CHARACTERS
! THE WORD GATHERED WILL NOT EXCEED THIS LENGTH
! FURTHER THE ATOM WILL BE CLEARED TO THE END IF NOT FILLED
! RETURNS ACTUAL LENGTH AS VALUE
! THE ATOM WILL CONSIST OF AN ARBITRARY MIXTURE OF ALPHABETIC, NUMERIC,
! AND HYPHENS
GLOBAL ROUTINE GATHER(CBUFF,CBPTR,CCOUNT,CHAR,ATOM,SIZE)=
BEGIN
REGISTER
GNC,
Z,
PACCUM;
SKIPBLANKS(.CBUFF,.CBPTR,.CCOUNT,.CHAR);
GNC_0;
PACCUM_(.ATOM)[-1]<1,7>;
WHILE (ALPHANUMERIC(.CHAR) OR ..CHAR EQL "-") DO
(IF .GNC LSS .SIZE THEN REPLACEI(PACCUM,..CHAR); ADV(.CBUFF,.CBPTR,.CCOUNT,.CHAR); GNC_.GNC+1);
IF (.GNC EQL 0) AND (..CHAR EQL "??") THEN ! PICK UP ONE CHARACTER IF NOT A <CR> AND IS A "?"
BEGIN
REPLACEI(PACCUM, ..CHAR);
ADV( .CBUFF, .CBPTR, .CCOUNT, .CHAR);
GNC _ 1
END;
Z_.GNC;
WHILE .Z LSS .SIZE DO ( Z _ .Z+1; REPLACEI(PACCUM,0)); !FILL WITH NULLS
.GNC
END;
GLOBAL ROUTINE SEARCHTABLE(TABLE,ATOM,ASIZE,TSIZE,EXECUTE)=
! TSIZE NOT IMPLEMENTED FOR VALUES NEQ 1
! RETURNS TRUE IF UNIQUE MATCH OF ATOM IN TABLE
! RETURNS FALSE IF NOT
! .EXECUTE IS SET TO TABLE[ATOM+1] IF TRUE
! OR IF FALSE THEN 0 IF ATOM NOT FOUND OR 1 IF NOT UNIQUE
! POSSIBLE MOD:
! RETURN WORD:
! BIT(0) = STATUS == GOOD/BAD
! BIT(1) = ERROR CODE == NOT-UNIQUE/NOT-FOUND
! BITS(18,36) = .TABLE[ATOM + 1]<RH>
BEGIN
REGISTER Z,ACCUM,COMMANDS,UNIQUE;
LOCAL MASK,PARTIALMATCH;
IF .TSIZE NEQ 1 OR .ASIZE GTR 5 OR .ASIZE LSS 0 THEN
BEGIN
OUTS('?? ASIZE OR TSIZE OUT OF RANGE?M?J'); OUTS('TSIZE=');
OUTD(.TSIZE) ;OUTS(' ASIZE='); OUTD(.ASIZE); CRLF; .EXECUTE_0;
RETURN
END;
%MAKE MASK%
MASK_0;
Z_MASK<36,7>;
DECR I FROM .ASIZE-1 TO 0 DO REPLACEI(Z,-1);
ACCUM_..ATOM;
COMMANDS_.TABLE;
PARTIALMATCH_-1;
UNIQUE _ FALSE;
.EXECUTE_INCR I FROM 0 TO @(.COMMANDS)[-1] BY .TSIZE+1 DO
(IF .ACCUM EQL (Z_@(.COMMANDS)[.I]) THEN EXITLOOP .I
ELSE IF .ACCUM EQL (Z_.Z AND .MASK) THEN
(UNIQUE _ IF .PARTIALMATCH LSS 0 THEN (PARTIALMATCH _ .I; TRUE) ELSE FALSE)
);
IF ..EXECUTE LSS 0 THEN
BEGIN
IF .UNIQUE EQL TRUE THEN
BEGIN
(.EXECUTE _ @(.COMMANDS)[.PARTIALMATCH+.TSIZE]; TRUE)
END
ELSE
BEGIN
(.EXECUTE _ (IF .PARTIALMATCH LSS 0 THEN 0 ELSE 1); FALSE)
END
END
ELSE
(.EXECUTE _ @(.COMMANDS)[..EXECUTE+.TSIZE]; TRUE)
END;
COMMENT;
!XTYPE ROUTINE
! ===== =======
!CALL: XTYPE(PLIT ASCIZ 'TEXT');
! OUTPUTS TEXT DEPENDING UPON MSGLEVEL
! IF MSGLEVEL IS 0 ALL TEXT IS TYPED.
! IF MSGLEVEL IS 1 ONLY THE TEXT INSIDE AT LEAST ONE LEVEL OF SQUARE
! BRACKETS [] IS TYPE
! IF MSGLEVEL IS 2 ONLY TEXT INSIDE AT LEAST TWO LEVELS OF SQUARE
! BRACKETS IS TYPED
! ETC.
! PARENTHESES HAVE THE OPPOSITE EFFECT FROM SQUARE BRACKETS, I.E.
! UNLESS THE MSGLEVEL MATCHES THE NUMBER OF PARENTHESES, THE
! TEXT WILL NOT BE TYPED
!NOTE: A ^R (OR ?R) IN THE TEXT FORCES THE NEXT CHARACTER TO BE TYPED
! REGARDLESS OF THE CHARACTER AND FURTHER THAT CHARACTER IS IGNORED
! AS FAR AS STOPPING OR LEVEL CHANGE IS CONCERNED.
! THUS TO TYPE A NULL OR SQUARE BRACKET PUT A ?R JUST BEFORE IT.
GLOBAL ROUTINE XTYPE(A)=
BEGIN
MACRO NEXT=CHAR _ SCANI(TEXTPTR)$,
ADD1(A)=A _ .A+1$,
SUB1(A)=A _ .A-1$;
REGISTER TEXTPTR,CHAR,BCOUNT,PCOUNT;
LABEL B;
TEXTPTR _ (.A)<36,7>;
BCOUNT _ 0;
PCOUNT _ 0;
WHILE 1 DO
SELECT (NEXT) OF NSET
NULLCHAR: RETURN;
CNTRLR: (NEXT; IF (.MSGLEVEL LEQ .BCOUNT) AND (.MSGLEVEL GEQ .PCOUNT) THEN OUTC(.CHAR));
LBRACKET: ADD1(BCOUNT);
RBRACKET: SUB1(BCOUNT);
LPAREN: ADD1(PCOUNT);
RPAREN: SUB1(PCOUNT);
OTHERWISE: IF (.MSGLEVEL LEQ .BCOUNT) AND (.MSGLEVEL GEQ .PCOUNT) THEN OUTC(.CHAR);
TESN
END;
GLOBAL ROUTINE OUTBUF =
BEGIN
IFSKIP OUT( OCHAN, 0 ) THEN
BEGIN
ERROR( 80 );
% ERRORMSG = 'OUTPUT FAILED IN PUTC' %
XIT %???%
END
END;
GLOBAL ROUTINE PUTC( CHAR ) =
BEGIN
IF ( OBUF[2] _ .OBUF[2] - 1 ) LEQ 0 THEN
BEGIN
OUTBUF();
END;
REPLACEI( OBUF[1], .CHAR )
END;
GLOBAL ROUTINE OUTTC( CHAR ) =
BEGIN
IF .DCHANNEL EQL TTYCHANNEL THEN OUTC( .CHAR ) ELSE PUTC( .CHAR )
END;
GLOBAL ROUTINE XPUT(A)=
BEGIN
REGISTER
CHAR,
BPTR;
BPTR _ (.A)<36,7>;
WHILE ( CHAR _ SCANI( BPTR ) ) NEQ 0 DO PUTC( .CHAR )
END;
GLOBAL ROUTINE XOUTPUT(A)=
BEGIN
IF .DCHANNEL EQL TTYCHANNEL THEN OUTSA(.A) ELSE XPUT(.A)
END;
GLOBAL ROUTINE PUTWORD( AWORD ) =
BEGIN
IF ( OBUF[2] _ .OBUF[2] - 1 ) LEQ 0 THEN
BEGIN
IFSKIP OUT( OCHAN, 0 ) THEN
BEGIN
ERROR( 81 );
% ERRORMSG = 'OUTPUT FAILED IN PUTWORD' %
XIT %???%
END
END;
OBUF[1] _ .OBUF[1] + 1;
.OBUF[1] _ .AWORD
END;
GLOBAL ROUTINE PUTBLK( FIRST, LAST ) =
BEGIN
INCR I FROM .FIRST TO .LAST DO PUTWORD( @.I );
END;
GLOBAL ROUTINE INBUF=
BEGIN
IFSKIP IN(ICHAN,0) THEN
BEGIN
ERROR( 82 );
% ERRORMSG = 'INPUT ERROR OR EOF' %
RETURN -1
END
END;
GLOBAL ROUTINE INBUFFER=
BEGIN
IFSKIP IN(ICHAN,0) THEN RETURN -1
END;
GLOBAL ROUTINE GETWORD(BUFFER)=
BEGIN
IF (IBUF[2] _ .IBUF[2]-1) LEQ 0 THEN
IF (INBUF()) LSS 0 THEN RETURN;
IBUF[1] _ .IBUF[1] + 1;
@.IBUF[1]
END;
GLOBAL ROUTINE GETBLK( FIRST, LAST ) =
BEGIN
INCR I FROM .FIRST TO .LAST DO (.I)<WORD> _ GETWORD();
END;
FORWARD OUTTSWORD;
GLOBAL ROUTINE OPENINPUTDEVICE =
BEGIN
IFSKIP OPEN(ICHAN,IOPENBLK)
THEN RETURN GOOD
ELSE
BEGIN
ERROR( 51 );
OUTTSWORD( .IOPENBLK[ 1 ] );
OUTS( ': NOT AVAILABLE OR DOES NOT EXIST?M?J' )
END;
BAD
END;
GLOBAL ROUTINE OPENOUTPUTDEVICE =
BEGIN
IFSKIP OPEN(OCHAN,OOPENBLK)
THEN RETURN GOOD
ELSE
BEGIN
ERROR( 51 );
OUTTSWORD( .OOPENBLK[ 1 ] );
OUTS( ': NOT AVAILABLE OR DOES NOT EXIST?M?J' )
END;
BAD
END;
GLOBAL ROUTINE GMEM(SIZE)=
BEGIN
! THIS IS A VERY CRUDE COUNTERFIT OF THE GMEM ROUTINE
! WHICH IS TO EXIST IN THE KERNAL.
! IT RETURNS ONLY 1 32 WORD BLOCK PER CALL
! MEMORY MANAGEMENT IS VIA LINKING FREE BLOCKS TOGETHER IN A LINKED LIST
LOCAL TEMP;
BIND BLOCKSIZE=32,
NUMBERTOGET=10;
%LOCAL% ROUTINE GCORE(SIZE)= !RETURNS POINTER AS VALUE
BEGIN
REGISTER Q,QQ;
EXTERNAL ?.JBFF,?.JBREL;
Q_.?.JBFF;
IF (QQ_(?.JBFF_.?.JBFF+.SIZE)) GEQ .?.JBREL THEN
BEGIN
IFSKIP CORE(QQ) THEN
ELSE
BEGIN
ERROR( 63 );
CRLF;
XIT
END
END;
.Q
END;
IF DEBUG THEN
BEGIN
IF (.SIZE GTR BLOCKSIZE OR .SIZE LEQ 0) THEN
BEGIN
OUTS('SIZE OUT OF RANGE IN GMEM. MUST BE <=32 AND >0');
CRLF;
OUTS('SIZE GIVEN ='); OUTD(.SIZE);CRLF
END;
END;
IF .NEXTCORE EQL 0 THEN
BEGIN
REGISTER GOTCHYA;
NEXTCORE _ GOTCHYA _ GCORE(BLOCKSIZE*NUMBERTOGET);
DECR I FROM NUMBERTOGET-2 TO 0 DO
GOTCHYA _ (.GOTCHYA)<0,36> _ .GOTCHYA + BLOCKSIZE;
(.GOTCHYA)<0,36> _ 0; %LAST BLOCK'S POINTER = 0%
END;
%IN ANY CASE%
TEMP _ .NEXTCORE;
NEXTCORE _ @.NEXTCORE;
ZERO( .TEMP, %THRU% .TEMP + .SIZE );
.TEMP
END;
GLOBAL ROUTINE PMEM(POINTER,SIZE)=
BEGIN
! THIS IS THE COMPLEMENT OF THE COUNTERFIT GMEM
(.POINTER)<0,36> _ .NEXTCORE;
NEXTCORE _ .POINTER
END;
COMMENT;
! ROUTINE GETNAME
! ======= =======
! GETNAME GATHERS AN ARGUEMENT FROM THE GIVEN LINE BUFFER.
! AND FILLS PARTS OF ARGLIST:
! ARGTYPE
! ARGTYPELENGTH
! PRIM
! SUB1
! SUB2
! SUB3
! PERIODS
! STOPS ON ANY ILLEGAL CHARACTERS
! NOTE: ARGTYPE IS NOT ZEROED IF A TYPE ISN'T SPECIFIED
! ==== ===
! RETURNS TRUE IF A / WAS SEEN ELSE FALSE
GLOBAL ROUTINE GETNAME(CBUFF,CBPTR,CCOUNT,CHAR)=
BEGIN
REGISTER
I;
BIND NAMETABLE = PLIT(PRIM,SUB1,SUB2,SUB3), MAXLEVEL = 4;
COMMASEEN _ SLASHSEEN _ FALSE;
SKIPBLANKS(.CBUFF,.CBPTR,.CCOUNT,.CHAR);
I _ GATHER(.CBUFF,.CBPTR,.CCOUNT,.CHAR,PRIM,15);
IF ..CHAR EQL ":" THEN
BEGIN
ARGTYPELENGTH _ .I;
ADV(.CBUFF,.CBPTR,.CCOUNT,.CHAR);
MOVE(PRIM,ARGTYPE,3);
GATHER(.CBUFF,.CBPTR,.CCOUNT,.CHAR,PRIM,15);
IF .PRIM EQL ASCII '/' THEN
BEGIN
SLASHSEEN _ TRUE;
PRIM _ 0
END;
IF .PRIM EQL ASCII ',' THEN
BEGIN
COMMASEEN _ TRUE;
PRIM _ 0
END;
END;
ZERO(SUB1, %THRU% SUB3+2);
IF .SLASHSEEN OR .COMMASEEN THEN RETURN .SLASHSEEN OR .COMMASEEN;
I _ 1;
PERIODS _ 0;
WHILE ..CHAR EQL "." DO
BEGIN
PERIODS _ .PERIODS + 1;
ADV(.CBUFF,.CBPTR,.CCOUNT,.CHAR);
GATHER(.CBUFF,.CBPTR,.CCOUNT,.CHAR,.NAMETABLE[.I],15);
IF .(.NAMETABLE[.I]) EQL ASCII '/' THEN
BEGIN
SLASHSEEN _ TRUE;
(.NAMETABLE[.I]) _ 0;
RETURN .SLASHSEEN
END;
IF .(.NAMETABLE[.I]) EQL ASCII ',' THEN
BEGIN
COMMASEEN _ TRUE;
(.NAMETABLE[.I]) _ 0;
RETURN .COMMASEEN
END;
IF (I _ .I + 1) GEQ MAXLEVEL THEN RETURN .SLASHSEEN OR .COMMASEEN
END;
.SLASHSEEN OR .COMMASEEN
END;
COMMENT;
! ROUTINE GETITEM
! ======= =======
! GETITEM GATHERS AN ARGUEMENT FROM CMDLINE
! RETURNS VALUE TRUE IF END OF COMMAND [EOL OR COMMENT OR ;] ELSE FALSE
! SETS INDEX IN ARGLIST=
! 0 IF NONE OF THE BELOW
! 1 IF NOT UNIQUELY ONE OF THE BELOW
! 2 IF NULL
! 3 TREE:
! 4 NODE:
! 5 LEAF:
! 6 MPP:
! 7 TERMINAL:
! 8 PORT:
! 9 NETWORK:
! 10 MISCELLANEOUS:
! 11 ALL:
! 12 CONTINUE:
!
! FILLS ARGLIST WHICH CONSISTS OF
! INDEX
! ARGTYPE
! ARGTYPELENGTH
! PRIM
! SUB1
! SUB2
! SUB3
! PERIODS
!
! SETS ALLSWITCH
!
! NOTE: ARGTYPE IS NOT CLEARED BY THIS ROUTINE
! ==== ===
GLOBAL ROUTINE GETITEM =
BEGIN
BIND
TYPETABLE = PLIT(
0, 2,
ASCII 'TREES', 3,
ASCII 'NODES', 4,
ASCII 'LEAFS', 5, %YES LEAFS IS MISSPELLED%
ASCII 'LEAVE', 5,
ASCII 'MPPS', 6,
ASCII 'TERMI', 7,
ASCII 'PORTS', 8,
ASCII 'NETWO', 9,
ASCII 'MISCE', 10,
ASCII 'SYS', 10,
ASCII 'ALL', 11,
ASCII 'CONTI', 12);
GETNAME(CMDLINE,CCHAR); !FILLS ARGTYPE THROUGH SUB3
IF NOT SEARCHTABLE(TYPETABLE,ARGTYPE,(IF .ARGTYPELENGTH GTR 5 THEN 5 ELSE
.ARGTYPELENGTH),1,INDEX) THEN INDEX _ (IF .INDEX NEQ 0 THEN 1 ELSE 0);
ALLSWITCH _ IF .CCHAR NEQ "/" AND NOT .SLASHSEEN THEN FALSE
ELSE
BEGIN
ALLSWITCH _ 0;
IF NOT .SLASHSEEN THEN ADV(CMDBUFF,CMDBPTR,CMDCOUNT,CCHAR);
GATHER(CMDLINE,CCHAR,ALLSWITCH,5);
IF .ALLSWITCH NEQ 'ALL' THEN RETURN(ERROR(2));
TRUE
END;
RETURN ( IF EOL(CCHAR) OR COMMNT(CCHAR) OR NEWCMD(CCHAR) THEN TRUE ELSE FALSE)
END;
COMMENT;
! ROUTINE ASKS
! ======= ====
! ASKS THE QUESTION A, ACCEPTS AN ANSWER, LOOKS IT UP IN TABLE B,
! AND EXECUTES THE ROUTINE SPECIFIED IN TABLE B WITH ARGUEMENT C
! IF A WRONG ANSWER IS GIVEN, THE USER IS NOTIFIED, GIVEN A LIST OF
! VALID ANSWERS, AND ASKED TO TRY AGAIN
GLOBAL ROUTINE ASKS(A,B,C)=
BEGIN
LABEL LOOP;
OWN ATOM;
LOOP: REPEAT ! UNTIL THE USER GETS IT RIGHT
BEGIN
ASKL( .A ); ! TYPE THE QUESTION TO THE USER
! AND ACCEPT HIS ANSWER
SIZE _ GATHER(ALINE,ACHAR,ATOM,5); ! GATHER THE FIRST ATOM OF HIS ANSWER
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR ); ! SKIP ANY TRAILING BLANKS
IF NOT EOL( ACHAR ) THEN ERROR( 9 ) ! THEN IF NOT AN END OF LINE COMPLAIN
ELSE IF SEARCHTABLE(.B, ATOM, IF .SIZE GTR 5 THEN 5 ELSE .SIZE, 1, EXECUTE) THEN
! ELSE LOOK THAT ATOM UP IN THE TABLE
LEAVE LOOP WITH (.EXECUTE)(.C); ! IF FOUND IN THE TABLE EXECUTE AND LEAVE
ERROR( 69 ); ! OTHERWISE TELL THE USER HE BLEW IT,
INCR K FROM 0 TO .(.B)[-1] - 2 BY 2 DO ! GIVE HIM A LIST OF VALID ANSWERS,
BEGIN
IF .(.B)[.K] NEQ 0 THEN OUTSN((.B)[.K]<36,7>, 5)
ELSE OUTS('<crlf>');
IF .K NEQ .(.B)[-1] - 2 THEN OUTS(', ') ! AND HAVE HIM TRY AGAIN
END;
OUTPUTC( ")" );
CRLF
END;
ERRORFLG _ FALSE
END;
COMMENT;
FORWARD ASKYN;
! ROUTINE CONFIRMED
! ======= =========
! THIS ROUTINE ASKS "ARE YOU SURE" AND RETURNS TRUE IF THE USER THINK
! HE IS SURE, OTHERWISE FALSE IS RETURNED
GLOBAL ROUTINE CONFIRMED =
BEGIN
ASKYESORNO( '[ARE YOU SURE]?R(NO, YES?R)[: ??]', FALSE )
END;
COMMENT;
! ROUTINE TOOLONG
! ======= =======
! THIS ROUTINE CHECKS NAMES TO SEE IF THEY ARE TOO LONG
! CALLED WITH WHERE THE NAME IS (WHERE), WHAT IT'S MAX LENGTH SHOULD BE
! (LEN), AND THE SIZE OF THE FIELD IT IS IN (SIZE)
GLOBAL ROUTINE TOOLONG( WHERE, LEN, SIZE ) =
BEGIN
REGISTER BP;
BP _ (.WHERE)<36,7>; ! MAKE A BYTE POINTER
DECR I FROM .LEN - 1 TO 0 DO INCP( BP ); ! SKIP THE GOOD CHARACTERS
DECR I FROM .SIZE - .LEN - 1 TO 0 DO ! THEN ANYTHING NOT NULL IS BAD
IF SCANI( BP ) NEQ 0 THEN RETURN TRUE;
FALSE
END;
COMMENT;
! ROUTINE TRUNCATE
! ======= =======
! THIS ROUTINE PUTS NULLS INTO THE NAME FIELD
! CALLED WITH WHERE THE NAME IS (WHERE), WHAT IT'S MAX LENGTH SHOULD BE
! (LEN), AND THE SIZE OF THE FIELD IT IS IN (SIZE)
GLOBAL ROUTINE TRUNCATE( WHERE, LEN, SIZE ) =
BEGIN
REGISTER BP;
BP _ (.WHERE)<36,7>; ! MAKE A BYTE POINTER
DECR I FROM .LEN - 1 TO 0 DO INCP( BP ); ! SKIP THE GOOD CHARACTERS
DECR I FROM .SIZE - .LEN - 1 TO 0 DO ! THEN INSERT NULLS
REPLACEI( BP, 0 )
END;
COMMENT;
! ROUTINE TOOMUCHINPUT
! ======= ============
! THE ROUTINE GENERATES AN ERROR IF THERE IS NOT AN EOL NOW IN
! THE ALTERNATE INPUT LINE
GLOBAL ROUTINE TOOMUCHINPUT =
BEGIN
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR );
IF NOT EOL( ACHAR ) THEN ERROR( 9 )
END;
COMMENT;
! ROUTINE IGNORE
! ======= ======
! THIS ROUTINE IS JUST A DUMMY, IT MERELY RETURNS
! IT IS NEEDED FOR USE IN ASKS ( ASKSTR )
GLOBAL ROUTINE IGNORE = RETURN;
COMMENT;
! ROUTINE SUBQUEUES
! ======= =========
! THIS ROUTINE IS USED TO CHECK FOR THE PRESENCE OF SUBQUEUES
GLOBAL ROUTINE SUBQUEUES =
BEGIN
INCR I FROM 0 TO ( ( MAXLEVEL - 1 ) * N0NAMELEN ) - 1 DO
IF .SUB1[.I] NEQ 0 THEN RETURN TRUE;
FALSE
END;
COMMENT;
! ROUTINE ASKCS
! ======= ====
! ASKS THE QUESTION, ACCEPTS AN ANSWER AND STORES THE RESPONSE
! (UP TO LEN CHARACTERS) AT ATOM
FORWARD COLLECTCHARS(2);
GLOBAL ROUTINE ASKCS(QUESTION, ATOM, LEN)=
BEGIN
ASKL( .QUESTION ); ! TYPE THE QUESTION TO THE USER
! AND ACCEPT HIS ANSWER
! SKIP LEADING BLANKS
SIZE _ COLLECTCHARS(.ATOM,.LEN); ! GATHER THE FIRST ATOM OF HIS ANSWER
IF .SIZE EQL 0 THEN CRONLY ELSE NOT CRONLY
END;
COMMENT;
! ROUTINE GETNUM
! ======= ======
! THIS ROUTINE GATHERS A NUMBER FROM THE LINE GIVEN USING THE BASE
! GIVEN. THE ROUTINE STOPS ON THE FIRST NON-NUMERIC CHARACTER.
GLOBAL ROUTINE GETNUM( BASE, BUFF, BPTR, COUNT, CHAR ) =
BEGIN
REGISTER VALUE;
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR);
VALUE _ 0;
WHILE NUMERIC( .CHAR ) AND (..CHAR - "0" LSS .BASE) DO
BEGIN
VALUE _ .VALUE * .BASE + (..CHAR - "0");
ADV( .BUFF, .BPTR, .COUNT, .CHAR)
END;
.VALUE
END;
COMMENT;
! ROUTINE GETPPN
! ======= ======
! THIS ROUTINE GATHERS A PROJECT-PROGRAMMER PAIR FROM THE SPECIFIED
! LINE. THIS ROUTINE STARTS AFTER THE "[" AND PROCEDES THRU THE "]".
GLOBAL ROUTINE GETPPN( BUFF, BPTR, COUNT, CHAR ) =
BEGIN
REGISTER VALUE;
REGISTER MYPPN;
ADV( .BUFF, .BPTR, .COUNT, .CHAR ); ! SKIP THE "["
VALUE<LH> _ GETNUM( BASE8, .BUFF, .BPTR, .COUNT, .CHAR);
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR );
IF ..CHAR NEQ "," THEN ! BETTER HAVE A COMMA BETWEEN THE NUMBERS
BEGIN
ERROR(4);
RETURN
END;
ADV( .BUFF, .BPTR, .COUNT, .CHAR); ! SKIP THE COMMA
VALUE<RH> _ GETNUM( BASE8, .BUFF, .BPTR, .COUNT, .CHAR);
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR );
IF ..CHAR NEQ "]" THEN ! BETTER END WITH A "]"
BEGIN
ERROR(4);
RETURN
END;
ADV( .BUFF, .BPTR, .COUNT, .CHAR); ! SKIP THE "]"
IF .VALUE<LH> EQL 0 OR .VALUE<RH> EQL 0 THEN %DEFAULT THE PPN%
BEGIN
CALLI(MYPPN,%GETPPN% #24);
IF .VALUE<LH> EQL 0 THEN VALUE<LH> _ .MYPPN<LH>;
IF .VALUE<RH> EQL 0 THEN VALUE<RH> _ .MYPPN<RH>
END;
.VALUE
END;
COMMENT;
! ROUTINE SIXWORD
! ======= =======
! THIS ROUTINE RETURNS A SIXBIT WORD FROM THE CHARACTERS POINTED TO
! BY THE CALLING ARGUEMENT. NO ERROR CHECKING IS DONE.
GLOBAL ROUTINE SIXWORD( ASCIISTRING ) =
BEGIN
REGISTER
TEMP,
VALUE,
BPS,
BPA;
BPS _ VALUE<36,6>;
BPA _ (.ASCIISTRING)<36,7>;
DECR I FROM 5 TO 0 DO
REPLACEI( BPS, ( IF ( TEMP _ SCANI(BPA) ) EQL 0 THEN 0 ELSE .TEMP - #40) );
.VALUE
END;
COMMENT;
! ROUTINE GETFD
! ======= =====
! THIS ROUTINE GATHERS A FILE SPEC FROM THE LINE SPECIFIED
GLOBAL ROUTINE GETFD( BUFF, BPTR, COUNT, CHAR, SPECBLK ) =
BEGIN
OWN
ATOM[2];
MAP FORMAT SPECBLK;
ZERO( ARGLIST, ARGTYPELENGTH );
GETNAME( .BUFF, .BPTR, .COUNT, .CHAR);
IF .SUB2 NEQ 0 OR .SUB3 NEQ 0 THEN
BEGIN
ERROR( 6 );
RETURN
END;
IF .SUB1 NEQ 0 AND .PRIM EQL 0 THEN
BEGIN
ERROR( 20 );
RETURN
END;
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR);
SPECBLK[SB0DEVICE] _ SIXWORD( ARGTYPE );
SPECBLK[SB0NAME] _ SIXWORD( PRIM );
SPECBLK[SB0EXT] _ ( SIXWORD( SUB1 ); .VREG<LH> );
SPECBLK[SB0CORE] _ 0;
SPECBLK[SB0PPN] _ 0;
IF EOL(.CHAR) OR ..CHAR EQL "," OR .SLASHSEEN OR .COMMASEEN THEN RETURN .SLASHSEEN OR .COMMASEEN;
IF ..CHAR EQL "[" THEN
BEGIN
SPECBLK[SB0PPN] _ GETPPN( .BUFF, .BPTR, .COUNT, .CHAR );
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR )
END;
IF EOL( .CHAR ) OR ..CHAR EQL "," OR ..CHAR EQL "/" OR .ERRORFLG THEN RETURN;
GATHER( .BUFF, .BPTR, .COUNT, .CHAR, ATOM, 6 );
IF ..CHAR EQL ":" THEN
BEGIN
IF .ARGTYPE NEQ 0 THEN
BEGIN
ERROR( 21 );
RETURN
END;
SPECBLK[SB0DEVICE] _ SIXWORD( ATOM )
END
ELSE ERROR( 9 );
ADV( .BUFF, .BPTR, .COUNT, .CHAR ); ! SKIP THE ":"
SKIPBLANKS( .BUFF, .BPTR, .COUNT, .CHAR );
IF NOT ( EOL( .CHAR ) OR ..CHAR EQL "," ) THEN ERROR( 9 )
END;
COMMENT;
! ROUTINE ASKNUM
! ======= ======
! THIS ROUTINE ASKS THE USER A QUESTION, ACCEPTS A RESPONSE, TRYS
! TO CONVERT THE RESPONSE TO A NUMBER OF THE BASE REQUESTED, AND
! CHECKS TO SEE IF THE NUMBER IS WITHIN THE RANGES SPECIFIED IN THE
! CALL.
GLOBAL ROUTINE ASKNUM( BASE, QUESTION, DEFAULTOKFLAG, DEFAULTVALUE, MINVALUE, MAXVALUE ) =
BEGIN
LABEL LOOP1, LOOP2;
OWN VALUE;
LOOP1: REPEAT ! UNTIL WE GET A GOOD ANSWER DO
BEGIN
LOOP2: REPEAT ! UNTIL WE GET AN ANSWER IF A DEFAULT IS NOT ALLOWED DO
BEGIN
! ASK THE QUESTION
! ACCEPT AN ANSWER
IF ASKL( .QUESTION ) THEN ! IF ONLY AN EOL THEN
IF .DEFAULTOKFLAG THEN RETURN .DEFAULTVALUE
! IF DEFAULT OK THEN RETURN DEFAULT
ELSE
BEGIN
ERROR( 24 ); ! OTHERWISE TELL THE USER HE DID A NO NO
WARN( 0 )
END
ELSE LEAVE LOOP2 ! IF NOT EOL THEN LEAVE THIS LOOP
END;
VALUE _ GETNUM( .BASE, ALINE, ACHAR ); ! CONVERT NUMBER
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR ); ! SKIP TRAILING BLANKS
IF NOT EOL( ACHAR ) THEN ! NOW IF NOT EOL THEN ERROR( TOO MUCH INPUT )
BEGIN
ERROR( 9 );
WARN( 0 )
END
ELSE
IF .VALUE LEQ .MAXVALUE AND ! IF EOL THEN CHECK IF IN RANGE
.VALUE GEQ .MINVALUE THEN RETURN .VALUE
! IF IN RANGE THEN RETURN THE NUMBER
ELSE
BEGIN
ERROR( 22 ); ! OTHERWISE INFROM THE USER AND TRY AGAIN
OUTS( 'MIN: ' );
OUTN( .MINVALUE, .BASE, 1 );
OUTS( ' , MAX: ' );
OUTN( .MAXVALUE, .BASE, 1 );
OUTS( ' )?M?J' );
WARN( 0 )
END
END
END;
FORWARD MATCHALINE;
COMMENT;
! ROUTINE NASKNUM
! ======= ======
! THIS ROUTINE ASKS THE USER A QUESTION, ACCEPTS A RESPONSE, TRYS
! TO CONVERT THE RESPONSE TO A NUMBER OF THE BASE REQUESTED, AND
! CHECKS TO SEE IF THE NUMBER IS WITHIN THE RANGES SPECIFIED IN THE
! CALL. THIS ROUTINE DIFFERS FROM ASKNUM IN THAT A SYMBOLIC
! RESPONSE SUCH AS "<NONE>" MAY BE ACCEPTED.
GLOBAL ROUTINE NASKNUM( BASE, QUESTION, DEFAULTOKFLAG, DEFAULTVALUE, SRES, MINVALUE, MAXVALUE ) =
BEGIN
LABEL LOOP1, LOOP2;
OWN SFLAG,
VALUE;
MAP FORMAT SRES;
LOOP1: REPEAT ! UNTIL WE GET A GOOD ANSWER DO
BEGIN
LOOP2: REPEAT ! UNTIL WE GET AN ANSWER IF A DEFAULT IS NOT ALLOWED DO
BEGIN
! ASK THE QUESTION
! ACCEPT AN ANSWER
IF ASKL( .QUESTION ) THEN ! IF ONLY AN EOL THEN
IF .DEFAULTOKFLAG THEN RETURN .DEFAULTVALUE
! IF DEFAULT OK THEN RETURN DEFAULT
ELSE
BEGIN
ERROR( 24 ); ! OTHERWISE TELL THE USER HE DID A NO NO
WARN( 0 )
END
ELSE LEAVE LOOP2 ! IF NOT EOL THEN LEAVE THIS LOOP
END;
SFLAG _ FALSE;
IF .SRES NEQ 0 THEN
IF MATCHALINE( SRES[SRES0LIT] ) THEN
BEGIN
VALUE _ .SRES[ SRES0VAL ];
SFLAG _ TRUE
END;
IF NOT .SFLAG THEN VALUE _ GETNUM( .BASE, ALINE, ACHAR ); ! CONVERT NUMBER
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR ); ! SKIP TRAILING BLANKS
IF NOT EOL( ACHAR ) THEN ! NOW IF NOT EOL THEN ERROR( TOO MUCH INPUT )
BEGIN
ERROR( 9 );
END
ELSE
BEGIN
IF .SFLAG THEN RETURN .VALUE; ! IF A SPECIAL RESPONSE THEN NO NEED TO CHECK RANGE
IF .VALUE LEQ .MAXVALUE AND ! IF EOL THEN CHECK IF IN RANGE
.VALUE GEQ .MINVALUE THEN RETURN .VALUE
! IF IN RANGE THEN RETURN THE NUMBER
ELSE
BEGIN
ERROR( 22 ); ! OTHERWISE INFROM THE USER AND TRY AGAIN
OUTS( 'MIN: ' );
OUTN( .MINVALUE, .BASE, 1 );
OUTS( ' , MAX: ' );
OUTN( .MAXVALUE, .BASE, 1 );
OUTS( ' )?M?J' );
END
END;
WARN( 0 )
END
END;
COMMENT;
! ROUTINE ASKFD
! ======= ========
! THIS ROUTINE ASK THE QUESTION SUPPLIED, ACCEPTS AN ANSWER, AND TRYS
! TO DECODE THE ANSWER AS A FILE SPEC.
GLOBAL ROUTINE ASKFD( QUESTION, SPECBLK ) =
BEGIN
NOTE; WHAT HAPPENS TO THE SLASHSEEN RETURN FROM GETFD?
DO
BEGIN
IF ASKL( .QUESTION ) THEN RETURN CRONLY;
GETFD( ALINE, ACHAR, .SPECBLK );
IF .ERRORFLG THEN WARN( 0 )
END
WHILE .ERRORFLG;
NOT CRONLY
END;
COMMENT;
! ROUTINE NASKFD
! ======= ========
! THIS ROUTINE ASK THE QUESTION SUPPLIED, ACCEPTS AN ANSWER, AND TRYS
! TO DECODE THE ANSWER AS A FILE SPEC.
GLOBAL ROUTINE NASKFD( QUESTION, NEWSPECBLK, SRES, OLDSPECBLK ) =
BEGIN
MAP FORMAT SRES;
NOTE; WHAT HAPPENS TO THE SLASHSEEN RETURN FROM GETFD?
DO
BEGIN
IF ASKL( .QUESTION ) THEN
BEGIN
MOVE( .OLDSPECBLK, .NEWSPECBLK, SPECBLKLEN );
RETURN CRONLY
END;
IF .SRES NEQ 0 THEN
IF MATCHALINE( SRES[SRES0LIT] ) THEN
BEGIN
MOVE( .SRES[SRES0VAL], .NEWSPECBLK, SPECBLKLEN );
RETURN NOT CRONLY
END;
! ELSE !
GETFD( ALINE, ACHAR, .NEWSPECBLK );
IF .ERRORFLG THEN WARN( 0 )
END
WHILE .ERRORFLG;
NOT CRONLY
END;
COMMENT;
! ROUTINE ASKBS
! ======= =======
! THIS ROUTINE ASKS THE QUESTION SPECIFIED, ACCEPTS A RESPONSE, AND
! TRYS TO FORM A BIT STRING OUT OF THE ANSWER
FORWARD COLLECTOITS(2), COLLECTCHARS(2);
GLOBAL ROUTINE ASKBS( QUESTION, ATOM, LEN ) =
BEGIN
OWN SIZE;
XTYPE( .QUESTION );
ACHAR _ INPUT( ALINE, ALINELENGTH );
IF EOL( ACHAR ) THEN RETURN CRONLY;
SIZE _ COLLECTOITS( .ATOM, .LEN);
IF .SIZE GTR .LEN THEN WARN( 7 );
NOT CRONLY
END;
COMMENT;
! ROUTINE COLLECTOITS
! ======= ===========
! THIS ROUTINE COLLECTS OCTAL DIGITS AS A BIT STRING
ROUTINE COLLECTOITS( ATOM, LEN ) =
BEGIN
REGISTER COUNT,Z,BP;
COUNT_0;
BP_(.ATOM)<36,7>;
WHILE NOT EOL( ACHAR ) DO
BEGIN
IF .COUNT LSS .LEN THEN
BEGIN
IF .ACHAR NEQ "#" THEN
BEGIN
REPLACEI(BP,.ACHAR);
ADV(ABUFF,ABPTR,ACOUNT,ACHAR)
END
ELSE
BEGIN
ADV(ABUFF,ABPTR,ACOUNT,ACHAR);
IF .ACHAR EQL "#" THEN
BEGIN
REPLACEI(BP,.ACHAR);
ADV(ABUFF,ABPTR,ACOUNT,ACHAR)
END
ELSE
REPLACEI(BP, GETNUM( BASE8, ABUFF, ABPTR, ACOUNT, ACHAR ))
! NOTE IT IS POSSIBLE THE GETNUM WILL PRODUCE A NUMBER TOO LARGE
! THIS SHOULD BE CHECKED FOR, BUT NOW IT IS IGNORED
END
END
ELSE ADV(ABUFF,ABPTR,ACOUNT,ACHAR);
COUNT_.COUNT+1
END;
Z_.COUNT;
WHILE .Z LSS .LEN DO ( Z _ .Z+1; REPLACEI(BP,0)); !FILL WITH NULLS
.COUNT
END;
COMMENT;
! ROUTINE COLLECTCHARS
! ======= ============
! THIS ROUTINE COLLECTS CHARACTERS FOR A BIT STRING. THIS DIFFERS
! FROM GATHER IN THAT LEADING SPACES ARE NOT SUPPRESSED, AND ONLY
! AND EOL STOPS THE GATHERING
ROUTINE COLLECTCHARS( ATOM, LEN ) =
BEGIN
REGISTER GNC,Z,PACCUM;
GNC_0;
PACCUM_(.ATOM)[-1]<1,7>;
WHILE NOT EOL( ACHAR ) DO
BEGIN
IF .GNC LSS .LEN THEN REPLACEI(PACCUM,.ACHAR);
ADV(ABUFF,ABPTR,ACOUNT,ACHAR);
GNC_.GNC+1
END;
Z_.GNC;
WHILE .Z LSS .LEN DO ( Z _ .Z+1; REPLACEI(PACCUM,0)); !FILL WITH NULLS
IF .Z GTR .LEN THEN WARN( 6 ); ! COMPLAIN IF INPUT TOO LONG
.GNC
END;
COMMENT;
! ROUTINE GETSZ
! ======= =======
! THIS ROUTINE TRIES TO CONVERT THE ANSWER IN ALINE INTO A SIZE SPECIFICATION.
GLOBAL ROUTINE GETSZ =
BEGIN
REGISTER VALUE;
VALUE _ GETNUM( BASE10, ALINE, ACHAR );
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR );
SELECT TRUE OF
NSET
.ACHAR EQL "K" OR EOL( ACHAR ):
IF .VALUE GTR 256 THEN
ERROR( 23 )
ELSE
BEGIN
ADV( ABUFF, ABPTR, ACOUNT, ACHAR );
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR );
IF NOT EOL( ACHAR ) THEN ERROR( 9 )
ELSE RETURN KFLAG + .VALUE
END;
.ACHAR EQL "P":
IF .VALUE GTR 512 THEN
ERROR( 23 )
ELSE
BEGIN
ADV( ABUFF, ABPTR, ACOUNT, ACHAR );
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR );
IF NOT EOL( ACHAR ) THEN ERROR( 9 )
ELSE RETURN .VALUE
END;
OTHERWISE:
ERROR( 9 );
TESN;
-1 ! RETURN BAD ANSWER INDICATOR
END;
COMMENT;
! ROUTINE ASKSZ
! ======= =======
! THIS ROUTINE ASKS THE QUESTION SPECIFIED, ACCEPTS AN ANSWER, AND TRYS
! TO CONVERT THAT ANSWER INTO A SIZE SPECIFICATION.
GLOBAL ROUTINE ASKSZ( QUESTION ) =
BEGIN
REGISTER VALUE;
REPEAT
BEGIN
IF ASKL( .QUESTION ) THEN RETURN 0;
VALUE _ GETSZ();
IF .VALUE<LH> EQL 0 THEN RETURN .VALUE;
! ELSE !
WARN( 0 );
END
END;
COMMENT;
! ROUTINE NASKSZ
! ======= =======
! THIS ROUTINE ASKS THE QUESTION SPECIFIED, ACCEPTS AN ANSWER, AND TRYS
! TO CONVERT THAT ANSWER INTO A SIZE SPECIFICATION.
! THIS ROUTINE DIFFERS FROM ASKSZ IN THAT A SYMBOLIC ANSWER SUCH AS
! "<AS REQ'D>" MAY BE ACCEPTED DEPENDING ON SRES
GLOBAL ROUTINE NASKSZ( QUESTION, SRES, OLDVALUE ) =
BEGIN
REGISTER VALUE;
MAP FORMAT SRES;
REPEAT
BEGIN
IF ASKL( .QUESTION ) THEN RETURN .OLDVALUE;
IF .SRES NEQ 0 THEN
BEGIN
IF MATCHALINE( SRES[SRES0LIT] ) THEN RETURN .SRES[ SRES0VAL ]
END;
! ELSE !
VALUE _ GETSZ();
IF .VALUE<LH> EQL 0 THEN RETURN .VALUE;
! ELSE !
WARN( 0 );
END
END;
COMMENT;
! ROUTINE OUTTSWORD
! ======= ===========
! THIS ROUTINE OUTPUTS A WORD AS SIX SIXBIT CHARACTERS
GLOBAL ROUTINE OUTTSWORD( AWORD ) =
BEGIN
REGISTER
TEMP,
BP;
LABEL LOOP;
BP _ AWORD<36,6>;
LOOP: DECR I FROM 5 TO 0 DO
IF ( TEMP _ SCANI( BP ) ) EQL 0 THEN LEAVE LOOP ELSE OUTPUTC( .TEMP + #40 )
END;
COMMENT;
! ROUTINE OUTTSHALFW
! ======= ============
! THIS ROUTINE OUTPUTS THREE SIXBIT CHARACTERS FROM THE RIGHT HALF OF
! THE WORD SUPPLIED
GLOBAL ROUTINE OUTTSHALFW( AWORD ) =
BEGIN
REGISTER
TEMP,
BP;
LABEL LOOP;
BP _ AWORD<18,6>;
LOOP: DECR I FROM 2 TO 0 DO
IF ( TEMP _ SCANI( BP ) ) EQL 0 THEN LEAVE LOOP ELSE OUTPUTC( .TEMP + #40 )
END;
COMMENT;
! ROUTINE OUTTM
! ======= =======
! THIS ROUTINE OUTPUT THE SINGLE CHARACTER SPECIFIED THE SPECIFIED
! NUMBER OF TIMES
GLOBAL ROUTINE OUTTM( CHAR, NUM ) =
BEGIN
DECR I FROM .NUM - 1 TO 0 DO
OUTPUTC( .CHAR )
END;
COMMENT;
! ROUTINE OUTTN
! ======= =======
! THIS ROUTINE OUTPUTS THE NUMBER SUPPLIED IN THE BASE SPECIFIED
GLOBAL ROUTINE OUTTN( NUM, BASE, REQD ) =
BEGIN
OWN
N,
B,
RD,
T;
%LOCAL% ROUTINE XN =
BEGIN
LOCAL R;
IF .N EQL 0 THEN RETURN OUTPUTM("0", .RD - .T);
R _ .N MOD .B;
N _ .N / .B;
T _ .T + 1;
XN();
OUTPUTC( .R + "0" )
END;
IF .NUM LSS 0 THEN OUTPUTC( "-" );
B _ .BASE;
RD _ .REQD;
T _ 0;
N _ ABS( .NUM );
XN()
END;
COMMENT;
! ROUTINE OUTN
! ======= =======
! THIS ROUTINE OUTS THE NUMBER SUPPLIED IN THE BASE SPECIFIED
GLOBAL ROUTINE OUTN( NUM, BASE, REQD ) =
BEGIN
OWN
N,
B,
RD,
T;
%LOCAL% ROUTINE XN =
BEGIN
LOCAL R;
IF .N EQL 0 THEN RETURN OUTM("0", .RD - .T);
R _ .N MOD .B;
N _ .N / .B;
T _ .T + 1;
XN();
OUTC( .R + "0" )
END;
IF .NUM LSS 0 THEN OUTC( "-" );
B _ .BASE;
RD _ .REQD;
T _ 0;
N _ ABS( .NUM );
XN()
END;
COMMENT;
! ROUTINE OUTTFSPEC
! ======= ===========
! THIS ROUTINE OUTPUTS A FILE SPECIFICATION IN THE FORM:
! "DEV:NAME.EXT[PPN]"
GLOBAL ROUTINE OUTTFSPEC( SPECBLK ) =
BEGIN
MAP FORMAT SPECBLK;
IF .SPECBLK[SB0DEVICE] NEQ 0 THEN
BEGIN
OUTPUTSWORD( .SPECBLK[SB0DEVICE] );
OUTPUTC( ":" )
END;
IF .SPECBLK[SB0NAME] NEQ 0 THEN
BEGIN
OUTPUTSWORD( .SPECBLK[SB0NAME] );
IF .SPECBLK[SB0EXT] NEQ 0 THEN
BEGIN
OUTPUTC( "." );
OUTPUTSHALFW( .SPECBLK[SB0EXT] )
END
END;
IF .SPECBLK[SB0PPN] NEQ 0 THEN
BEGIN
OUTPUTC( "[" );
OUTPUTO( .SPECBLK[SB0PROJ] );
OUTPUTC( "," );
OUTPUTO( .SPECBLK[SB0PROG] );
OUTPUTC( "]" )
END
END;
COMMENT;
! ROUTINE ATTACH
! ======= ======
! THIS ROUTINE IS THE LINK ROUTINE WITH AN ARBITRARY LINK WORD
GLOBAL ROUTINE ATTACH( KEY, NODE, OFFSETT ) =
BEGIN
REGISTER LAST;
IF .KEY EQL 0 THEN
BEGIN
(.NODE)[.OFFSETT] _ 0;
(.KEY)<FORE> _ (.KEY)<AFT> _ .NODE;
RETURN
END;
! ELSE !
LAST _ .(.KEY)<AFT>;
(.LAST)[.OFFSETT]<FORE> _ .NODE;
(.NODE)[.OFFSETT]<AFT> _ .LAST;
(.KEY)<AFT> _ .NODE
END;
COMMENT;
! ROUTINE UNATTACH
! ======= ========
! THIS ROUTINE IS THE CONVERSE OF ATTACH
GLOBAL ROUTINE UNATTACH( KEY, NODE, OFFSETT ) =
BEGIN
REGISTER
LAST,
NEXT;
IF .(.NODE)[.OFFSETT]<WORD> EQL 0 THEN
BEGIN
(.KEY) _ 0;
RETURN
END;
! ELSE !
IF ( LAST _ .(.NODE)[.OFFSETT]<AFT> ) NEQ 0 THEN
BEGIN
(.LAST)[.OFFSETT]<FORE> _ .(.NODE)[.OFFSETT]<FORE>
END;
IF ( NEXT _ .(.NODE)[.OFFSETT]<FORE> ) NEQ 0 THEN
BEGIN
(.NEXT)[.OFFSETT]<AFT> _ .(.NODE)[.OFFSETT]<AFT>
END;
(.NODE)[.OFFSETT] _ 0
END;
COMMENT;
! ROUTINE ASKYN
! ======= =========
! THIS ROUTINE ASKS A QUESTION, ACCEPTS A YES OR NO RESPONSE, AND
! RETURNS TRUE IF YES OR FALSE IF NO
GLOBAL ROUTINE ASKYN( Q, DEFAULT ) =
BEGIN
OWN VALUE;
%LOCAL% ROUTINE SETTRUE = VALUE _ TRUE;
%LOCAL% ROUTINE SETFALSE = VALUE _ FALSE;
%LOCAL% ROUTINE SETDEFAULT( DEFAULT ) = VALUE _ .DEFAULT;
ASKS( .Q,
PLIT( ASCII 'NO', SETFALSE,
ASCII 'YES', SETTRUE,
0, SETDEFAULT),
.DEFAULT);
.VALUE
END;
COMMENT;
! ROUTINE ASKNM
! ======= =====
! THIS ROUTINE ASKS THE QUESTION SUPPLIED AND REQUESTS AN NAME AS
! INPUT
GLOBAL ROUTINE ASKNM( Q, LEN ) =
BEGIN
! TYPE THE QUESTION
IF ASKL( .Q ) THEN RETURN ( PRIM _ 0 ); ! ACCEPT AN ALTERNATE LINE ANSWER
! IF THE LINE WAS EMPTY RETURN 0
IF NOT .ERRORFLG THEN GETNAME(ALINE,ACHAR); ! IF NO ERROR ACCEPTING THE LINE THEN GATHER A NAME
IF NOT .ERRORFLG THEN TOOMUCHINPUT(); ! IF NOT END OF LINE THEN ERROR
IF NOT .ERRORFLG THEN IF SUBQUEUES() THEN ERROR( 15 ); ! IF STILL NO ERRORS, SEE IF THE USER
! PUT PERIODS IN THE NAME
IF NOT .ERRORFLG THEN
IF TOOLONG( PRIM, .LEN, .LEN * 5 ) THEN
BEGIN
WARN( 6 );
TRUNCATE( PRIM, .LEN, .LEN * 5 )
END;
IF .ERRORFLG THEN 0 ELSE 1 ! IF ERROR IN ANY PART, RETURN 0 ELSE 1
END;
FORWARD ASKL;
COMMENT;
! ROUTINE ASK2FD
! ======= ======
! THIS ROUTINE ASKS FOR A PAIR OF FILE SPECS
GLOBAL ROUTINE ASK2FD( Q, SB1, SB2 ) =
BEGIN
ZERO( .SB1, .SB1 + SPECBLKLEN );
ZERO( .SB2, .SB2 + SPECBLKLEN );
DO
BEGIN
IF ASKL( .Q ) THEN RETURN CRONLY;
GETFD( ALINE, ACHAR, .SB1 );
IF NOT .ERRORFLG THEN
BEGIN
IF EOL( ACHAR ) THEN RETURN NOT CRONLY;
IF .ACHAR NEQ "," AND NOT .COMMASEEN THEN ERROR( 83 );
IF NOT .COMMASEEN THEN ADV( ABUFF, ABPTR, ACOUNT, ACHAR ); ! SKIP THE COMMA
IF NOT .ERRORFLG THEN GETFD( ALINE, ACHAR, .SB2 );
END;
IF .ERRORFLG THEN WARN( 0 );
END
WHILE .ERRORFLG;
NOT CRONLY
END;
COMMENT;
! ROUTINE NASK2FD
! ======= ======
! THIS ROUTINE ASKS FOR A PAIR OF FILE SPECS
GLOBAL ROUTINE NASK2FD( Q, SB1, SB2 ) =
BEGIN
DO
BEGIN
IF ASKL( .Q ) THEN RETURN CRONLY;
IF MATCHALINE( NONE ) THEN ZERO( .SB1, .SB1 + SPECBLKLEN ) ELSE GETFD( ALINE, ACHAR, .SB1 );
IF NOT .ERRORFLG THEN
BEGIN
IF EOL( ACHAR ) THEN RETURN NOT CRONLY;
IF .ACHAR NEQ "," AND NOT .COMMASEEN THEN ERROR( 83 );
IF NOT .COMMASEEN THEN ADV( ABUFF, ABPTR, ACOUNT, ACHAR ); ! SKIP THE COMMA
IF NOT .ERRORFLG THEN IF MATCHALINE( NONE ) THEN ZERO( .SB2, .SB2 + SPECBLKLEN ) ELSE GETFD( ALINE, ACHAR, .SB2 );
END;
IF .ERRORFLG THEN WARN( 0 );
END
WHILE .ERRORFLG;
NOT CRONLY
END;
COMMENT;
! ROUTINE OUTTBS
! ======= ======
! THIS ROUTINE OUTPUTS A BIT STRING
GLOBAL ROUTINE OUTTBS( WHERE, LEN ) =
BEGIN
REGISTER
BP,
CHAR;
LABEL SEL;
BP _ (.WHERE)<36,7>;
DECR I FROM .LEN - 1 TO 0 DO
BEGIN
CHAR _ SCANI( BP );
SEL: SELECT TRUE OF
NSET
.CHAR EQL "#": ( OUTPUT( '##' ); LEAVE SEL );
.CHAR GTR " " AND .CHAR LEQ "\": ( OUTPUTC( .CHAR ); LEAVE SEL );
OTHERWISE: ( OUTPUTC( "#" ); OUTPUTO( .CHAR ));
TESN
END
END;
COMMENT;
! ROUTINE GETSWITCH
! ======= =========
! THIS ROUTINE IS A GATHER THAT WILL SKIP A LEADING /
GLOBAL ROUTINE GETSWITCH( BUFF, BPTR, COUNT, CHAR, SWITCH ) =
BEGIN
REGISTER SIZE;
SIZE _ .SWITCH _ 0;
IF .SLASHSEEN OR ..CHAR EQL "/" THEN
BEGIN
IF NOT .SLASHSEEN THEN ADV( .BUFF, .BPTR, .COUNT, .CHAR );
SIZE _ GATHER( .BUFF, .BPTR, .COUNT, .CHAR, .SWITCH, 5 )
END;
.SIZE
END;
COMMENT;
! ROUTINE ASKSW
! ======= ===========
! THIS ROUTINE ASKS THE QUESTION SUPPLIED, ACCEPTS AN INPUT, AND
! GATHERS A SWITCH FROM IT
GLOBAL ROUTINE ASKSW( Q, SWITCH ) =
BEGIN
WHILE ASKL( .Q ) DO
BEGIN
ERROR( 104 );
WARN( 0 )
END;
IF .ACHAR EQL "/" THEN ADV( ABUFF, ABPTR, ACOUNT, ACHAR );
GATHER( ABUFF, ABPTR, ACOUNT, ACHAR, .SWITCH, 5 ) ! NOTE RETURN SIZE
END;
COMMENT;
! ROUTINE ASKSTAT
! ======= =======
! THIS ROUTINE ASKS THE QUESTION SUPPLIED AND ACCEPTS AS
! A RESPONSE "ENABLED" OR "DISABLED".
! IT RETURNS TRUE IF ENABLED OR FALSE IF DISABLED
GLOBAL ROUTINE ASKSTAT( Q, DEFAULT ) =
BEGIN
OWN VALUE;
%LOCAL% ROUTINE SETENA = VALUE _ ENABLED;
%LOCAL% ROUTINE SETDIS = VALUE _ DISABLED;
VALUE _ .DEFAULT;
ASKS( .Q,
PLIT( ASCII 'ENABL', SETENA,
ASCII 'DISAB', SETDIS,
0, IGNORE ),
0 );
.VALUE
END;
COMMENT;
! ROUTINE OUTCOM
! ======= ======
! THIS ROUTINE OUTPUTS A COMMA
GLOBAL ROUTINE OUTCOM =
BEGIN
OUTPUTC( "," )
END;
COMMENT;
! ROUTINE OUTCRLF
! ======= ======
! THIS ROUTINE OUTPUTS A CARRIAGE RETURN/LINE FEED
GLOBAL ROUTINE OUTCRLF =
BEGIN
OUTPUT( '?M?J' )
END;
COMMENT;
! ROUTINE OUTTAB
! ======= ======
! THIS ROUTINE OUTPUTS A HORIZONTAL TAB
GLOBAL ROUTINE OUTTAB =
BEGIN
OUTPUTC( "?I" )
END;
COMMENT;
! ROUTINE OUTBOO
! ======= ======
! THIS ROUTINE OUTPUTS "TRUE" IF THE ARG IS TRUE ELSE "FALSE"
GLOBAL ROUTINE OUTBOO( BOOL ) =
BEGIN
IF .BOOL THEN OUTPUT( 'TRUE' ) ELSE OUTPUT( 'FALSE' )
END;
COMMENT;
! ROUTINE OUTTFB
! ======= ======
! THIS ROUTINE OUTPUTS A SPECBLK IN THE FORM:
! "<TAB>SIXBIT<TAB>/" DEVICE "/<CRLF>"
! "<TAB>SIXBIT<TAB>/" NAME "/<CRLF>"
! "<TAB>SIXBIT<TAB>/" EXTENSION "/<CRLF>"
! "<TAB>XWD<TAB>" PROJ "," PROG "<CRLF>"
GLOBAL ROUTINE OUTTFB( SPECBLK ) =
BEGIN
MAP FORMAT SPECBLK;
OUTPUT( ' SIXBIT /' );
IF .SPECBLK[SB0DEVICE] EQL 0 AND .SPECBLK[ SB0NAME ] NEQ 0 THEN OUTPUT( 'DSK' )
ELSE OUTPUTSWORD( .SPECBLK[SB0DEVICE] );
OUTPUT( '/?M?J' );
OUTPUT( ' SIXBIT /' );
OUTPUTSWORD( .SPECBLK[SB0NAME] );
OUTPUT( '/?M?J' );
OUTPUT( ' SIXBIT /' );
OUTPUTSHALF( .SPECBLK[SB0EXT] );
OUTPUT( '/?M?J' );
OUTPUT( ' XWD ' );
OUTPUTO( .SPECBLK[SB0PROJ] );
OUTPUTCOMMA;
OUTPUTO( .SPECBLK[SB0PROG] );
OUTPUTCRLF;
OUTPUTCRLF
END;
COMMENT;
! ROUTINE OUTTST
! ======= ======
! THIS ROUTINE OUTPUTS A BIT STRING
GLOBAL ROUTINE OUTTST( WHERE, LEN ) =
BEGIN
REGISTER
BP,
CHAR;
LABEL SEL;
BP _ (.WHERE)<36,7>;
DECR I FROM .LEN - 1 TO 0 DO
BEGIN
CHAR _ SCANI( BP );
SEL: SELECT TRUE OF
NSET
.CHAR GEQ " " AND .CHAR LEQ "\": (OUTPUTC( """" ); OUTPUTC( .CHAR ); OUTPUTC( """" ); LEAVE SEL );
OTHERWISE: ( OUTPUT( '^O' ); OUTPUTO( .CHAR ));
TESN;
IF .I NEQ 0 THEN OUTPUT( ', ' );
END;
END;
FORWARD ATCHND;
COMMENT;
! ROUTINE ASKSIBS
! ======= =======
! THIS ROUTINE ASKS FOR THE SIBLINGS OF A NODE, THEN LINKS THE
! NODE IN THE PROPER PLACE
GLOBAL ROUTINE ASKSIBS( NODEPTR, PARENT ) =
BEGIN
REGISTER SIB;
EXTERNAL DNAME, GETNODEPTR, NULLNODENAME;
OWN INDX;
LABEL LOOP;
MAP FORMAT PARENT;
MAP FORMAT NODEPTR;
MAP FORMAT SIB;
SIB _ .PARENT[ N0FIRSTCHILD ];
IF .SIB EQL 0 THEN ! IF NO SIBS THEN
BEGIN
ATTACHNODE( .NODEPTR, .PARENT, 0, 0 );
RETURN
END;
OUTPUT( 'SIBS: ' );
DO
BEGIN
DNAME( .SIB );
SIB _ .SIB[ N0RSIB ];
IF .SIB NEQ 0 THEN OUTPUTC( "," )
END
WHILE .SIB NEQ 0;
CRLF;
LOOP: REPEAT
BEGIN
TYPE( '[WHERE DO YOU WANT ]' );
DNAME( .NODEPTR );
TYPE( '[ INSERTED]?R(<before first sib>, BEFORE:<sib-name>, AFTER:<sib-name>?R)[: ??]' );
ACHAR _ INPUT( ALINE, ALINELENGTH );
ARGTYPE _ 0;
GETNAME( ALINE, ACHAR );
NOTE !!!!!!! GARBAGE AFTER COMMAND???? !!!!!!!!
IF SEARCHTABLE( PLIT ( ASCII 'BEFOR', BEFORE,
ASCII 'AFTER', AFTER,
0, 2 ),
ARGTYPE,
IF .ARGTYPELENGTH GTR 5 THEN 5 ELSE .ARGTYPELENGTH,
1,
INDX ) THEN
BEGIN
SIB _ .PARENT[ N0FIRSTCHILD ];
IF .INDX EQL 2 THEN
BEGIN
INDX _ 0;
IF NULLNODENAME( PRIM ) THEN LEAVE LOOP
END;
IF NULLNODENAME( PRIM ) THEN LEAVE LOOP;
IF .SUB1 NEQ 0 THEN
BEGIN
IF ( SIB _ GETNODEPTR( PRIM ) ) NEQ 0 THEN LEAVE LOOP
END
ELSE
BEGIN
WHILE .SIB NEQ 0 DO
BEGIN
IF COMPARE( SIB[ N0NAME ], PRIM, N0NAMELEN ) THEN LEAVE LOOP;
SIB _ .SIB[ N0RSIB ]
END
END;
ERROR( 70 ) %UNKNOWN SIB%
END
ELSE ERROR( 71 ) %MODIFIER NOT BEFORE, AFTER OR NULL%;
! ELSE !
WARN( 0 )
END;
! INSERT SIB
ATTACHNODE( .NODEPTR, .PARENT, .INDX, .SIB )
END;
COMMENT;
! ROUTINE MATCHALINE
! ======= =====
! THIS ROUTINE DOES A CHARACTER BY CHARACTER COMPARE OF AN ASCII STRING
! WITH THE ALTERNATE INPUT LINE AND RETURNS TRUE IF THEY ARE EQUAL ELSE FALSE
GLOBAL ROUTINE MATCHALINE( STRNG1 ) =
BEGIN
REGISTER
CHAR1,
BP1;
BP1 _ .STRNG1;
REPEAT
BEGIN
CHAR1 _ SCANI( BP1 );
IF .CHAR1 EQL 0
OR
.ACHAR EQL 0
OR
EOL( ACHAR )
THEN RETURN TRUE;
! ELSE !
IF .CHAR1 NEQ .ACHAR THEN RETURN FALSE;
ACHAR _ SCANI( ABPTR )
END
END;
COMMENT;
! ROUTINE NULL
! ======= ====
! THIS ROUTINE CHECKS THE BLK ARGUEMENT TO SEE IF IT IS ALL ZEROS
GLOBAL ROUTINE NULL( BLK, SIZE ) =
BEGIN
DECR I FROM .SIZE - 1 TO 0 DO
IF .(.BLK)[.I]<WORD> NEQ 0 THEN RETURN FALSE;
TRUE
END;
COMMENT;
! ROUTINE DTCHND
! ======= ======
! THIS ROUTINE DETACHES A GIVEN NODE FORM ITS PARENT AND SIBS
GLOBAL ROUTINE DTCHND( NODEPTR ) =
BEGIN
REGISTER
SIB,
PARENT;
MAP FORMAT NODEPTR;
MAP FORMAT PARENT;
MAP FORMAT SIB;
PARENT _ .NODEPTR[N0PARENT];
IF ( SIB _ .NODEPTR[N0RSIB] ) EQL 0 THEN
BEGIN
IF .PARENT NEQ 0 THEN PARENT[N0LASTCHILD] _ .NODEPTR[N0LSIB]
END
ELSE SIB[N0LSIB] _ .NODEPTR[N0LSIB];
IF ( SIB _ .NODEPTR[N0LSIB] ) EQL 0 THEN
BEGIN
IF .PARENT NEQ 0 THEN PARENT[N0FIRSTCHILD] _ .NODEPTR[N0RSIB]
END
ELSE SIB[N0RSIB] _ .NODEPTR[N0RSIB];
NODEPTR[N0SIBS] _ 0
END;
COMMENT;
! ROUTINE ATCHND
! ======= ======
! THIS ROUTINE IS USED TO ATTACH A NODE TO IT'S PARENT
! NODEPTR IS THE NODE TO BE ATTACHED
! PARENT IS TO BE THE NEW PARENT OF THE NODE
! FLAG TELLS WHERE TO PUT THE NEW NODE ( BEFORE / AFTER )
! SIB IS THE SIBLING TO BE POSITIONED ON
! IF SIB IS 0 THEN THE NEW NODE IS PLACED BEFORE THE FIRST OR AFTER
! THE LAST DEPENDING UPON FLAG
GLOBAL ROUTINE ATCHND( NODEPTR, PARENT, FLAG, SIB ) =
BEGIN
OWN LSIB,
RSIB;
MAP FORMAT PARENT;
MAP FORMAT NODEPTR;
MAP FORMAT SIB;
MAP FORMAT LSIB;
MAP FORMAT RSIB;
NODEPTR[ N0LEVEL ] _ .PARENT[ N0LEVEL ] + 1;
NODEPTR[ N0PARENT ] _ .PARENT;
IF .PARENT[ N0CHILDREN ] EQL 0 THEN
BEGIN
NODEPTR[ N0SIBS ] _ 0;
PARENT[ N0FIRSTCHILD ] _ PARENT[ N0LASTCHILD ] _ .NODEPTR;
ZAPTRCODE( .PARENT[ N0TRCODE ] );
ZERO( PARENT[ N0OPNAME ], PARENT[ N0OPNAME ] + N0NAMELEN );
PARENT[ N0OPFLAG ] _ FALSE;
RETURN
END;
IF .SIB EQL 0 THEN
SIB _ ( IF .FLAG NEQ AFTER THEN .PARENT[ N0FIRSTCHILD ] ELSE .PARENT[ N0LASTCHILD ] );
IF .FLAG NEQ AFTER THEN ! DEFAULT TO BEFORE IF BAD
BEGIN
IF .SIB[ N0LSIB ] EQL 0 THEN ! BEFORE ALL SIBS
BEGIN ! YES
SIB[ N0LSIB ] _ PARENT[ N0FIRSTCHILD ] _ .NODEPTR;
NODEPTR[ N0LSIB ] _ 0;
NODEPTR[ N0RSIB ] _ .SIB
END
ELSE
BEGIN
LSIB _ NODEPTR[ N0LSIB ] _ .SIB[ N0LSIB ];
LSIB[ N0RSIB ] _ SIB[ N0LSIB ] _ .NODEPTR;
NODEPTR[ N0RSIB ] _ .SIB
END
END
ELSE
BEGIN
IF .SIB[ N0RSIB ] EQL 0 THEN ! AFTER ALL SIBS
BEGIN
SIB[ N0RSIB ] _ PARENT[ N0LASTCHILD ] _ .NODEPTR;
NODEPTR[ N0RSIB ] _ 0;
NODEPTR[ N0LSIB ] _ .SIB
END
ELSE
BEGIN
RSIB _ NODEPTR[ N0RSIB ] _ .SIB[ N0RSIB ];
RSIB[ N0LSIB ] _ SIB[ N0RSIB ] _ .NODEPTR;
NODEPTR[ N0LSIB ] _ .SIB
END
END
END;
COMMENT;
! ROUTINE ASKL
! ======= ====
! THIS ROUTINE ASK THE QUESTION SUPPLIED, ACCEPTS AN ALTERNATE LINE,
! SKIPS ANY LEADING BLANKS, AND RETURNS TRUE IF AFTER SKIPPING IT IS
! THE END OF LINE, ELSE FALSE
GLOBAL ROUTINE ASKL( Q ) =
BEGIN
XTYPE( .Q );
ACHAR _ INPUT( ALINE, ALINELENGTH );
SKIPBLANKS( ABUFF, ABPTR, ACOUNT, ACHAR );
EOL( ACHAR ) NOTE <--- NOTE NO SEMICOLON
END;
COMMENT;
! ROUTINE CMOVE
! ======= =====
! THIS ROUTINE MOVES CHARACTERS FORM THE FIRST STRING TO THE SECOND,
! THEN FILLS THE SECOND WITH NULLS
! NOTE BOTH SOURCE AND DESTINATION STRINGS ARE ASSUMED TO START ON WORD BOUNDARIES
GLOBAL ROUTINE CMOVE( WHAT, WHERE, WORDS ) =
BEGIN
REGISTER
CHARACTERS,
INBP,
OUTBP,
INCHAR;
CHARACTERS _ .WORDS * 5;
INBP _ (.WHAT)< 36, 7 >;
INCHAR _ SCANI( INBP );
OUTBP _ (.WHERE)< 36, 7 >;
DECR I FROM .CHARACTERS - 1 TO 0 DO
BEGIN
REPLACEI( OUTBP, .INCHAR );
IF .INCHAR NEQ 0 THEN INCHAR _ SCANI( INBP )
END
END;
COMMENT;
! ROUTINE CCPY
! ======= ====
! THIS ROUTINE MOVES CHARACTERS FROM THE FIRST STRING TO THE SECOND,
! NEITHER STRING IS EXPECTED TO START ON A WORD BOUNDARY, BUT MAY.
GLOBAL ROUTINE CCPY( STRNG1, STRNG2 ) =
BEGIN
REGISTER
BP,
CHAR;
BP _ .STRNG2;
WHILE ( CHAR _ SCANI( STRNG1 ) ) NEQ 0 DO
REPLACEI( BP, .CHAR );
.BP
END;
COMMENT;
! ROUTINE CCPY6
! ======= ====
! THIS ROUTINE MOVES CHARACTERS FROM THE FIRST STRING TO THE SECOND,
! CONVERTING FROM SIXBIT TO ASCII
! NEITHER STRING IS EXPECTED TO START ON A WORD BOUNDARY, BUT MAY.
GLOBAL ROUTINE CCPY6( STRNG1, STRNG2 ) =
BEGIN
REGISTER
BP,
CHAR;
BP _ .STRNG2;
DECR I FROM 5 TO 0 DO
IF ( CHAR _ SCANI( STRNG1 ) ) NEQ 0 THEN
REPLACEI( BP, .CHAR + " " );
.BP
END;
COMMENT;
! ROUTINE HYPHENIN
! ======= ========
! THIS ROUTINE CHECKS A STRING TO SEE IF IT CONTAINS A HYPHEN
GLOBAL ROUTINE HYPHENIN( %IN% STRNG, CHARS %LONG% ) =
BEGIN
REGISTER BP;
BP _ ( .STRNG )< 36, 7 >;
DECR I FROM .CHARS - 1 TO 0 DO
IF SCANI( BP ) EQL "-" THEN RETURN TRUE;
FALSE
END;
COMMENT;
! ROUTINE JOBNO
! ======= =====
! THIS ROUTINE RETURNS THE CURRENT JOB NUMBER IN SIXBIT RIGHTT JUSTIFIED
GLOBAL ROUTINE JOBNO =
BEGIN
REGISTER
JOBNUM,
AC;
PJOB( AC );
JOBNUM _ SIXBIT "000";
JOBNUM< 0, 3 > _ .AC MOD 10;
AC _ .AC / 10;
JOBNUM< 6, 3 > _ .AC MOD 10;
AC _ .AC / 10;
JOBNUM< 12, 3 > _ .AC;
.JOBNUM
END;
COMMENT;
! ROUTINE KILLFILE
! ======= ========
! THIS ROUTINE DELETES THE FILE GIVEN IN THE SPECBLK
! SUPPLIED, ... THE FILE MUST BE ON DISK!
GLOBAL ROUTINE KILLFILE( SPECBLK ) =
BEGIN
BIND BUFFSIZE = #200 + 3,
KBSIZE = 4;
LOCAL BUF1[BUFFSIZE], BUF2[BUFFSIZE], BUF3[BUFFSIZE], KILLBLOCK[ KBSIZE ];
MAP FORMAT SPECBLK;
MAP ROOTFORMAT ROOT;
IOPENBLK[0] _ #10;
IOPENBLK[1] _ .SPECBLK[SB0DEVICE];
IOPENBLK[2]<RH> _ IBUF<0,0>;
IF OPENINPUTDEVICE() FAILED THEN RETURN;
MAKEBUFFERRING( IBUF, 0<0,36>, BUF1, BUF2, BUF3 );
ILOOKUPBLK[0] _ .SPECBLK[SB0NAME];
ILOOKUPBLK[1]<LH> _ .SPECBLK[SB0EXT];
ILOOKUPBLK[2] _ 0;
ILOOKUPBLK[3] _ .SPECBLK[SB0PPN];
IFSKIP LOOKUP(ICHAN,ILOOKUPBLK)
THEN %CONTINUE%
ELSE
BEGIN
ERROR( 55 );
RETURN
END;
ZERO( KILLBLOCK, KBSIZE );
IFSKIP RENAME(ICHAN,KILLBLOCK)
THEN %CONTINUE%
ELSE
BEGIN
ERROR( 53 );
RETURN
END;
CLOSE( ICHAN, 0 )
END;
COMMENT;
! SUBROUTINE MOVE
! ========== ====
! THIS SUBROUTINE MOVES THISMANY NUMBER OF WORDS
GLOBAL ROUTINE MOVE(FROMPTR,TOPTR,THISMANY) =
BEGIN
REGISTER P;
MACHOP BLT = #251;
IF .THISMANY EQL 0 THEN RETURN FALSE; ! IF NOTHING TO DO RETURN FALSE
IF .FROMPTR EQL 0 THEN ! IF MOVE FROM ZERO THEN TREAT AS A ZERO STORAGE COMMAND
BEGIN
P<LH> _ .TOPTR; ! SET UP FOR A ZERO TYPE BLT
P<RH> _ .TOPTR + 1;
(.TOPTR)<0,36> _ 0 ! ZERO FIRST WORD
END
ELSE
BEGIN
P<LH> _ .FROMPTR; ! SET UP FOR A MOVE TYPE BLT
P<RH> _ .TOPTR;
END;
BLT(P,.TOPTR+.THISMANY-1); ! BLT
TRUE ! RETURN TRUE
END;
COMMENT;
! SUBROUTINE COMPARE
! ==================
! THIS SUBROUTINE COMPARES TWO VECTORS, EACH OF THISMANY NUMBER OF WORDS LONG
! ON ENTRY:
! A = POINTER TO VECTOR 1
! B = POINTER TO VECTOR 2
! THISMANY = LENGTH OF THE VECTORS
GLOBAL ROUTINE COMPARE(A,B,THISMANY) =
BEGIN
INCR I FROM 0 TO .THISMANY-1 DO
IF @(.A+.I) NEQ @(.B+.I) THEN RETURN FALSE;
TRUE
END;
COMMENT;
! SUBROUTINE LINK
! ===============
! THIS ROUTINE LINKS BLOCKS THAT THE FIRST WORD OF EACH BLOCK CONTAINS
! INFORMATION OF THE PREVIOUS AND NEXT BLOCKS IN THE LINK CHAIN.
! THE FIRST AND THE LAST BLOCKS IN THE CHAIN IS REFLECTED IN THE LINKKEY
! IN THE CONTROL HEADER. E.G. G0MHS IN A GH IS THE LINKKEY TO ALL THE MH'S
! THAT BELONG TO THIS GH.
GLOBAL ROUTINE LINK(KEY,WHAT) =
BEGIN
REGISTER
WHERE,
WORK;
IF @.KEY NEQ 0 THEN
BEGIN
WHERE _ .(.KEY)<AFT>;
WORK _ .(.WHERE)<RH>;
(.WHERE)<RH> _.WHAT;
(.WHAT)<AFT> _ .WHERE;
IF DEBUG THEN
IF .WORK NEQ 0 THEN
BEGIN
ERROR( 103 ); %PROBLEM IN LINK%
END;
(.KEY)<AFT> _ .WHAT
END
ELSE (.KEY)<FORE> _ (.KEY)<AFT> _ .WHAT;
WHERE _ .(.WHAT)<FORE>;
UNTIL .WHERE EQL 0 DO
BEGIN
(.KEY)<AFT> _ .WHERE;
WHERE _ .(.WHERE)<FORE>
END
END;
COMMENT;
! SUBROUTINE UNLINK
! =================
GLOBAL ROUTINE UNLINK(KEY,WHAT) =
BEGIN
REGISTER
PREV,
NEXT;
PREV _ .(.WHAT)<AFT>;
NEXT _ .(.WHAT)<FORE>;
IF .PREV NEQ 0 THEN (.PREV)<FORE> _ .NEXT
ELSE (.KEY)<FORE> _ .NEXT;
IF .NEXT NEQ 0 THEN (.NEXT)<AFT> _ .PREV
ELSE (.KEY)<AFT> _ .PREV;
END;
END;
! END OF MGNUTL.BLI