/* W 9 Y B - FIELD DAY DUP CHECKER */
/* COPYRIGHT 1976, HOWARD CUNNINGHAM */
DECLARE /* LANGUAGE EXTENSIONS */
TRUE LITERALLY '11111111B',
FALSE LITERALLY '0',
WORD LITERALLY 'ADDRESS',
LOGICAL LITERALLY 'BYTE';
DECLARE /* GLOBAL DATA */
FWATAB ADDRESS INITIAL(3000H),
LWATAB ADDRESS INITIAL(4FFFH),
ECHO LOGICAL INITIAL(FALSE), /* TAPE BACKUP RECORD FLAG */
(BTK,PTK,STK,CTK) WORD, /* INPUT TOKENS */
(BND,PFX,SFX) WORD, /* CURRENT BAND, PREFIX AND SUFIX */
(LOC,LIM) ADDRESS, /* CURRENT AND LAST TABLE ENTRY POINTERS */
CON BASED LOC WORD; /* CONTENTS OF CURRENT TABLE ENTRY */
/* TABLE ENTRY FORMATS:
/*
/* --------------------------------
/* BAND | 1 | 1 | 0 | 13 BITS |
/* --------------------------------
/*
/* --------------------------------
/* PREFIX | 1 | 0 | 14 BITS |
/* --------------------------------
/*
/* --------------------------------
/* SUFIX | 0 | 15 BITS |
/* --------------------------------
/*
/* NOTE THAT BAND > PREFIX > SUFIX. THIS INSURES THAT
/* LOCATE WILL STOP SEARCHING AT THE END OF THE APPROPRATE
/* LIST.
*/
DECLARE /* TOKEN FLAGS */
ENDFLG LITERALLY '0FFFFH',
BNDFLG LITERALLY '0C000H',
PFXFLG LITERALLY '8000H',
SFXFLG LITERALLY '0';
/* PROCEDURE STRUCTURE:
/*
/* MAIN COMMAND INTERPRETER
/* NEWLINE PRINT CR-LF
/* GETTOKEN INPUT PARSER
/* GETCHAR CHARACTER INPUT AND CLASSIFICATION
/* GETSTRING MULTIPLE CHARACTER INPUT
/* LOCATE SEARCH TABLES
/* INSERT INSERT INTO TABLES
/* FORMAT FORMAT TABLE ENTRY
/* PRINT OUTPUT TABLE ENTRY
/* DUMP PRINT ALL STATIONS FOR BAND
/* LIST LIST ALL BANDS
/* EDIT REMOVE TABLE ENTRIES
*/
DECLARE /* PRINT FORMATS */
BNDFMT DATA(27,'A',11,'0',11,'0',0),
PFXFMT DATA(11,'0',27,'A',27,'A',0),
SFXFMT DATA(27,'A',27,'A',27,'A',0);
DECLARE /* LOCAL VARIABLES */
(OP,NP) ADDRESS, /* TO AND FROM POINTERS FOR MOVE */
OLD BASED OP WORD,
NEW BASED NP WORD;
NEWLINE: PROCEDURE;
CALL OUTSTRING(.(15Q,12Q,1,1,1,1,1,0));
END;
GETTOKEN: PROCEDURE;
DECLARE /* GETCHAR INTERFACE */
CH BYTE, /* CURRENT CHARACTER */
(ASMBLY,ASMSAV) WORD, /* CHARACTER ASSEMBLEY */
(ALPHA,NUMERIC) LOGICAL; /* CURRENT CHARACTER ATTRIBUTES */
GETCHAR: PROCEDURE;
CH=0;
DO WHILE CH<40Q;
CH=INPUT AND 01111111B;
IF CH=15Q THEN DO;
CALL NEWLINE;
CH=' ';
END;
END;
IF ALPHA:= CH>='A' AND CH<='Z'
THEN ASMBLY=ASMBLY*27+(CH-'A'+1);
IF NUMERIC:= CH>='0' AND CH<='9'
THEN ASMBLY=ASMBLY*11+(CH-'0'+1);
END; /* GETCHAR */
GETSTRING: PROCEDURE; /* COMPLETE PREFIX OR SUFIX STRINGS */
DECLARE I BYTE;
DO I=1 TO 3;
IF ALPHA THEN DO;
ASMSAV=ASMBLY;
CALL GETCHAR;
END;
END;
END; /* GETSTRING */
/* BEGIN GETTOKEN */
START: /* RETURN HERE ON ILLEGAL INPUT */
BTK,STK,PTK,CTK,ASMBLY=0; /* CLEAR RETURN ARGUMENTS */
CH=' '; CALL OUTPUT (21Q);
DO WHILE CH=' '; CALL GETCHAR; END; /* SKIP BLANKS */
IF NUMERIC THEN DO;
CALL GETCHAR;
IF NUMERIC THEN CALL GETCHAR;
IF ALPHA THEN CALL GETCHAR;
ELSE ASMBLY=ASMBLY*27;
BTK=ASMBLY OR BNDFLG;
END;
ELSE DO;
IF ALPHA THEN DO;
CALL GETSTRING;
IF NUMERIC THEN DO;
PTK=ASMBLY OR PFXFLG;
ASMBLY=0;
CALL GETCHAR;
IF ALPHA THEN DO; /* INPUT COMPLETE CALL */
CALL GETSTRING;
STK=ASMBLY;
END;
END;
ELSE DO;
IF ALPHA THEN DO; /* INPUT COMMAND */
CTK=ASMSAV;
DO WHILE ALPHA; CALL GETCHAR; END;
END;
ELSE
STK=ASMBLY; /* INPUT SUFIX */
END;
END;
END;
CALL OUTPUT(23Q);
IF CH<>' ' THEN DO; /* ILLEGAL INPUT RESPONSE */
CALL OUTSTRING(.(7,77Q,' ',0));
GOTO START;
END;
END; /* GETTOKEN */
LOCATE: PROCEDURE(TKN);
DECLARE /* ARGUMENTS */
TKN WORD; /* SEARCH KEY */
LOC=LOC+2;
DO WHILE CON<TKN;
LOC=LOC+2;
END;
END; /* LOCATE */
INSERT: PROCEDURE(TKN);
DECLARE /* ARGUMENTS */
TKN WORD; /* STORAGE ELEMENT */
IF TKN<>0 AND TKN<>CON THEN DO;
IF LIM<LWATAB-2 THEN DO;
NP,LIM=(OP:=LIM)+2; /* START AT END OF TABLE */
DO WHILE NP<>LOC; /* WORK BACK TO CURRENT LOCATION */
NEW=OLD;
OP=(NP:=OP)-2;
END;
END;
ELSE CALL OUTSTRING(.('(MEMORY FULL) '));
CON=TKN;
END;
END; /* INSERT */
FORMAT: PROCEDURE(TKN,PTR);
DECLARE /* ARGUMENTS */
TKN WORD, /* TOKEN TO BE FORMATTED */
PTR ADDRESS, /* POINTER TO FORMAT LIST */
FMT BASED PTR BYTE; /* FORMAT ITEM: 2-ALPHA, 1-NUMERIC, 0-END */
DECLARE /* LOCAL VARIABLES */
REM BYTE, /* DISASSEMBLED CHARACTER */
I BYTE, J(4) BYTE; /* CHARACTER BUFFER */
I=LAST(J); J(LAST(J))=0; /* EMPTY BUFFER */
DO WHILE FMT<>0 AND I>0;
REM=TKN MOD FMT; TKN=TKN/FMT;
PTR=PTR+1;
IF REM<>0 THEN J(I:=I-1)=REM+FMT-1;
PTR=PTR+1;
END; /* WHILE */
DO I=I TO LAST(J)-1;
CALL OUTPUT(J(I));
END;
END; /* FORMAT */
PRINT: PROCEDURE(TKN);
DECLARE
TKN WORD; /* TOKEN TO BE PRINTED */
IF TKN=ENDFLG THEN CALL OUTSTRING(.('(END)'));
ELSE DO;
IF HIGH(TKN)<HIGH(PFXFLG) THEN CALL FORMAT(TKN,.SFXFMT);
ELSE DO;
IF HIGH(TKN)<HIGH(BNDFLG) THEN
CALL FORMAT(TKN AND NOT PFXFLG,.PFXFMT);
ELSE CALL FORMAT(TKN AND NOT BNDFLG,.BNDFMT);
END;
END;
END; /* PRINT */
DUMP: PROCEDURE;
DECLARE NUM BYTE;
LOC=LOC+2; NUM=0;
DO WHILE CON<BNDFLG;
IF CON>PFXFLG THEN PFX=CON;
ELSE DO;
IF NUM=0 THEN DO;
CALL NEWLINE;
NUM=10;
END;
ELSE NUM=NUM-1;
CALL OUTPUT(' ');
CALL PRINT(PFX); CALL PRINT(CON);
END;
LOC=LOC+2;
END; /* WHILE */
CALL NEWLINE;
END; /* DUMP */
LIST: PROCEDURE;
LOC=FWATAB;
DO WHILE CON<>ENDFLG;
CALL PRINT(CON);
CALL LOCATE(BNDFLG);
CALL OUTPUT(' ');
END;
END; /* LIST */
EDIT: PROCEDURE;
DO WHILE CTK<>14406 /* STOP */ ;
CALL PRINT(CON); CALL OUTPUT(' ');
CALL GETTOKEN;
IF BTK<>0 THEN CALL LOCATE(BTK);
IF PTK<>0 THEN CALL LOCATE(PTK);
IF STK<>0 THEN CALL LOCATE(STK);
IF CTK=10365 /* NEXT */ THEN LOC=LOC+2;
IF CTK=1488 /* BACK */ THEN LOC=LOC-2;
IF CTK=8274 /* KILL */ THEN DO;
LIM=LIM-2; OP=(NP:=LOC)+2;
DO WHILE NP<=LIM;
NEW=OLD;
OP=(NP:=OP)+2;
END;
END;
IF CTK=9004 /* LIMIT */ THEN DO;
LIM=LOC; CON=ENDFLG;
END;
IF CTK=841 /* ADDRESS */ THEN CALL OUTHEX(LOC,4);
IF CTK=6958 /* INSERT */ THEN DO;
CALL GETTOKEN;
CALL INSERT(BTK);
CALL INSERT(PTK);
CALL INSERT(STK);
END;
END;
END; /* EDIT */
/* BEGIN MAIN PROGRAM */
DECLARE /* LOCAL DATA */
BA ADDRESS INITIAL(01BFH), BEGA BASED BA ADDRESS,
EA ADDRESS INITIAL(01C1H), ENDA BASED EA ADDRESS,
DUP LOGICAL, /* TRUE IF SUFIX WORKED */
TAPEON DATA(22Q,1,1,0),
TAPEOFF DATA(' ',1,1,1,1,24Q,177Q,0),
BEEP DATA(7,1,1,1,1,1,1,1,1,7,1,1,1,1,1,1,1,1,7,0);
CALL OUTSTRING(.(' SUPER DUPER - BY WA9VRU ',0));
LOC,LIM=FWATAB; CON=ENDFLG; /* MARK END OF TABLE */
BND=324 OR BNDFLG; /* DEFAULT BAND - 00 */
SFX=757 OR SFXFLG; /* DEFAULT SUFIX - AAA */
DO WHILE TRUE;
DO; /* FANTOM INTERFACE */
BEGA=FWATAB;
ENDA=LIM+1;
END;
CALL GETTOKEN;
LOC=(FWATAB)-2;
IF BTK<>0 THEN DO;/* CHANGE BAND */
BND=BTK;
CALL LOCATE(BTK);
CALL INSERT(BTK);
IF ECHO THEN DO; /* RECORD ON TAPE */
CALL OUTSTRING(.TAPEON);
CALL PRINT(BND);
CALL OUTSTRING(.TAPEOFF);
END;
END;
ELSE DO;
CALL LOCATE(BND);
CALL INSERT(BND);
IF PTK<>0 THEN DO; /* WORK STATION */
CALL LOCATE(PTK);
CALL INSERT(PTK);
IF STK<>0 THEN SFX=STK; /* NEW SUFIX, IF SPECIFIED */
CALL LOCATE(SFX);
IF CON<>SFX THEN DO;
CALL INSERT(SFX);
IF ECHO THEN DO; /* RECORD ON TAPE */
CALL OUTSTRING(.TAPEON);
CALL PRINT(PTK);
CALL PRINT(SFX);
CALL OUTSTRING(.TAPEOFF);
END;
END;
ELSE CALL OUTSTRING(.(7,'(DUP) ',0));
END;
ELSE DO;
IF STK<>0 THEN DO; /* CHECK DUPS */
SFX=STK;
CALL LOCATE(PFXFLG);
DUP=FALSE;
DO WHILE CON<BNDFLG;
PFX=CON; CALL LOCATE(STK);
IF STK=CON THEN DO;
CALL PRINT(PFX);
CALL OUTPUT(' ');
DUP=TRUE;
END;
LOC=LOC-2;
CALL LOCATE(PFXFLG);
END; /* WHILE */
IF NOT DUP THEN CALL OUTSTRING(.BEEP);
END;
ELSE DO; /* SPECIAL COMMANDS */
IF CTK=3496 THEN CALL DUMP;
IF CTK=9010 THEN CALL LIST;
ECHO=ECHO XOR CTK=3734;
IF CTK=3762 THEN CALL EDIT;
IF CTK=1499 /* BAND */ THEN DO;
CALL PRINT(BND); CALL OUTPUT(' ');
END;
END;
END;
END;
END; /* MAIN PROGRAM */
EOF