COVLAY3
* /--- FILE TYPE = E
* /--- BLOCK COVLAY3 00 000 81/07/13 01.09
IDENT COVLAY3
LCC OVERLAY(1,1)
*
TITLE OVERLAYS FOR COMMAND READINS
*
*
CST
*
*
COVLY3$ OVFILE
*
*
EXT ECSPRTY
EXT KEYTYPE,VARFIN,VARFINM
EXT ERRORC,PUTCODE,ALTCODE,CALCODE
EXT NXTNAM,SYSTEST,SYSTST1
EXT LNGUNIT
EXT COMCONT
EXT ERRTAGS,ERRNAME,ERRSTOR
EXT ERRXYTG,ERR2MNY,ERR2FEW
EXT ERRTERM,ERRUARG,ERRVTYP
EXT ERROUTR,ERRCNTD,ERRXORQ
EXT ERRBAL,ERR
EXT NXTNAMP,MRKLAST
EXT VARDO,VARDO1,COMPILE,NXTNAME
EXT ADDLES=
EXT ONE2IN
*
*
* /--- BLOCK PACK 00 000 77/06/12 16.40
**
**
**
TITLE PACK COMMANDS
*
PACKOV OVRLAY
SB1 FSPACK LOG TEXT FOR PUBLICATION
RJ =XPUBTEXT
*
* TO DO';
* RETURN SCREEN LENGTH
* ALLOW 5000 CHARS (MAYBE) BY PACKING IN *INFO*
* MULTIPLE LINES FOR *PACK*
*
* PACK COMMAND WITH EMBEDS';
*
*
* FIRST *XCODEL* BITS ARE VAR STORING INTO
* SECOND *XCODEL* BITS ARE CHAR COUNT (0 IF NO)
* NEXT 11 BITS LOCATION OF TABLE IN EXTRA STORAGE
* NEXT *XCMNDL* BITS ARE COMMAND CODE NUMBER
*
* TABLE ENTRIES ARE SET UP IN ROUTINE -PACKER-
*
SA1 TAGCNT MAKE SURE SOME TAG
ZR X1,ERR2FEW
*
* OVARG1 = 0 (PACK), 1 (PACKC), 2 (SAY), 3 (SAYC)
SA1 OVARG1
SB1 X1
JP PACKOJ+B1
PACKOJ EQ PACK00 PACK
+ EQ PACKC0 PACKC
+ EQ SAY00 SAY
+ EQ SAYC0 SAYC
*
SAY00 MX7 0 NO GETVAR CODES FOR -SAY-
SA7 PCWORD
EQ PACK0
*
PACK00 CALL COMPILE EVALUATE FIRST TAG
NZ B1,ERRSTOR MAKE SURE ITS STORABLE
LX1 60-XCODEL LEFT JUSTIFY GETVAR CODE
MX7 1
LX7 2*XCODEL FAKE GVAR CODE FOR SECOND ARG
BX7 X1+X7 MERGE LOC GVAR + FAKE GVAR
SA7 PCWORD SAVE CODES
*
* SEE IF TWO COMMAS NEXT TO EACH OTHER (TWO ARG COMMAND)
*
*
SA1 WORDPT SAVE CURRENT POSITION
BX6 X1
SA6 OLDPT
CALL NEXTKEY
SA1 X2+KEYTYPE LOAD KEYTYPE FOR NEXT KEY
SX3 X1-OPCOMMA
ZR X3,PACK0 IF SEPARATER
*
*
SA1 OLDPT
BX6 X1 RESTORE WORDPT
SA6 WORDPT
*
CALL PUTCOMP
NG B1,ERRSTOR MAKE SURE SECOND ARG STORABLE
LX1 60-2*XCODEL AND PUT IN CENTER
SA2 PCWORD FETCH LOC GVAR CODE
MX7 XCODEL
BX7 X7*X2 INCLUDE ONLY 1ST GETVAR CODE
BX7 X7+X1 MERGE THEM
SA7 PCWORD AND STORE
*
PACK0 CALL PACKER RETURNS START OF TABLE IN B3
ZR B2,ERR2FEW AND LENGTH IN B2
*
SA1 PCWORD
SX2 B3 GET SAVED START OF TABLE
LX2 XCMNDL
BX6 X2+X1
EQ PUTCODE AND PUT IN COMMAND CODE
*
*
* /--- BLOCK PACKC0 00 000 77/06/19 12.56
*
* PACKC COMMAND'; ( MAX OF 100 CHAR STRINGS )
*
* COMMAND WORD';
* FIRST *XCODEL* BITS'; STRING DESTINATION
* NEXT *XCODEL* BITS'; CHAR CNT RETURN
* NEXT 11 BITS'; START OF TAG TABLE
* LAST *XCMNDL* BITS'; COMMAND NUMBER
**
* FIRST WORD OF TAG TABLE';
* FIRST *XCODEL* BITS'; CONDITIONAL EXPRESSSION GVAR
* BOTTOM 10 BITS'; NUMBER OF TAG ENTRIES
*
* TAG TABLE ENTRIES';
* 30 BIT ENTRIES, TWO PER WORD
*
* BOTTOM 12 BITS'; ADDRESS OF SECONDARY TABLE
* NEXT 9 BITS'; NUMBER OF ENTRIES IN SEC. TABLE
*
* TAG TABLE IS FORMATTED INTO BUFFER '7SHOWOUT'7 (100WDS LONG)
*
* (SECONDARY TABLE SET UP IN ROUTINE -PACKER-)
*
SAYC0 CALL COMPILE GET CONDITIONAL EXPRESSION
BX6 X1
SA6 PCWORD
EQ PACKC4
*
PACKC0 CALL VARDO1 FIRST EXPRESSION
CALL VARDO2 SECOND EXPRESSION
*
* CHECK FOR ADJACENT SEPARATORS'; NOT RETURNING CCOUNT
*
SA1 WORDPT SAVE CURRENT POSITION
BX6 X1
SA6 OLDPT
CALL NEXTKEY
SA1 X2+KEYTYPE LOAD KEYTYPE FOR NEXT KEY
*
SX3 X1-OPCOMMA
ZR X3,PACKC1 IF A SEPARATOR
*
SX3 X1-EOL
NZ X3,PACKC2 IF NOT END OF LINE
*
PACKC1 BX7 X2
SA7 LASTKEY
MX3 1
LX3 XCODEL FAKE GVAR CODE FOR THIRD ARG
EQ PACKC3
*
* RESTORE WORDPT AND PROCESS CHAR COUNT DESTINATION
*
PACKC2 SA1 OLDPT
BX6 X1
SA6 WORDPT
*
CALL PUTCOMP
NG B1,ERRSTOR MUST STORE INTO-ABLE
BX3 X1 SAVE IT
*
* /--- BLOCK PACKC3 00 000 77/06/12 17.11
*
* STORE THREE GVAR CODES IN *PCWORD* FOR NOW
*
PACKC3 SA1 VARBUF+1 CONDITIONAL EXPRESSION
MX0 -XCODEL
BX1 -X0*X1 MASK OFF TOP BIT
*
SA2 VARBUF+2 STRING DESTINATION
NG X2,ERRSTOR CANNOT BE STORED INTO
LX2 XCODEL+XCODEL PUT ON FAR LEFT SIDE
*
LX3 XCODEL PUT IN MIDDLE
*
BX6 X1+X2 NOW MERGE ALL THREE
BX6 X6+X3
SA6 PCWORD
*
* DETERMINE STRING TERMINATOR
*
PACKC4 SA2 LASTKEY
ZR X2,PACKC5 IF TERMINATOR IS END-OF-LINE
*
SA1 WORDPT POINTS JUST PAST LAST CHAR
SA3 X1-2 CHAR PRECEDING LASTKEY
SX4 X3-ACCESS
NZ X4,PACKC5 IF ACCESS NOT PART OF TERMINATR
*
LX3 6
BX2 X2+X3 MERGE ACCESS+LAST CHAR
*
PACKC5 BX7 X2
SA7 TERMSAV AND STORE IT
*
* INITIALIZATIONS BEFORE MAIN LOOP
*
MX6 0
SA6 SHOWOUT INITIALIZE TAG TABLE COUNTER
ZR X7,PLINE0 IF EOL TERMINATOR, NEXT LINE
SA2 X1 GET LAST CHAR
NZ X2,PLINE1 JUMP IF LINE NOT EXHAUSTED
*
* /--- BLOCK PACKC 00 000 76/07/25 08.46
*
* BRINGS IN CONTINUATION LINE IF THERE IS ONE
*
PLINE0 SA1 NEXTCOM CHECK IF CONTINUATION
SA2 COMCONT
BX2 X1-X2
NZ X2,PCEND0 DONE PROCESSING IF NOT CONT.
*
CALL GETLINE READ IN NEXT LINE
*
*
* MAIN LOOP. -PACKER- RETURNS'; B3=TABLE START, B2=LENGTH
*
*
PLINE1 CALL PACKER EVALUATE NEXT CHAR STRING
*
SA1 SHOWOUT
SX7 X1+1 INCREMENT SHOWOUT COUNTER
SA7 SHOWOUT AND STORE INCREMENTED COUNTER
*
SX2 X1-100 LENGTH OF SHOWOUT = 100 WORDS
PL X2,ERR2MNY TOO MANY TAGS
*
SX5 B3 START OF TABLE IN BOTTOM 12 BTS
SX6 B2 LENGTH OF TABLE
LX6 12
BX6 X5+X6 MERGE LENGTH + INDEX
SA6 X7+SHOWOUT AND STORE ENTRY
*
* FIND OUT WHETHER IT NEEDS NEW LINE OR NOT
*
SA1 WORDPT
SA2 X1
ZR X2,PLINE0 -PACKER- STOPPED ON EOL
*
SX7 X1+1 INCREMENT WORDPT
SA2 X7 AND READ NEXT CHAR
ZR X2,PLINE0 IF EMPTY, READ NEXT LINE
SA7 WORDPT OTHERWISE, UPDATE WORDPT
EQ PLINE1
*
*
* /--- BLOCK PACKC 00 000 76/07/25 08.47
*
* ALL DONE'; STORE FIRST WORD OF TABLE, AND COMMAND WORD
*
PCEND0 SA1 PCWORD
LX1 XCODEL+XCODEL GET COND. EXPR. ON TOP
MX0 XCODEL
BX6 X0*X1 AND PUT IT INTO X6
SA2 SHOWOUT
BX7 X6+X2 MERGE GVAR + NUMBER OF ENTRIES
SA2 INX
SA7 X2+INFO STORE AS 1ST WORD OF TABLE
SX7 X2+1 INCREMENT XSTOR POINTER
SA7 INX
*
BX1 X1-X6 REMOVE GVAR CODE FROM CMND WD.
LX1 XCODEL AND RESTORE WORD
LX2 XCMNDL MERGE WITH LOC OF TABLE
BX6 X1+X2
SA6 PCWORD AND STORE IT AGAIN
*
* NOW PUT TAG TABLE INTO XSTORAGE
*
SA1 ICX
SA0 X1-1 MARKER FOR END OF UNIT
SA1 SHOWOUT LOAD NUMBER OF ENTRIES
ZR X1,ERR2FEW NOTHING THERE
MX6 0
SA6 X1+SHOWOUT+1 CLEAR LAST WORD
SB4 X1-1 B4=END TEST
SA2 INX
SB2 X2 B2=INDEX INTO XSTORAGE
SA2 SHOWOUT-1 A2=INDEX INTO SHOWOUT BUFFER
*
*
PCEND1 SA2 A2+2
LX2 30
SA3 A2+1
BX6 X2+X3 MERGE TWO TABLE ENTRIES
SA6 B2+INFO B2 IS INDEX INTO XSTOR
*
SX3 A0-B2
NG X3,LNGUNIT
*
SB2 B2+1 INCREMENT POINTER INTO SHOWOUT
SB4 B4-2 DECREMENT END TEST
PL B4,PCEND1 AND LOOP BACK
*
*
SX6 B2
SA6 INX UPDATE XSTOR POINTER
*
SA1 PCWORD
BX6 X1
EQ PUTCODE DONE
*
*
* /--- BLOCK PACKER 00 000 78/11/02 11.27
*
* PACKER EVALUATES LAST TAG (TEXT) OR CONTINUATION LINE';
* RETURNS START OF TABLE IN B3, LENGTH IN B2
*
*
* TABLE ENTRIES'; 30 BITS APIECE';
*
* FOR PACK, FIRST ENTRY IS NUMBER OF ENTRIES ( NOT SO,PACKC)
*
*
* FOR TEXT';
* BOTTOM 12 BITS'; INDEX OF TEXT IN XSTORAGE
* NEXT 6 BITS '; 0 ( AS FLAG THAT THIS IS TEXT )
* NEXT 9 BITS '; LENGTH OF TEXT
* FOR SHOWS';
* BOTTOM 12 BITS'; INDEX OF GETVAR CODES IN XSTORAGE
* NEXT 6 BITS '; TYPE OF SHOW (1 TO 6)
* NEXT 6 BITS'; NUMBER OF GETVAR CODES IN XSTOR WORD
*
* GETVAR CODES IN XSTORAGE ARE THREE PER WORD
* SIGN BIT ON MEANS GETVAR ENTITY CAN BE STORED INTO
* NOTE ASSUMPTION THAT SHOW COMMANDS HAVE NO MORE
* THAN THREE ARGUMENTS
*
*
* OVARG1 = 0 (PACK), 1 (PACKC), 2 (SAY), 3 (SAYC)
*
PACKER EQ *
MX6 0
SA6 VARBUF INITIALIZE ^$ OF ENTRIES
*
PL SA1 INX INX IS BUFFER
SB2 X1 B2= XSTORAGE POINTER
SB3 B0 B3= WORD COUNT
SA1 WORDPT
SX7 X1-1 X7= WORDPT POINTER
SA1 OVARG1
MX0 59
BX0 -X0*X1 X0=0 (PACK,SAY), =1 (PACKC, SAYC)
SA1 TERMSAV X1= TERMINATOR (FOR PACKC)
SA2 ICX
SA0 X2-1 A0= END OF UNIT
SB7 1 B7=FONT FLAG, 1=NORM,-1=ALT
*
* /--- BLOCK PL0 00 000 78/11/01 11.17
*
* NOW FOR MAIN LOOP
*
PL0 MX6 0 X6= WORD BUILDING VAR
SB1 60 B1= SHIFT COUNTER
*
*
PL1 SX7 X7+1 NEXT CHARACTER
SA2 X7 X2=NEXT CHARACTER
ZR X2,PEOL FOUND END OF LINE
*
*
ZR X0,PL1B FOLLOWING CHECKS FOR TERMINATOR
BX3 X1-X2 CHECK FOR SINGLE CHAR TERMNTR
ZR X3,PEOL FOUND TERMINATOR
*
*
PL1B SX3 X2-FONT CHECK FOR FONT
NZ X3,PL1C
SB7 -B7 FLIP FONT FLAG
*
PL1C SX3 X2-ACCESS START CHECK FOR EMBEDS
NZ X3,PL2
SA3 X7+1
*
NG B7,PL1D DO NOT CHECK FOR ^0 IN ALT.FONT
*
SX4 X3-1R0 LEFT EMBED SYMBOL
ZR X4,PEMBED FOUND EMBED SYMBOL
*
PL1D ZR X0,PL2 FOR PACKC ONLY
SX4 X2 COPY
LX4 6 MOVE ACCESS OVER
BX4 X3+X4 MERGE ACCESS + NEXT CHAR
BX4 X4-X1 COMPARE WITH 2-CHAR TEMINATOR
NZ X4,PL2 FOUND TERMINATOR'/
SX7 X7+1 INCREMENT WORDPT
EQ PEOL
*
*
PL2 SB1 B1-6 SHIFT COUNT
LX2 X2,B1 SHIFT KEY OVER
BX6 X2+X6 MERGE WITH WORD BUFFER
NZ B1,PL1 GET NEXT KEY IF WORD NOT DONE
*
SX3 A0-B2 AT END OF UNIT'/
NG X3,LNGUNIT
*
SA6 B2+INFO STORE COMPLETED TEXT WORD
SB2 B2+1 INCREMENT XSTOR POINTER
SB3 B3+1 INCREMENT WORD COUNT
EQ PL0 END OF MAIN LOOP
*
*
* /--- BLOCK PEMBED 00 000 76/07/25 08.47
*
* HIT EMBED SYMBOL'; PROCESS WHATEVER IS INSIDE
*
PEMBED SX7 X7+2 UPDATE WORDPT
SA7 WORDPT
CALL PTEXT UPDATES CURRENT TEXT
*
CALL NXTNAME GET TAG OF EMBED (RETURNS X6)
ZR X6,BADEMB IF NO TAG
SB4 0 LOOP COUNTER
MX0 42 FIRST MASK
MX1 6 SECOND MASK
*
* FIND MATCH IN SHOW TABLE OF FIRST TAG
*
PE2 SA2 PACKLST+B4 READ NEXT ENTRY
ZR X2,BADEMB IF NO MATCH
BX3 X0*X2 MASK OFF TOP 7 CHARS
BX3 X6-X3 AND COMPARE WITH NXTNAM
ZR X3,PE3
LX2 54 TAKE A LOOK AT BOTTOM CHAR
BX2 X1*X2 MASK OFF ONE CHAR
BX2 X6-X2 AND MATCH IT
ZR X2,PE3
SB4 B4+1
EQ PE2
*
* /--- BLOCK PE3 00 000 78/11/02 13.49
*
PE3 SX6 B4+1 *SHOW* CODE FOR TABLE
SA6 PSHOW
SX6 0 GETVAR COUNT
SA6 PCODES
SA6 PTEMP GETVAR CODES
SX6 60 SHIFT COUNT
SA6 PSHFT
*
*
PE4 CALL COMPILE EVALUATE NEXT TAG
*
SA2 LASTKEY
ZR X2,ERRTERM HIT EOL INSTEAD OF R. EMBED
*
MX0 -XCODEL MASK
BX2 -X0*X1 MASK OFF GETVAR CODE
*
ZR B1,PE5 WAS EXPRESSION STORABLE'/
MX1 1
LX1 XCODEL SET TOP BIT OF GVAR CODE
BX2 X2+X1 AS A FLAG
*
PE5 SA1 PCODES GETVAR COUNTER
SX6 X1+1 AND UPDATE IT
SA6 PCODES
*
SA1 PSHFT SHIFT COUNTER
SX6 X1-XCODEL UPDATE IT
SB1 X6 AND SAVE IT IN B1
NG B1,ERRTAGS MORE THAN 3 TAGS
SA6 PSHFT
*
SA1 PTEMP CONTAINS GETVAR CODES
LX6 X2,B1 SHIFT CURRENT GETVAR CODE
BX6 X6+X1 AND MERGE WITH OLD GVAR CODES
SA6 A1
*
*
SA1 WORDPT CHECK IF HIT R. EMBED OR NOT
SA2 X1-2 BACK UP TWO CHARS
SX2 X2-ACCESS
NZ X2,PE4 NEXT TO LAST SYMBOL NOT EMBED
SA2 X1-1
SX2 X2-1R1 CHECK FOR ACCESS 1 (RT. EMBED)
NZ X2,PE4 IF CHECKS, THEN DONE
*
* MAKE TABLE ENTRY FOR *SHOW*
*
SA1 PTEMP
BX6 X1
SA1 INX
SA6 X1+INFO ADD GETVAR CODES TO CM ARGS
SX6 X1+1 INCREMENT CM ARG POINTER
SA6 A1
*
SX6 X1 BOTTOM 12 BITS'; ADDR OF GVARS
*
SA1 PSHOW NEXT 6 BITS'; TYPE OF SHOW
LX1 12
BX6 X1+X6
*
SA1 PCODES NEXT 6 BITS'; NUMBR OF GVARS
LX1 12+6
BX6 X1+X6
*
SA1 VARBUF
SX7 X1+1 INCREMENT NUMBER OF TABLE ENTRY
SA7 VARBUF
*
SA6 X7+VARBUF NOW WRITE WORD TO TABLE
*
SX1 X7-VARBUFL+2
PL X1,ERR2MNY MAKE SURE TABLE DOESNT OVERFLOW
EQ PL
*
* /--- BLOCK PEOL 00 000 76/05/26 16.27
*
* REACHED END OF LINE, OR TERMINATOR (FOR PACKC)'; PUT
* VARBUF TABLE INTO XSTORAGE, TWO PER WORD
* EXPECTS X0= PACKC FLAG, A0 = END OF UNIT MARKER
* AND B2= XSTORAGE POINTER
*
PEOL SA7 WORDPT UPDATE WORDPT
CALL PTEXT UPDATE TEXT
*
SA1 VARBUF LOAD NUMBER OF ENTRIES
ZR X1,PO4 NOTHING HERE
MX6 0
SA6 X1+VARBUF+1 CLEAR LAST WORD
SB3 B2 B3= START OF TABLE
SB4 X1 B4= END TEST
SA2 VARBUF-2 A2= INDEX INTO VARBUF BUFFER
*
ZR X0,PO3 -PACK- COMMAND
SA2 A2+1 DO NOT RETURN LENGTH
SB4 B4-1 IN FIRST TABLE ENTRY
*
*
PO3 SA2 A2+2
LX2 30
SA3 A2+1
BX6 X2+X3 MERGE TWO TABLE ENTRIES
*
SA6 B2+INFO B2= INDEX INTO XSTORAGE
*
SX3 A0-B2 STILL IN UNIT'/
NG X3,LNGUNIT
*
SB2 B2+1
SB4 B4-2 DECREMENT END TEST
PL B4,PO3 AND LOOP BACK
*
*
SX6 B2 UPDATE XSTOR POINTER
SA6 INX
*
PO4 SA1 VARBUF GET NUMBER OF ENTRIES
SB2 X1
EQ PACKER DONE
*
*
* BAD FORMAT SPECIFICATION
*
BADEMB SB1 154
EQ =XERR
*
*
* /--- BLOCK PTEXT 00 000 78/09/12 00.28
*
* STORES LAST TEXT WORD, UPDATES TABLE ENTRY
*
* ENTERS WITH X6=LAST TEXT WD, B3=WORD CNT, B2=XSTORAGE INDX
* A0= END OF UNIT MARKER, X0 = PACKC FLAG
*
PTEXT EQ *
ZR X6,PT0 JUMP IF CURRENT WORD EMPTY
*
SX4 A0-B2 AT END OF UNIT'/
NG X4,LNGUNIT
*
SA6 B2+INFO DUMP CURRENT WORD INTO XSTOR
SB2 B2+1 UPDATE XSTOR COUNTER
SB3 B3+1 UPDATE WORD COUNTER
*
PT0 ZR B3,PT1 NO TEXT HERE
SA1 VARBUF UPDATE NUMBER OF TABLE ENTRIES
SX6 X1+1
SA6 A1
*
SA1 INX BEGINNING INDEX OF TEXT
SX2 B3 NUMBER OF WORDS OF TEXT
LX2 12+6
BX7 X1+X2 MERGE INDEX AND LENGTH
SA7 X6+VARBUF AND PUT INTO TABLE
*
SX1 X6-VARBUFL+2
PL X1,ERR2MNY MAKE SURE TABLE DOESNT OVERFLOW
*
PT1 SX6 B2 UPDATE XSTOR POINTER
SA6 INX
*
EQ PTEXT
*
*
PACKLST VFD 42/0LSHOWZ,18/1RZ
VFD 42/0LSHOW,18/1RS
VFD 42/0LSHOWT,18/1RT
VFD 42/0LSHOWO,18/1RO
VFD 42/0LSHOWE,18/1RE
VFD 42/0LSHOWA,18/1RA
VFD 42/0LSHOWH,18/1RH
VFD 42/0LHIDDEN,18/0
VFD 42/0LSHOWK,18/1RK
ZR DATA 0
*
PCWORD BSS 1 COMMAND WORD
PCODES BSS 1 NUMBER OF GETVAR CODES
PSHFT BSS 1 SHIFT COUNT
PSHOW BSS 1 SHOW CODE
PTEMP BSS 2 TEMPORARIES
TERMSAV BSS 1 SAVE TERMINATOR CODE(S)
*
*
ENDOV
* /--- BLOCK SETDAT 00 000 76/07/25 08.49
*
TITLE -SETDAT- COMMAND
*
* SET VALUE OF STUDENT DATA RESERVED WORD
* SETDAT WORD_EXPRESSION
*
SETROV OVRLAY
CALL NXTNAME GET TAG ****
* RETURNS TAG ENTRY IN X6,
* SEPARATOR IN X1, SEPARATOR TYPE IN X2
SX1 X1-KASSIGN CHECK FOR ASSIGN ARROW
NZ X1,ERRTERM IF NOT GIVE CONDENSE ERROR
MX0 6*7
BX2 -X0*X6 CHECK FOR OVER 7 CHARS
NZ X2,ERRNAME
SA6 ENDLST PLANT END TEST FOR SEARCH
SA2 RSVLST-1 INITIALIZE SEARCH
RSV100 SA2 A2+1
IX3 X6-X2
NZ X3,RSV100
SB1 A2-ENDLST
ZR B1,ERRNAME NOT FOUND IN LIST
SB1 A2-RSVLST COMPUTE INDEX IN LIST
SX7 B1 STORE INDEX IN LIST
SA7 SRTEMP
CALL COMPILE GET VALUE OF NEXT ARGUMENT
MX0 -XCODEL
BX6 -X0*X1 ONLY GETVAR CODE
LX6 60-2*XCODEL
SA1 SRTEMP PICK UP WORD NUMBER
SX1 X1 LIMIT TO 18 BITS
LX1 60-XCODEL PUT IN TOP BITS
BX6 X6+X1 COMBINE WITH GETVAR CODE
EQ PUTCODE
*
RSVLST DATA 7LAARROWS
DATA 3LAOK
DATA 6LAOKIST
DATA 4LASNO
DATA 4LAUNO
DATA 5LAHELP
DATA 6LAHELPN
DATA 5LATERM
DATA 6LATERMN
DATA 5LAAREA
DATA 5LATIME
ENDLST BSS 1
*
SRTEMP BSS 1
*
ENDOV
* /--- BLOCK SUBMITM 00 000 80/12/15 22.22
TITLE -SUBMITM- / -SUBMITX- COMMANDS
*
*
*
* -SUBMITM- COMMAND
* 1ST ARGUMENT = MAIN-FRAME NUMBER
* 2ND = ACCOUNT NAME
* 3RD = FILE NAME
* 4TH = BLOCK NAME
* 5TH (OPT) = SECURITY INFORMATION BUFFER
*
* -SUBMITX- COMMAND
* 1ST ARGUMENT = MAIN-FRAME NUMBER
* 2ND = CONTROL CARD BUFFER
* 3RD = LENGTH OF CONTROL CARD BUFFER
* 4TH = (UNUSED)
* 5TH (OPT) = SECURITY INFORMATION BUFFER
*
*
SUBMOV OVRLAY
CALL VARDO1 GET MAINFRAME ARGUMENT
SX6 0 PRE-ZERO 4TH AND 5TH ARGUMENTS
SA6 VARBUF+4
SA6 VARBUF+5
SA1 OVARG1
NZ X1,SUBMITX --- JUMP IF SUBMITX
*
* -SUBMITM- COMMAND
*
CALL ACCFILE,VARBUF+2,0
ZR X1,ERR2FEW
CALL COMPNAM GET BLOCK NAME
BX6 X1
SA6 VARBUF+4
EQ SECURE
*
* -SUBMITX- COMMAND
*
SUBMITX CALL VARDO2 CONTROL CARD BUFFER
NG X6,ERRSTOR --- ERROR IF NOT STOREABLE
CALL VARDO2 BUFFER LENGTH
*
*
* CHECK FOR SECURITY INFORMATION BUFFER ARGUMENT
*
SECURE SX6 4 4 ARGUMENTS SO FAR
SA6 VARBUF
SA1 LASTKEY
ZR X1,SBMEND --- IF END OF LINE
CALL VARDO2
NG X6,ERRSTOR --- ERROR IF NOT STOREABLE
SA1 LASTKEY
NZ X1,ERR2MNY
*
SBMEND SX6 5 5 ARGUMENTS
SA6 VARBUF
BX1 X6
EQ VARFIN
ENDOV
*
*
* /--- BLOCK FINDS 00 000 76/08/29 21.54
*
*
TITLE -FINDS-/-FINDSA- COMMAND READINS
*
* -FINDS-
*
* READIN IS MODIFIED FROM -SORT- COMMAND READIN
*
* COMMAND WORD CONSISTS OF';
* 6 BITS TYPE'; 0 N,NC VAR
* 1 ECS COMMON VAR
* 2 ECS STORAGE VAR
* *XCODEL* BITS LIST GETVAR CODE'; ADDRESS IN CM/ECS
* 12 BITS POSITION OF EXTRA GETVAR CODES IN XSTORAGE
*
* 3 WORDS OF EXTRA STORAGE GVAR CODES';
* OBJECT,LENGTH,INCREMENT,1STBIT,NUMBITS,RETURN,MASK
*
*
* FINDS OBJECT,LIST;LTH,INC,1ST BIT,NUM BITS,RETURN,MASK
* FINDSA OBJECT,LIST;LTH,INC,1ST CHAR,NUM CHARS,RETURN,MASK
*
* NOTE THAT ONLY THE LAST ARGUMENT, *MASK*, IS OPTIONAL
*
* NOTE ALSO THAT TOP BIT OF OBJECT GETVAR CODE IS SET IF
* IT IS NON-STORABLE
*
*
FINDSOV OVRLAY
*
CALL VARDO1 EVALUATE OBJECT GVAR CODE
*
SA1 WORDPT SAVE *WORDPT*
BX6 X1
SA6 OLDPT
*
MX6 0
SA6 VARBUF+7 INITIALIZE MASK ENTRY
*
* EVALUATE LIST TYPE / LOCATION
*
CALL NXTNAM GET FIRST ENTRY
SX0 X1-1R,
NZ X0,FIND150 JUMP IF MAY BE CM BUFFER
MX0 42
SA1 FINDLST-1 SET UP FOR BUFFER TYPE SEARCH
*
FIND110 SA1 A1+1 LOAD NEXT LIST ENTRY
ZR X1,FIND150 CHECK IF CM BUFFER
BX2 X0*X1 MASK OFF BUFFER TYPE NAME
IX2 X2-X6 COMPARE WITH NXTNAM RETURN
NZ X2,FIND110 LOOP BACK
*
* PROCESS HERE IF FORM -FINDS S,3;- OR -FINDS C,10;-
*
SX6 X1 PICK UP BUFFER TYPE NAME
LX6 60-6 AND LEFT-JUST IT
SA6 FINDWK
*
CALL COMPILE EVALUATE POSITION EXPRESSION
LX1 60-6-XCODEL POSITION GVAR CODE
*
SA2 FINDWK
BX6 X1+X2 MERGE TYPE/POSITION
SA6 A2 STORE IT
*
SA1 LASTKEY MUST END WITH SEMI-COLON
SX0 X1-KSEMIC
ZR X0,FIND200
EQ ERRTERM SEMICOLON NOT FOUND
* /--- BLOCK FINDS 00 000 76/09/12 21.14
*
* PROCESS HERE IF OF FORM -FINDS N1;- OR -FINDS NC1;-
*
FIND150 SA1 OLDPT RESTORE WORDPT
BX6 X1
SA6 WORDPT
*
CALL COMPILE EVALUATE BUFFER EXPRESSION
NZ B1,ERRSTOR ERROR IF NOT STORABLE
LX1 60-6-XCODEL POSITION GVAR CODE
*
BX6 X1
SA6 FINDWK AND STORE IT
*
SA1 LASTKEY MUST END WITH SEMI-COLON
SX0 X1-KSEMIC
NZ X0,ERRTERM SEMI-COLON NOT FOUND
*
*
* PROCESS REMAINING ARGUMENTS
*
FIND200 CALL VARDO2 LENGTH
CALL VARDO2 INCREMENT
CALL VARDO2 1ST BIT
CALL VARDO2 NUM BITS
*
CALL PUTCOMP *RETURN*
NG B1,ERRSTOR MUST BE STORABLE
BX6 X1 STORE CODE IN VARBUF
SA6 VARBUF+6
SX6 6 INCREMENT VARBUF
SA6 VARBUF
*
SA1 LASTKEY SEE IF ANOTHER ARGMUENT
ZR X1,FIND210 NO MORE ARGUMENTS
CALL VARDO2 GET MASK GETVAR CODE
*
SA1 VARBUF+7
MX0 -XCODEL
BX1 -X0*X1 GIVE ERROR IF MASK IS ZERO
ZR X1,ERRORC
*
SA1 LASTKEY
NZ X1,ERR2MNY TOO MANY TAGS
*
FIND210 SA1 VARBUF+1 FETCH OBJECT GVAR CODE
MX0 1 SET TOP BIT IF NOT STORABLE
BX2 X0*X1 GET TOP BIT
LX2 XCODEL
BX6 X1+X2 AND MERGE WITH GVAR CODE
SA6 VARBUF+1
*
* /--- BLOCK FINDS 00 000 76/09/12 21.09
*
* NOW STORE ALL GVAR CODES AND WRAP IT UP
*
SA1 INX GET INDEX IN EXTRA STORAGE
BX6 X1 X1 = INX
LX6 60-6-XCODEL-12 POSITION XSTOR INDEX
SA2 FINDWK
BX6 X2+X6 X6 = COMMAND WORD
MX0 -XCODEL X0 = XCODEL MASK
*
SA2 VARBUF+1 OBJECT GVAR CODE
SA3 VARBUF+2 LENGTH GVAR CODE
SA4 VARBUF+3 INCREMENT GVAR CODE
*
BX2 -X0*X2 MASK OFF
BX3 -X0*X3
BX4 -X0*X4
*
LX2 60-1*XCODEL AND POSITION THEM
LX3 60-2*XCODEL
LX4 60-3*XCODEL
*
BX7 X2+X3 NOW MERGE AND STORE
BX7 X7+X4
SA7 X1+INFO STORE
*
SA2 VARBUF+4 1ST BIT GVAR CODE (1ST CHAR)
SA3 VARBUF+5 NUM BITS GVAR CODE (NUM CHARS)
SA4 VARBUF+6 *RETURN* GVAR CODE
*
BX2 -X0*X2 MASK
BX3 -X0*X3
BX4 -X0*X4
*
LX2 60-1*XCODEL POSITION
LX3 60-2*XCODEL
LX4 60-3*XCODEL
*
BX7 X2+X3 MERGE AND STORE
BX7 X7+X4
SA7 X1+INFO+1
*
SA2 VARBUF+7 FIND MASK GVAR CODE
BX7 -X0*X2 MASK MASK CODE (HEHE)
LX7 60-XCODEL POSITION IT
SA7 X1+INFO+2 STORE
*
SX7 X1+3 INCREMENT INX POINTER
SA7 INX
SA1 ICX
IX1 X7-X1 CHECK FOR UNIT BUFFER OVERFLOW
PL X1,LNGUNIT
EQ PUTCODE EXIT
*
* FINDLST IS USED BY FINDS,FINDSA,INSERTS,DELETES
*
FINDLST VFD 42/0LSTORAGE,18/2
VFD 42/0LS,18/2
VFD 42/0LCOMMON,18/1
VFD 42/0LC,18/1
DATA 0
*
FINDWK BSS 1
*
ENDOV
* /--- BLOCK INSERTS 00 000 77/01/11 17.12
*
TITLE -INSERTS- COMMAND
*
* READIN IS MODIFIED FROM -SORT- COMMAND READIN
*
*INSERTS BUFFER,LIST;LENGTH,INCREMENT,POSIT,NUMBER (OPT.)
* BUFF2,LIST2;INC2
*
* COMMAND WD'; 6 BITS LIST TYPE CODE
* 20 BITS LIST GVAR CODE
* 12 BITS XSTOR POSIT OF GVAR CDS
* 6 BITS ASSOC. LIST TYPE CODE
*
* TYPE CODE IS 0=CM,1=ECS COMMON,2=ECS STORAGE
* ASSOCIATED LIST TYPE CODE IS SAME AS ABOVE, EXCEPT TOP
* BIT OF 6 BIT CODE IS SET AS FLAG THAT THERE IS ASSOC. LIST
*
*XSTOR GETVAR WORDS (3)
*
* WD1'; BUFFER,LENGTH,INCREMENT
* WD2'; POSIT,NUMBER,BUFFER2
* WD3'; LIST2,INCREMENT2
*
*
INSRTOV OVRLAY
*
SA1 OVARG1
NZ X1,DELETOV FOR -DELETES- COMMAND
*
CALL VARDO1 EVALUATE OBJECT GVAR CODE
SA1 VARBUF+1
NG X1,ERRSTOR BUFFER MUST BE LOCATION
CALL SLINE1 EVALUATE REST OF LINE
*
*
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED
BX2 X1-X2
NZ X2,INSRT10 NOT CONTINUED
*
CALL GETLINE GET NEXT LINE OF TEXT
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED
BX2 X1-X2
ZR X2,ERRCNTD ERROR IF CONTINUED FURTHER
*
*
CALL VARDO2 EVALUATE ASSOC. LIST OBJECT
SA1 VARBUF
SA1 X1+VARBUF
NG X1,ERRSTOR BUFFER MUST BE LOCATION
CALL SLINE2 EVALUATE REST OF ASSOC. LIST
*
INSRT10 EQ LSTFIN STORE GVAR CODES AND WRAP UP
*
* /--- BLOCK DELETES 00 000 77/01/11 17.15
*
TITLE -DELETES- COMMAND
*
* READIN IS MODIFIED FROM -SORT- COMMAND READIN
*
*DELETES LIST;LENGTH,INCREMENT,POSIT,NUMBER (OPT.)
* LIST2;INC2
*
* COMMAND WD'; 6 BITS LIST TYPE CODE
* 20 BITS LIST GVAR CODE
* 12 BITS XSTOR POSIT OF GVAR CDS
* 3 BITS 0
* 6 BITS ASSOC. LIST TYPE CODE
* 9 BITS COMMAND NUMBER
*
* TYPE CODE IS 0=CM,1=ECS COMMON,2=ECS STORAGE
* ASSOCIATED LIST TYPE CODE IS SAME AS ABOVE, EXCEPT TOP
* BIT OF 6 BIT CODE IS SET AS FLAG THAT THERE IS ASSOC. LIST
*
*XSTOR GETVAR WORDS (3)
*
* WD1'; 0,LENGTH,INCREMENT
* WD2'; POSIT,NUMBER,0
* WD3'; LIST2,INCREMENT2
*
* THE 0 GETVAR CODES ARE SO FORMAT IS EXACTLY LIKE THE
* -INSERTS- COMMAND
*
*
*
DELETOV SX6 1
SA6 VARBUF INCREMENT VARBUF CAUSE NO BUFF
MX6 0
SA6 A6+1 ZERO BUFFER GVAR CODE
CALL SLINE1 EVALUATE FIRST LINE
*
*
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED
BX2 X1-X2
NZ X2,DELET10 NOT CONTINUED
*
CALL GETLINE GET NEXT LINE OF TEXT
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED
BX2 X1-X2
ZR X2,ERRCNTD ERROR IF CONTINUED FURTHER
*
*
SA1 VARBUF
SX6 X1+1 INCREMENT VARBUF (NO BUFF2)
SA6 VARBUF
MX7 0
SB1 A6
SA7 X6+B1 STORE ZERO AS GVAR CODE
CALL SLINE2 EVALUATE REST OF ASSOC. LIST
*
DELET10 EQ LSTFIN STORE XSTOR GVARS AND WRAP UP
*
* /--- BLOCK INSERTS-1 00 000 77/03/30 22.24
TITLE -INSERTS- ROUTINES
*
* PROCESS FIRST LINE OF INSERTS AND DELETES COMMANDS
*
SLINE1 EQ *
*
SA1 WORDPT
BX6 X1
SA6 OLDPT SAVE WORDPT
*
CALL NXTNAM GET FIRST ENTRY
SX0 X1-1R,
NZ X0,SLIN150 JUMP IF MAY BE CM BUFFER
MX0 42
SA1 INSTLST-1 SET UP FOR BUFFER TYPE SEARCH
*
SLIN110 SA1 A1+1 LOAD NEXT ENTRY
ZR X1,SLIN150 CHECK IF CM BUFFER
BX2 X0*X1 MASK OFF BUFFER TYPE NAME
IX2 X2-X6
NZ X2,SLIN110
*
SX6 X1 PICK UP BUFFER TYPE CODE
LX6 60-6
SA6 CMNDWD STORE FOR NOW
CALL COMPILE EVALUATE POSITION EXPRESSION
LX1 60-6-XCODEL POSITION GVAR CODE
SA2 CMNDWD
BX6 X1+X2 MERGE TYPE/POSITION
SA6 A2
SA1 LASTKEY MUST END WITH SEMICOLON
SX0 X1-KSEMIC
ZR X0,SLIN200
EQ ERRTERM
*
*
SLIN150 SA1 OLDPT RESTORE WORDPT
BX6 X1
SA6 WORDPT
CALL COMPILE EVALUATE BUFFER EXPRESSION
NZ B1,ERRSTOR ERROR IF NOT STORABLE
BX6 X1
LX6 60-6-XCODEL POSITION GVAR CODE
SA6 CMNDWD SAVE
SA1 LASTKEY MUST END WITH A SEMI-COLON
SX0 X1-KSEMIC
NZ X0,ERRTERM
*
* PROCESS REMAINING ARGUMENTS
*
SLIN200 CALL VARDO2 LENGTH OF LIST
CALL VARDO2 INCREMENT OF EACH ENTRY
CALL VARDO2 POSITION TO ADD
SA1 LASTKEY
NZ X1,SLIN201 GET LAST ARGUMENT
*
SA1 VARBUF
SX6 X1+1 INCREMENT VARBUF (NO NUMBER)
SA6 VARBUF
SX7 1 DEFAULT OF 1 ITEM TO INSERT
SB1 A6
SA7 X6+B1 STORE ZERO FOR NUMBER
EQ SLINE1 DONE
*
*
SLIN201 CALL VARDO2 GET NUMBER GVAR CODE
SA1 LASTKEY
NZ X1,ERR2MNY TOO MANY TAGS
EQ SLINE1
*
*
* /--- BLOCK INSERTS-2 00 000 76/09/13 13.45
*
* PROCESS THE SECOND LINE FOR INSERTS AND DELETES
*
SLINE2 EQ *
*
SA1 WORDPT SAVE WORDPT
BX6 X1
SA6 OLDPT
*
CALL NXTNAM GET FIRST ENTRY
SX0 X1-1R,
NZ X0,SLIN250 JUMP IF MAY BE CM BUFFER
MX0 42
SA1 INSTLST-1 SET UP FOR BUFFER TYPE SEARCH
*
SLIN220 SA1 A1+1 LOAD NEXT LIST ENTRY
ZR X1,SLIN250 CHECK IF CM BUFFER
BX2 X0*X1 MASK OFF BUFFER TYPE NAME
IX2 X2-X6
NZ X2,SLIN220
*
SX6 X1+40B PICK UP BUFFER TYPE CODE
LX6 XCMNDL
SA1 CMNDWD PICK UP COMMAND WORD
BX6 X1+X6 MERGE
SA6 CMNDWD AND STORE
CALL VARDO2 EVALUATE LOCATION ARGUMENT
EQ SLIN260
*
*
SLIN250 SA1 OLDPT RESTORE WORDPT
BX6 X1
SA6 WORDPT
*
SX6 40B SET BUFFER TYPE CODE
LX6 XCMNDL MOVE OVER
SA1 CMNDWD PICK UP COMMAND WORD
BX6 X1+X6 MERGE
SA6 CMNDWD AND STORE
*
CALL VARDO2 EVALUATE BUFFER EXPRESSION
SA1 VARBUF
SA1 X1+VARBUF LOAD BUFFER GETVAR CODE
NG X1,ERRSTOR MUST BE STOREABLE
*
SLIN260 SA1 LASTKEY MUST END IWTH A SEMICOLON
SX0 X1-KSEMIC
NZ X0,ERRTERM
*
* EVALUATE ENTRY DIMENSION EXPRESSION
*
CALL VARDO2 EVALUATE DIMENSION EXPRESSION
SA1 LASTKEY
NZ X1,ERRTERM ERROR IF NOT END OF LINE
EQ SLINE2
*
*
*
* /--- BLOCK INSERTS-3 00 000 77/01/11 17.22
*
* FINAL PROCESSING FOR INSERTS AND DELETES COMMANDS
*
LSTFIN SA1 INX GET INDEX IN EXTRA STORAGE
BX6 X1
LX6 60-6-XCODEL-12 POSITION XSTOR INDEX
SA2 CMNDWD
BX6 X2+X6 X6 = PARTIAL COMMAND WORD
*
* PACK UP REMAINING GETVAR CODES
*
MX0 -XCODEL
*
SA2 VARBUF+1 LOAD BUFFER -GETVAR- CODE
SA3 VARBUF+2 LOAD LENGTH -GETVAR- CODE
SA4 VARBUF+3 LOAD INCREMENT -GETVAR- CODE
BX2 -X0*X2
BX3 -X0*X3
BX4 -X0*X4
LX2 60-XCODEL POSITION -GETVAR- CODES
LX3 60-2*XCODEL
LX4 60-3*XCODEL
BX7 X2+X3 COMBINE -GETVAR- CODES
BX7 X4+X7
SA7 X1+INFO STORE 1ST XSTOR WORD
*
SA2 VARBUF+4 LOAD POSITION -GETVAR- CODE
SA3 VARBUF+5 LOAD NUMBER -GETVAR- CODE
SA4 VARBUF+6 LOAD ASSOC BUFF -GETVAR- CODE
BX2 -X0*X2
BX3 -X0*X3
BX4 -X0*X4
LX2 60-XCODEL POSITION -GETVAR- CODES
LX3 60-2*XCODEL
LX4 60-3*XCODEL
BX7 X2+X3 COMBINE -GETVAR- CODES
BX7 X4+X7
SA7 X1+INFO+1 STORE 2ND XSTOR WORD
*
SA2 VARBUF+7 LOAD ASSOC LST -GETVAR- CODE
SA3 VARBUF+8 LOAD ASSOC INCREMNT GETVAR CODE
BX2 -X0*X2
BX3 -X0*X3
LX2 60-XCODEL POSITION -GETVAR- CODE
LX3 60-2*XCODEL
BX7 X2+X3
SA7 X1+INFO+2 AND STORE IT
*
SX7 X1+3
SA7 INX INCREMENT *INX*
SA1 ICX
IX1 X7-X1 CHECK FOR UNIT BUFFER OVERFLOW
PL X1,LNGUNIT
EQ PUTCODE EXIT
*
INSTLST VFD 42/0LSTORAGE,18/2
VFD 42/0LS,18/2
VFD 42/0LCOMMON,18/1
VFD 42/0LC,18/1
DATA 0
*
CMNDWD BSS 1 PARTIAL COMMAND WORD
*
ENDOV
* /--- BLOCK COVL3 00 000 80/10/01 03.12
TITLE COVL3 COMMAND READ-INS
*
*
*
COVL3 OVRLAY
SA1 OVARG1 GET OVERLAY ARGUMENT
SB1 X1
JP B1+*+1 JUMP TO APPROPRIATE COMMAND
*
+ EQ INHIBC 0 = -INHIBIT- COMMAND
+ EQ FORCEIN 1 = -FORCE- COMMAND
+ EQ RANDUIN 2 = -RANDU- COMMAND
+ EQ RANDPIN 3 = -RANDP- COMMAND
+ EQ ANSVC 4 = -ANSV- COMMAND
+ EQ RESTIN 5 = -RESTART- COMMAND
+ EQ EXCHIN 6 = -EXCHANG- COMMAND
+ EQ STATSIN 7 = -STATS- COMMAND
+ EQ GETWDC 8 = -GETWORD- COMMAND
+ EQ GETLOCC 9 = -GETLOC- COMMAND
+ EQ SEARCHC 10 = -SEARCH- COMMAND
+ EQ COMPUIN 11 = -COMPUTE- COMMAND
+ EQ CALCSIN 12 = -CALCS- COMMAND
+ EQ CSLOOP 13 = *CSLOOP* ROUTINE
+ EQ COLORIN 14 = -COLOR- COMMAND
+ EQ CTIMEIN 15 = -CTIME-, -CDATE- COMMANDS
*
*
* /--- BLOCK -INHIBIT- 00 000 79/01/05 01.47
TITLE -INHIBIT- COMMAND READ-IN
*
*
*
* -INHIBIT- COMMAND READ-IN
*
INHIBC SB1 HIBLIST SET UP ARGUMENTS
SB2 HIBEND
MX5 60 FULL WORD MASK
CALL SCANNER SCAN INHIBIT NAME LIST
NZ X0,ERRNAME SEE IF ANY ERROR
* CHECK FOR SYSTEM-LESSON-ONLY KEYWORDS.
SA1 SYSHIBS
BX1 X1*X6
ZR X1,PUTCODE IF NO SYSTEM-LESSON-ONLY BITS
* SYSTEM-LESSON-ONLY KEYWORDS SELECTED - MAKE SURE
* THIS IS A SYSTEM LESSON.
RJ SYSTEST
EQ PUTCODE
PURGMAC INHIB
MACREF INHIB$
INHIB MACRO NAME,SYS
MACREF INHIB
+ VFD 60/0L_NAME
SYSHIB RMT
SYSIF IFC EQ,*SYS**
VFD 1/0
SYSIF ELSE
VFD 1/1
SYSIF ENDIF
SYSHIB RMT
ENDM
HIBLIST INHIB ERASE DONT DO FULL SCREEN ERASE
INHIB ARROW DONT PLOT ARROW
INHIB ANSERASE ANS CONTG WRITING ERASURE
INHIB NEXT NEXT
INHIB NOMOVE DONT MOVE ARROW UNTIL ANS OK
INHIB BLANKS DISALLOW BLANK STUDENT INPUT
INHIB CHARCLEAR DONT UNSET CHARSET FLAG ON -CHAR- COMMAND
INHIB DROPSTOR DONT DROP XSTOR ON JUMPOUT
INHIB UNLOAD DONT UNLOAD ON CON/STO LOAD
INHIB LOAD DONT LOAD ON CON/STO LOAD
INHIB JUMPCHK DONT DO ECS CHECK ON JUMPOUT
INHIB EDIT DISABLE -EDIT- KEY FUNCTIONS
INHIB FROM DONT SET *FROM* ON JUMPOUT
INHIB TERM DISABLE -TERM- FUNCTIONS
INHIB ADVANCE NO AUTO ADVANCE WHEN ARROW SATISFIED
INHIB CLEAR CLEAR BEFORE SET
INHIB DROPFILE DONT DROP DATASET/NAMESET
INHIB DROPCOM DONT DROP COMMON
INHIB DROPLIST,SYS DONT DROP LESLIST
INHIB ARETURN,SYS DISABLE RETURNING TO ARROW
HIBEND BSS 1 SCRATCH FOR SCANNER ROUTINE
* SYSTEM-LESSON-ONLY FLAGS.
SYSHIBS BSS 0
LIST G
SYSHIB HERE
LIST *
* /--- BLOCK -INHIBIT- 00 000 81/07/22 20.52
*
*
* -FORCE- COMMAND READ-IN
* SAME FORMAT AS -INHIBIT- BUT ENABLES RATHER THAN
* DISABLES
*
FORCEIN SB1 FOLIST
SB2 FOEND
MX5 60 FULL WORD MASK
RJ SCANNER
ZR X0,PUTCODE SEE IF ANY ERROR
EQ ERRNAME ELSE ERROR
*
FOLIST VFD 60/4LLONG FORCE JUDGING ON CHAR LIMIT
VFD 60/4LFONT FORCE FONT AS CHAR 1
VFD 60/5LMICRO FORCE CONTINUOUS MICRO OPTION
VFD 60/10LFIRSTERASE IF ANSWER WRONG, ERASE
* ENTIRE INPUT WHEN NEXT CHARACTER IS ENTERED
VFD 60/4LLEFT FORCE LEFT WRITING
VFD 60/0LCLEAR CLEAR BEFORE SET
VFD 60/0LBOLD FORCE BOLD WRITTING
VFD 60/0LCAPS ALL CAPS
FOEND BSS 1
*
* /--- BLOCK -RANDU- 00 000 79/01/05 01.59
TITLE -RANDU- COMMAND READ-IN
*
*
*
* -RANDU- COMMAND READ-IN
* IF ONE VARIABLE, SPECIFIES A VARIABLE
* IN WHICH A RANDOM NUMBER IN (0,1) IS TO BE
* STORED. IF TWO VARIABLES, THE FIRST IS
* A STORAGE VARIABLE FOR AN INTEGER BETWEEN
* ONE AND THE VALUE OF THE SECOND VARIABLE.
*
RANDUIN CALL PUTCOMP COMPILE FIRST TAG
SA2 LASTKEY
ZR X2,CALCODE DONE IF ONE TAG--CODE IN X1
BX6 X1
LX6 -XCODEL POSITION -PUTVAR- CODE
SA6 VARBUF AND SAVE IT.
CALL COMPILE COMPILE NEXT TAG
RANDU1 SA2 LASTKEY *** ENTRY FROM RANDPIN
NZ X2,ERR2MNY ERROR IF MORE THAN 2 TAGS
SA2 VARBUF PREPARE COMMAND WORD
LX1 -XCODEL-XCODEL
BX6 X1+X2 WITH BOTH CODES
SA1 COMNUM AND INCREMENTED COMMAND NUMBER
SX1 X1+1
BX6 X6+X1
EQ ALTCODE
*
*
*
* -RANDP- COMMAND READ-IN
*
RANDPIN CALL PUTCOMP COMPILE FIRST TAG
SA2 LASTKEY
ZR X2,CALCODE DONE IF ONE TAG--CODE IN X1
BX6 X1
LX6 -XCODEL POSITION -PUTVAR- CODE
SA6 VARBUF AND SAVE IT.
CALL COMPILE COMPILE NEXT TAG
NZ B1,ERRSTOR ERROR IF NON-STOREABLE
EQ RANDU1 OTHERWISE FINISH COMPILING
*
*
* /--- BLOCK -ANSV- 00 000 79/01/05 02.22
TITLE -ANSV- COMMAND READIN
*
*
*
* -ANSV- COMMAND READ-IN
*
ANSVC SA1 TAGCNT X1 = NUM CHARACTERS IN TAG
ZR X1,ERR2FEW ERROR EXIT IF NO TAG
SX6 0
SA6 APTSW PRE-SET TO ABS TOLERANCE
SA2 TAG-1+X1 X2 = LAST CHARACTER
SX3 X2-KPCT CHECK FOR PER CENT SIGN
NZ X3,ANSVIN1 JUMP IF ABSOLUTE TOLERANCE
MX7 0
SA7 A2 OVERWRITE PERCENT SIGN WITH EOL
MX6 1
LX6 60-2*XCODEL
SA6 A6 RE-SET TO PERCENT TOLERANCE
ANSVIN1 SA1 OVARG2 CHECK FOR ANSU OR ANSV
ZR X1,ANSVIN2 JUMP IF ANSV
CALL COMPILU COMPILE UNIT DIMENSIONS
EQ ANSVIN3
ANSVIN2 CALL COMPILE COMPILE WITHOUT UNIT DIMENSIONS
ANSVIN3 SA2 LASTKEY
LX1 60-XCODEL
ZR X2,ANSVIN4 JUMP IF END OF LINE
BX7 X1
SA7 VARBUF SAVE GETVAR CODE
RJ COMPILE GET SECOND ARG (TOLERANCE)
SA2 LASTKEY
NZ X2,ERR2MNY TWO ARGS MAX
SA2 VARBUF FIRST ARG
LX1 60-2*XCODEL
ANSVIN4 BX6 X1+X2 MERGE BOTH ARGS
SA3 APTSW
BX6 X6+X3 ADD ABS/PERCENT TOLERANCE FLAG
SA1 OVARG2
ZR X1,PUTCODE JUMP IF ANSV
BX6 X1+X6 MERGE COMMAND NUMBER
SA1 NDEFU NUMBER OF UNITS DEFINED
SB1 X1
SA1 ATEMPEC
BX0 X1
SA0 UADS UNIT COEFFICIENTS
+ WE B1
RJ ECSPRTY
SA1 INX
SX7 X1+B1 INCREMENT INX
SA7 A1
SA0 X1+INFO ADDRESS FOR UNIT COEFFS
+ RE B1
RJ ECSPRTY
SX1 X1+1 INSURE NZ TO DISTINGUISH ANSU
LX1 XCMNDL POSITION POINTER TO UNIT COEFFS
BX6 X1+X6 MERGE WITH ARGS
EQ ALTCODE
*
APTSW BSS 1 ABSOLUTE / PERCENT TOLER FLAG
*
* /--- BLOCK -RESTART- 00 000 80/02/02 23.45
TITLE -RESTART- COMMAND READ-IN
*
*
*
* -RESTART- COMMAND READ-IN
* A. NO ARGS. MEANS USE CURRENT LESSON, CURRENT UNIT
* B. ONE ARG. MEANS USE CURRENT LESSON, THIS UNIT
* C. TWO ARGS. MEANS USE THIS LESSON, THIS UNIT
*
RESTIN CALL ACCFILE,VARBUF+1,0
ZR X1,=XPAUSE2 --- IF BLANK TAG
SA2 LASTKEY
NZ X2,REST2 --- IF MORE THAN ONE ARGUMENT
*
* SINGLE-ARGUMENT FORM (UNIT NAME ONLY)
*
SX0 X1-1
NZ X0,ERRTAGS ERROR IF ARGUMENT IS LESSON NAME
SA2 VARBUF+2 LOAD GETVAR CODE
LX2 60-XCODEL POSITION GETVAR CODE
LX1 58
BX6 X1+X2 SET 2ND BIT OF GETVAR CODE
EQ PUTCODE
*
* LESSON AND UNIT SPECIFIED
*
REST2 CALL COMPNAM GET UNIT NAME
BX6 X1
SA6 VARBUF+3
SA1 LASTKEY
NZ X1,ERR2MNY ERROR IF NOT END-OF-LINE
SX6 3
SA6 VARBUF SET NUMBER OF ARGUMENTS
BX1 X6
EQ VARFIN
*
* /--- BLOCK -STATS- 00 000 80/04/07 21.32
TITLE -STATS- COMMAND READ-IN
*
*
*
STATSIN CALL SYSTEST
CALL VARDO1 GET TYPE OF STATISTICS
SA2 LASTKEY SEE IF EOL
NZ X2,STATS1 IF ACCOUNT';FILE PRESENT
SA1 VARBUF+1
MX6 1
LX6 XCODEL
BX6 X1+X6 SET TOP BIT IF ONLY ONE ARG.
SA6 A1
SX1 1 ONE GETVAR CODE
EQ =XVARFIN
STATS1 CALL ACCFILE,(VARBUF+2),0 PROCESS ACCOUNT';FILE
SA1 LASTKEY
NZ X1,ERR2MNY ERROR IF NOT EOL
SX6 3
SA6 VARBUF ADJUST NUMBER OF ARGUMENTS
SX1 3 THREE GETVAR CODES
EQ =XVARFIN
* /--- BLOCK -EXCHANG- 00 000 80/05/15 20.20
TITLE -EXCHANG- COMMAND READ-IN
*
*
* TAG ON -EXCHANG- COMMAND SPECIFIES IF THE
* LOGICAL SITE CONTROLLER IS TO BE BYPASSED.
*
EXCHIN CALL SYSTEST
SA1 LESSON
SA2 KPLAT CHECK FOR LESSON -PLATO-
BX2 X1-X2
ZR X2,EXCHANC
SA2 KNPLAT
BX2 X1-X2 CHECK FOR LESSON -NPLATO-
NZ X2,ERRORC
*
EXCHANC MX6 0 PRESET X6
SA1 TAGCNT CHECK FOR BLANK TAG
ZR X1,PUTCODE -- ASSUME BLANK = 0
EQ ONE2IN IN ',CONDC',
EQ PUTCODE
*
KPLAT DATA 5LPLATO
KNPLAT DATA 6LNPLATO
*
*
* /--- BLOCK -GETWORD- 00 000 79/01/23 01.06
TITLE -GETWORD- COMMAND READ-IN
*
*
*
* -GETWORD- COMMAND READ-IN
* GET THE N-TH WORD OUT OF THE STUDENT ANSWER
* AND PUT INTO THE STATED BUFFER.
*
* GETWORD VAR1,VAR2,VAR3,VAR4
* VAR1 = WORD WANTED
* VAR2 = ADDRESS TO PUT WORD PACKED 10 CHARS / WORD
* VAR3 = RETURN ACTUAL CHARACTER COUNT
* VAR4 = MAXIMUM ALLOWABLE NUMBER OF CHARACTERS
* (IF ABSENT, SET TO DEFAULT 10)
*
GETWDC CALL VARDO GET COMMA SEPARATED VARS
SA1 VARBUF+2 VAR2 MUST BE STORABLE
NG X1,ERRSTOR
SA1 VARBUF+3 DITTO FOR VAR3
NG X1,ERRSTOR
SA1 VARBUF SEE IF RIGHT NUMBER OF ARGS
SX2 X1-4
ZR X2,VARFIN GO TO STANDARD PACK-UP ROUTINE
SX2 X1-3 SEE IF NEED TO GENERATE 4TH ARG
NZ X2,ERRTAGS ALL ELSE AN ERROR IN FORM
SX6 10 SET DEFAULT SMALL CONSTANT 10
SA6 VARBUF+4 AS FOURTH ARG
SX6 4 AND RESET VARBUF TO 4 ARGS
SA6 VARBUF
BX1 X6 AND X1 ALSO SET TO 4 ARGS
EQ VARFIN EXIT TO STANDARD PACK ROUTINE
*
* /--- BLOCK -GETLOC- 00 000 79/01/23 01.08
TITLE -GETLOC- COMMAND READ-IN
*
*
*
* -GETLOC- COMMAND READ-IN
* GET THE SCREEN LOCATION OF STUDENT WORDS
*
* GETLOC ARG1,ARG2,ARG3,(ARG4,ARG5)
* ARG1 = WORD WANTED
* ARG2 = STARTING X
* ARG3 = STARTING Y
* ARG4 = ENDING X --OPTIONAL
* ARG5 = ENDING Y --OPTIONAL
*
GETLOCC CALL VARDO GET COMMA SEPARATED VARS
SA1 VARBUF+2 VAR2 MUST BE STORABLE
NG X1,ERRSTOR
SA1 VARBUF+3 DITTO FOR VAR3
NG X1,ERRSTOR
SA1 VARBUF SEE IF RIGHT NUMBER OF ARGS
SX2 X1-3
NZ X2,GETLC1 IF 3 ARGS MUST ADD DUMMY 2 MORE
MX6 0
SA6 VARBUF+4
SA6 VARBUF+5
SX6 5
SA6 VARBUF
BX1 X6
EQ VARFIN
*
GETLC1 SX2 X1-5 SEE IF ENDING LOCATION WANTED
NZ X2,ERRTAGS ALL ELSE AN ERROR IN FORM
SA2 VARBUF+4 VAR4 MUST BE STORABLE
NG X2,ERRSTOR
SA2 VARBUF+5 DITTO FOR VAR5
NG X2,ERRSTOR
EQ VARFIN
*
* /--- BLOCK -SEARCH- 00 000 79/01/23 01.19
TITLE -SEARCH- COMMAND READ-IN
*
*
*
* -SEARCH- COMMAND READ-IN
*
* TAG HAS 6 (OR OPTIONALLY, 7) ENTRIES.
* 1ST = OBJECT (LEFT-JUSTIFIED)
* 2ND = OBJECT LENGTH IN CHARS
* 3RD = BASE ADDRESS FOR SEARCH
* 4TH = INFORMATION LENGTH IN CHARS
* 5TH = STARTING CHAR FOR SEARCH (OFFSET FROM BASE)
* 6TH = VARIABLE FOR STORAGE OF RETURN CODE--
* -1=NOT FOUND 1-N=FOUND STARTING AT CHAR N
* 7TH = LENGTH OF RETURN LIST (REPEATED SEARCHES)
*
SEARCHC CALL VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+3 BASE ADDRESS
NG X1,SCERR ERROR IF NOT STORE-ABLE
SA1 VARBUF+6 CODE FOR RETURN VARIABLE
NG X1,SCERR ERROR IF NOT STORE-ABLE
SA1 VARBUF+1 CODE FOR STRING
MX0 1
LX0 XCODEL-XFBIT
BX6 -X0*X1 MASK OUT I/F BIT (SET INTEGER)
SA6 A1
SX1 7 7 VARIABLES REQUIRED
SA2 VARBUF X2 = NUMBER OF VARIABLES
SX3 X2-6
NZ X3,VARFIN EXIT IF NOT 6 VARIABLES
BX6 X1
SA6 A2 RESET VARIABLE COUNT TO 7
MX7 1
LX7 XCODEL PREPARE DUMMY CODE FOR 7TH ARG
SA7 VARBUF+7 STORE AS 7TH ARGUMENT
EQ VARFIN
*
SCERR SB1 70 NON-STOREABLE VARIABLE
EQ ERR
*
* /--- BLOCK -COMPUTE- 00 000 79/07/15 15.19
TITLE -COMPUTE- COMMAND READ-IN
*
*
*
* -COMPUTE- COMMAND READ-IN
* COMPUTE RESULT,STRING,CHAR COUNT,POINTER
* (OPTIONAL)
*
* THE 4 TAG COMPUTE COMMAND IS SIMILAR TO A STORE COMMAND,
* EXCEPT THE COMPILED MACHINE CODE IS SAVED IN AN ECS
* BUFFER FOR LATER REUSE. POINTER IS SET TO POINT AT THIS
* COMPILED CODE, AND SUCCEEDING EXECUTIONS OF THE COMPUTE
* COMMAND WITH THIS POINTER WILL CAUSE SIMPLE FETCHES OF
* THE MACHINE CODE FROM ECS.
*
* THE 3 TAG VERSION FUNCTIONS THE SAME AS THE 4 TAG VERSION,
* EXCEPT THAT THE CODE IS NOT STORED FOR LATER REUSE. 'IT
* PROVIDES A WAY OF EVALUATING EXPRESSIONS OUTSIDE OF JUDGE
* STATE.
COMPUIN CALL PUTCOMP DECODE FIRST VARIABLE
BX6 X1
SA6 VARBUF+1 STORE FIRST -GETVAR- CODE
SX6 1
SA6 VARBUF INITIALIZE *VARBUF*
MX6 0
SA6 VARBUF+5
CALL VARDO2 DECODE REMAINING VARS
CALL VARDO2
SA2 LASTKEY CHECK FOR E-O-L
ZR X2,ONLY3 JUMP IF ONLY 3 ARGS
CALL VARDO2
SA1 LASTKEY MUST BE END-OF-LINE
NZ X1,ERR2MNY
SB1 4 CHECK POINTER ADDRESS
RJ JUSTAD CHECK FOR STORABILITY
ALLDONE SB1 2 CHECK STRING ADDRESS
RJ JUSTAD
SX1 4
EQ VARFIN
*
ONLY3 SX6 4
SA6 VARBUF SET ARGUMENT COUNT IN VARBUF
MX6 0 SET 4TH GETVAR CODE TO 0 TO
SA6 VARBUF+4 INDICATE LACK OF 4TH ARGUMENT
EQ ALLDONE
*
JUSTAD EQ * CHECK (VARBUF+B1) STORE-ABLE
* AND CLEAN OUT I/F BIT, SINCE AT EXECUTION TIME WE NEED
* ONLY THE ADDRESS, NOT THE VALUE.
SA1 VARBUF+B1 GET THE CODE
NG X1,ERRSTOR ERROR IF NOT STORE-ABLE
MX6 61-XCODEL+XFBIT MASK OUT I/F BIT
BX6 -X6*X1
SA6 A1
EQ JUSTAD
*
*
* /--- BLOCK -CALCS- 00 000 80/10/01 04.18
TITLE -CALCS- COMMAND READ-IN
*
*
*
* -CALCS- COMMAND READ-IN
* FOUR TO N VARS LEGAL
*
* EXAMPLE OF USAGE -
* CALCS V2+2,V1= 5,7,V8
* V1 IS SET TO 5 IF (V2+2) IS NEQATIVE
* V1 IS SET TO 7 IF (V2+2) IS ZERO
* V1 IS SET TO V8 IF (V2+2) IS POSITIVE
*
CALCSIN CALL VARDO1 GET FIRST VAR
SA1 WORDPT POINTER TO NEXT CHARACTER
SX0 KASSIGN ACCEPT ASSIGNMENT AS TERMINATOR
CALL PSCAN
ZR X1,ERR2FEW ERROR IF END OF LINE
SX6 1R,
SA6 B1 REPLACE WITH COMMA
CALL PUTCOMP DECODE VARIABLE TO STORE INTO
BX6 X1
SA6 VARBUF+2 STORE -GETVAR- CODE
SX6 2
SA6 VARBUF UPDATE NUMBER OF CODES
*
* -CSLOOP-
* BUILD LIST OF EXPRESSIONS INTO *VARBUF*, ASSUMING
* THAT 1) THE ARGUMENTS CAN BE BLANK, IN WHICH CASE
* A SPECIAL BIT IS SET, AND 2) THE COMMAND MAY BE
* CONTINUED ACROSS SOURCE LINES
*
* EXITS TO -VARFINM- WHEN DONE
*
CSLOOP CALL GETBARG GET (POSSIBLY BLANK) ARGUMENT
NZ X3,CSLOOP AND LOOP WHILE ARGUMENTS FOUND
ZR X2,CSNEXT GET NEW LINE IF E-O-L
*
* PUT DUMMY GETVAR CODE (1/1,19/0) INTO *VARBUF*
*
SA1 VARBUF
SX6 X1+1 ADVANCE *VARBUF* POINTER
SX1 X6-VARBUFL
PL X1,ERR2MNY ERROR IF BUFFER FULL
SA6 A1
MX7 1 SET UP SPECIAL GETVAR CODE
LX7 XCODEL
SA7 X6+VARBUF STORE IT
EQ CSLOOP
*
CSNEXT SA1 NEXTCOM CHECK FOR CONTINUATION
SA2 COMCONT
BX3 X1-X2
NZ X3,CSEND JUMP IF NOT CONTINUED
CALL GETLINE READ IN NEXT LINE
EQ CSLOOP
*
CSEND SA1 VARBUF
SX1 X1-3 MUST BE AT LEAST 3 VARS
PL X1,VARFINM
EQ ERR2FEW
*
* /--- BLOCK GETBARG 00 000 80/10/01 04.19
TITLE -GETBARG- GET POSSIBLY BLANK ARGUMENT
*
* -GETBARG-
* READ NEXT EXPRESSION, WHICH MAY BE BLANK, AND
* ASSEMBLE GETVAR CODE IN *VARBUF* IF PRESENT.
*
* ON ENTRY -- *WORDPT* SET
*
* ON EXIT -- X2 = NEXT CHARACTER (0 IF E-O-L)
* X3 = 0 IF NO ARGUMENT COMPILED
*
* USES -- PRETTY MUCH EVERYTHING
*
GETBARG EQ *
SX3 0 SET TO NO ARGUMENT COMPILED
SA1 WORDPT X1 = POINTER TO NEXT CHARACTER
GBA1 SA2 X1 X2 = NEXT CHARACTER
ZR X2,GETBARG DONE IF E-O-L
SX0 X2-1R IGNORE LEADING SPACES
NZ X0,GBA2
SX1 X1+1 MOVE PAST SPACE
EQ GBA1 AND CONTINUE
*
GBA2 SA3 X2+KEYTYPE
SX0 X3-OPCOMMA CHECK FOR COMMA
NZ X0,GBA3 COMPILE IT IF SOMETHING ELSE
*
SX6 X1+1 COMMA FOUND -- BLANK EXPRESSION
SA6 A1 UPDATE *WORDPT*
MX3 0 FLAG NO EXPRESSION FOUND
EQ GETBARG -- EXIT
*
GBA3 CALL VARDO2 GET CODE FOR NEXT VARIABLE
SA1 WORDPT
SA2 X1 SET TO NEXT CHARACTER
SX3 1 FLAG EXPRESSION COMPILED
EQ GETBARG -- EXIT
*
* /--- BLOCK -CTIME- 00 000 80/10/01 03.05
TITLE -CTIME- COMMAND READIN
* CONDENSE ROUTINE FOR -CTIME- (CODE = 180)
* 1ST ARGS ARE INPUT PARAMETERS (UP TO 3)
* 2ND ARG IS OUTPUT WORD TO HOLD RESULTS
* 3RD ARG IS FORMAT FOR TRANSLATION (OPTIONAL)
* 12=12 HOUR FORMAT
* 24=24 HOUR FORMAT
***
* THE FIRST GETVAR CODE CONTAINS NUMBER OF
* INPUT PARAMETERS
CTIMEIN SX6 1
SA6 VARBUF SET UP DUMMY FIRST ARGUMENT
CALL VARDO2 GET FIRST REAL ARGUMENT
CTIMES SA1 LASTKEY
SX1 X1-KSEMIC (KSEMIC) = SEMI-COLON
ZR X1,STORETC END OF INPUT PARAMS
CALL VARDO2
SA2 VARBUF GET NUMBER OF TAGS
SX2 X2-5 POSITIVE IF X2 .GT. MAX INPUT
NG X2,CTIMES IS - IF MORE TAGS TO FETCH
EQ ERR2MNY MAXIMUM OF 3 TAGS FOR INPUT
STORETC SA3 VARBUF X3 = NUMBER TAGS SO FAR
SX6 X3-1 DO NOT COUNT DUMMY ARGS
SA6 VARBUF+1 SAVE NO. INPUT ARGS AS 1ST ARG
CALL VARDO2
NG X6,ERRSTOR NOT STOREABLE
SA1 VARBUF+1 GET NUMBER OF INPUT TAGS
SX1 X1-1
NZ X1,CTNEXT MORE THEN ONE TAG
*
SA1 VARBUF+2 GET FIRST FLOATING POINT
MX6 61-XCODEL+XFBIT
BX6 -X6*X1 GET RID OF FLOATING POINT BIT
SA6 A1 REWRITE WORD WITHOUT F BIT
CTNEXT SA1 LASTKEY
ZR X1,MRKLAST IF NO FORMAT TAG EXIT
SX1 X1-KSEMIC
NZ X1,ERR2MNY ONLY SEMI COLONS
CALL VARDO2
SA1 LASTKEY
ZR X1,MRKLAST THIS IS LAST LEGAL TAG
EQ ERR2MNY TOO MANY TAGS
*
TITLE -COLOR- COMMAND READIN
*
* -COLOR- COMMAND (NUMBER 158)
*
* COLOR DEFINE;(VAR),REDVAL,GREENVAL,BLUEVAL
*
* READS IN THE VALUES SPECIFIED FOR
* COLOR INTENSITIES IN THE RANGE 0..1,
* CONVERTS THEM TO A 24-BIT INTEGER,
* AND STORES THE RESULT IN THE SPECIFIED
* VARIABLE.
*
* COLOR DISPLAY;FOREGND,BACKGND
* COLOR DISPLAY;FOREGND
* COLOR DISPLAY;,BACKGND
*
* TAKES THE 24-BIT COLOR VALUE(S)
* SPECIFIED FOR FOREGROUND AND BACKGROUND
* COLOR(S) AND SENDS THE INFORMATION TO
* THE TERMINAL.
*
* COMMAND WORD FORMAT';
* 20/GETVAR,20/GETVAR,11/EXSTO ADDR,9/COMMAND NUMBER
*
* THE FIRST GETVAR CODE IS THE COMMAND EXECUTION
* ROUTINE NUMBER --
* 0 = -COLOR DEFINE-
* 1 = -COLOR DISPLAY-
*
* /--- BLOCK -CTIME- 00 000 80/10/01 03.05
* IF THE COMMAND IS -COLOR DISPLAY-, THE SECOND
* GETVAR CODE IS THE FOREGROUND COLOR AND THE
* THIRD GETVAR CODE (FIRST IN EXTRA STORAGE) IS
* THE BACKGROUND COLOR. SINCE EITHER (BUT NOT
* BOTH) MAY BE OMITTED, AN OMITTED COLOR IS
* SIGNALLED BY THE GETVAR CODE 200 000B.
*
EJECT
COLORIN BSS 0
*
* PROCESS FIRST TAG -- TYPE OF -COLOR- REQUEST
*
RJ NXTNAM X6 = TAG, X1 = DELIMITER CHAR
ZR X6,ERR2FEW -> NOT ENOUGH TAGS
BX7 X1 SAVE DELIMITER
SX2 X1-KSEMIC SEE IF DELIMITER = SEMICOLON
SA7 LASTKEY SAVE DELIMITER
NZ X2,ERRTERM -> BAD DELIMITER CHARACTER
SB1 1 B1 = CONSTANT 1
SA2 KCDEF START OF KEYWORDS
TAGCHEK ZR X2,ERRNAME -> KEYWORD NOT FOUND
BX3 X2-X6 CHECK KEYWORD
SA2 A2+B1 X2 = NEXT KEYWORD IN LIST
NZ X3,TAGCHEK -> NOT A MATCH
SB1 A2-KCDEF-1 B1 = JUMP TABLE INDEX
SX6 B1 X6 = COMMAND TYPE
SA6 VARBUF+1
SX6 1 ONE ENTRY IN VARBUF
SA6 VARBUF
+ JP B1+*+1
+ EQ CDEFINE -> PROCESS DEFINE KEYWORD
+ EQ CDISPLY -> PROCESS DISPLAY KEYWORD
KCDEF DATA 0LDEFINE
DATA 0LDISPLAY
DATA 0 MUST END IN 0 WORD
KCOMMA EQU 56B COMMA CHARACTER
EJECT
*
* PROCESS DEFINE KEYWORD
*
CDEFINE BSS 0
RJ CARGS GET ARGUMENTS
SA1 VARBUF MUST BE 4 ARGUMENTS + KEYWORD
SX1 X1-5
NG X1,ERR2FEW -> NOT ENOUGH TAGS
NZ X1,ERR2MNY -> TOO MANY TAGS
SA1 VARBUF+2 X1 = VAR TAG GETVAR CODE
NG X1,ERRSTOR -> MUST BE STOREABLE
SA1 VARBUF+3 X1 = RED TAG GETVAR CODE
RJ CHKVALU CHECK VALIDITY
SA1 VARBUF+4 X1 = GREEN TAG GETVAR CODE
RJ CHKVALU CHECK VALIDITY
SA1 VARBUF+5 X1 = BLUE TAG GETVAR CODE
RJ CHKVALU CHECK VALIDITY
EQ CEND -> ALL OK; FINISH COMMAND
*
* PROCESS DISPLAY KEYWORD
*
CDISPLY BSS 0
MX6 1 PRESTORE BOTH ARGS OMITTED
LX6 XCODEL
SA6 VARBUF+2
SA6 VARBUF+3
RJ GETBARG GET FOREGROUND ARG
ZR X2,CDISP1 -> ONLY ONE ARGUMENT
NZ X3,CDISP0 -> CHECK BGND IF FGND COMPILED
SA1 VARBUF ELSE INCREMENT *VARBUF* OVER
SX6 X1+1 OMITTED FGND ARGUMENT
SA6 VARBUF
CDISP0 BSS 0
RJ GETBARG GET BACKGROUND ARG
CDISP1 BSS 0
* /--- BLOCK -CTIME- 00 000 80/10/01 03.05
SA1 VARBUF CHECK FOR .LT. 4 ARGS
SX1 X1-4
PL X1,ERR2MNY -> TOO MANY ARGUMENTS
SX6 3 SET TO EXACTLY 3 ARGS
SA6 VARBUF
SA1 VARBUF+2 CHECK FOR BOTH ARGS OMITTED
SA2 VARBUF+3
MX0 1
LX0 XCODEL X0 = OMITTED ARG MASK
BX1 X0*X1 X1 .NZ. IF OMITTED
BX2 X0*X2 X2 .NZ. IF OMITTED
BX2 X1*X2 X2 .NZ. IF BOTH OMITTED
NZ X2,ERR2FEW -> ERROR IF BOTH OMITTED
CEND SA1 VARBUF X1 = NUMBE OF VARBUF ENTRIES
EQ VARFIN -> BUILD COMMAND WORD
*
* CARGS -- GET ALL THE TAGS IN THE COMMAND.
* IF A TAG IS OMITTED, INSERT A GETVAR CODE
* OF 200 000B.
*
CARGS EQ *
CGET RJ GETBARG GET NEXT TAG
NZ X3,CGET -> NOT OMITTED, GET NEXT
ZR X2,CARGS -> EOL; EXIT
MX6 1
LX6 XCODEL X6 = OMITTED TAG CODE
SA1 VARBUF X1 = CURRENT ENTRIES COUNT
SX1 X1+1 INCREMENT COUNT
SA6 VARBUF+X1 STORE OMITTED ARG
BX6 X1
SA6 VARBUF STORE NEW COUNT
EQ CGET GET NEXT TAG
*
* CHKVALU -- MAKE SURE CONSTANT IS IN
* RANGE 0..1.
*
* ENTER'; X1 = GETVAR CODE FROM *VARBUF*
*
CHKVALU EQ *
PL X1,CHKVALU -> STOREABLE; NO TEST
MX0 1
LX0 XCODEL X0 = OMITTED TAG CODE
BX2 X0*X1 X2 .NZ. IF OMITTED
MX0 60-XCODEAL X0 = ADDRESS MASK
NZ X2,ERRTAGS -> ERROR IN TAGS COUNT
BX6 -X0*X1 X6 = SHORT LIT OR ADDRESS
BX2 X1 SAVE ORIGINAL GETVAR CODE IN X1
AX2 XCODEAL MOVE TYPE CODE TO LOW ORDER
BX0 -X0*X2 X0 = TYPE CODE (0 OR 1)
SX0 X0-1 0 = SHORT LIT, 1 = LONG LIT
PL X0,CHKLONG -> CHECK LONG LIT
PX1 X6 ELSE FLOAT SHORT LIT
NX1 X1
EQ CHKRANGE -> CHECK RANGE
CHKLONG BSS 0
SA1 INFO+X6 GET LONG LIT FROM *INFO*
CHKRANGE BSS 0
SA2 ONEP0 X2 = 1.0
NG X1,COLROOR -> COLOR NEGATIVE
FX2 X2-X1 X2 <= 1.0 - COLOR
PL X2,CHKVALU -> COLOR OK; EXIT
COLROOR BSS 0 CONDENSE ERROR IF OOR
SB1 500 B1 = CONDENSE ERROR NUMBER
EQ =XERR -> GENERATE CONDENSE ERROR
ONEP0 DATA 1.0 CONSTANT 1.0
*
* /--- BLOCK ENDOV 00 000 79/01/05 02.22
*
ENDOV ENDOV
*
*
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
TSLINKC SPACE 4,10
TITLE -TSLINK- COMMAND READIN
** COMMAND READIN FROM -TSLINK-
*
* 1ST ARG IS KEYWORD
* 2ND - 4TH ARG EXTRA TAGS (ALL OPTIONAL)
*
* TSLINK LOGIN;MAINFRAME,PASSWORD
* TSLINK RECOVER
* TSLINK COMMAND;S,X;WORDS
* TSLINK SEND;S,X;WORDS
* TSLINK RECEIVE;S,X;MAX ALLOWED;WORDS RETURNED
* TSLINK STATUS;WORD
* TSLINK MESSAGE;MESSAGE
* TSLINK CONTINUE
* TSLINK STOP
* TSLINK CSET;VALUE
* TSLINK LOGOUT
* TSLINK NOLOG
*
TSLINKC OVRLAY
.TSL IFEQ 0,1
* FOR NOW -TSLINK- CAN BE USED IN NORMAL LESSONS
* ON THE SYSTEMS SPECIFIED BELOW, AND IN SYSTEM
* LESSONS ON ANY SYSTEM.
SA1 CSYSNAM (X1) = THIS SYSTEMS ROUTING ID
SA2 MNE
BX2 X1-X2
ZR X2,TSOK IF MINNE
SA2 PCA
BX2 X1-X2
ZR X2,TSOK IF PCA
SA2 PEA
BX2 X1-X2
ZR X2,TSOK IF PEA
SA2 PWA
BX2 X1-X2
ZR X2,TSOK IF PWA
SA2 S1
BX2 X1-X2
ZR X2,TSOK IF S1
CALL SYSTEST ELSE MUST BE SYSTEM LESSON
TSOK BSS 0
CALL NXTNAM
BX7 X1
SA7 LASTKEY
* IDENTIFY KEYWORD
SB2 B0
TLOOP SA2 TSTABLE+B2 FETCH TABLE ENTRY
ZR X2,ERRNAME KEYWORD NOT IN TABLE
IX3 X6-X2
ZR X3,FOUND =0 IF EXACT MATCH
SB2 B2+1 INCREMENT LOOP POINTER
EQ TLOOP
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
* FOUND SO FETCH DESCRIPTOR WORD
FOUND SA2 TSDES+B2
SX6 B2 KEYWORD NUMBER
SA6 VARBUF+1
SX6 1
SA6 VARBUF COUNT OF TAGS
MX0 3 TAG DESCRIPTORS ARE 3 BITS
BX3 X0*X2 (X3) = SYSTEM LESSON FLAG
LX2 6 PUT 1ST TAG BITS IN BITS 2-0
BX6 X2
SA6 XTEMP
ZR X3,FOUND.1 IF ALLOWED IN USER LESSONS
CALL SYSTEST
SA2 XTEMP RETRIEVE DESCRIPTOR WORD
FOUND.1 MX0 -3
BX3 -X0*X2
* PROCESS DESCRIPTOR
DLOOP ZR X3,LASTCHK CHECK IF END OF INPUT
SA1 LASTKEY
ZR X1,ERR2FEW IF NO MORE CHARS
SA4 STORCO3 1R; IS ONLY LEGAL SEPERATOR
IX1 X1-X4
NZ X1,ERRTERM IF NOT ;
SX3 X3-1
NZ X3,NREAD (1) = READABLE
CALL VARDO2
EQ STORE
NREAD SX3 X3-1
NZ X3,NWRITE (2) = STOREABLE
CALL VARDO2
SA1 VARBUF GET CURRENT NUMBER OF TAG
SA1 VARBUF+X1 FETCH ENTRY
NG X1,=XERRSTOR TEST IF STOREABLE
EQ STORE
NWRITE BSS 0
CALL NXTNAM GET NEXT LITERAL
BX7 X1
SA7 LASTKEY
SA2 STORCON
IX4 X6-X2
SB1 155 BAD STORAGE LOCATION
ZR X4,NWRITEY IS S, FORM
SA2 STORCO4 NOW TRY STORAGE,
IX4 X6-X2
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
ZR X4,NWRITEY IS STORAGE FORM SO CONTINUE
EQ ERR
NWRITEY SA2 STORCO2
IX6 X1-X2
NZ X6,ERR IF NOT 2R
SA1 LASTKEY
ZR X1,ERR2FEW IF NO MORE CHARS
CALL VARDO2
STORE SA2 XTEMP
LX2 3
MX0 3
LX0 3
BX3 X2*X0
BX6 X2
SA6 XTEMP
EQ DLOOP
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
LASTCHK SA3 LASTKEY
NZ X3,ERR2MNY TOO MANY TAGS
EQ MRKLAST MARK AS LAST FLAG
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
STORCON CON 1LS
STORCO2 CON 1R,
STORCO3 CON 1R;
STORCO4 CON 0LSTORAGE
XTEMP BSSZ 1
*
* TO ADD A KEYWORD';
*
* ADD THE LITERAL STRING TO THE *KEYWORD* TABLE AND
* ADD THE DESCRIPTOR WORD TO THE *PROCESS WORD*
* TABLE. (MATCHING THE OFFSET INTO EACH)
* THE END OF TABLE IS LOCATED BY THE LAST ENTRY = 0
*
* KEYWORD TABLE
TSTABLE DATA 0LLOGIN
DATA 0LRECOVER
DATA 0LCOMMAND
DATA 0LSEND
DATA 0LRECEIVE
DATA 0LSTATUS
DATA 0LCONTINUE
DATA 0LSTOP
DATA 0LCSET
DATA 0LLOGOUT
DATA 0LNOLOG
DATA 0LMESSAGE
DATA 0 END OF TABLE
* DESCRIPTOR WORD TABLE
*
* THE FORMAT OF EACH WORD IS
* EACH COMMAND MUST HAVE SEMI-COLONS FOR EACH
* TAG DIVISOR, EXCEPT FOR THE STORAGE, FORMAT
* WHICH HAS A COMMA AFTER THE S OR STORAGE
* 3/0, = NON-SYSTEM KEYWORD
* 3/1, = SYSTEM LESSON ONLY KEYWORD
* THE FOLLOWING 3 BIT FIELDS DESCRIBE THE
* FORMAT OF THE USERS TAG
* 0 = END OF TAGS
* 1 = READABLE USER VARIABLE (I.E. WHERE)
* 2 = STORABLE USER VARIABLE (I.E. N1)
* 3 = STORAGE DEFINITION
* THIS MEANS S, OR STORAGE,
TSDES VFD 3/0,3/1,3/1,3/0,48/0
VFD 3/0,3/0,3/0,3/0,48/0
VFD 3/0,3/3,3/1,3/0,48/0
VFD 3/0,3/3,3/1,3/0,48/0
VFD 3/0,3/3,3/1,3/2,48/0
VFD 3/0,3/2,3/0,3/0,48/0
VFD 3/0,3/0,3/0,3/0,48/0
VFD 3/0,3/0,3/0,3/0,48/0
VFD 3/0,3/1,3/0,3/0,48/0
VFD 3/0,3/0,3/0,3/0,48/0
VFD 3/0,3/0,3/0,3/0,48/0
VFD 3/0,3/2,3/0,3/0,48/0
VFD 60/0
* SYSTEM NAMES FOR WHICH -TSLINK- IS ALLOWED
MNE DATA 0LMNE
PCA DATA 0LPCA
PEA DATA 0LPEA
PWA DATA 0LPWA
S1 DATA 0LA02
.TSL ELSE
SB1 73 BAD COMMAND NAME
EQ =XERR
.TSL ENDIF
ENDOV
IPCC TITLE -IPC- / -CHARCNV- COMMAND READ IN
** COMMAND READIN FOR -IPC- / -CHARCNV-
*
* IPC CONNECT
* IPC DISCONNECT
* IPC SEND,MESSAGE,LENGTH,ID,ADDRESS
* IPC GET,MESSAGE,LENGTH,ID,ADDRESS
* IPC STATUS,NUMBER,INMSG,OUTMSG
* IPC RESET
*
* CHARCNV PLATO,BUF1,LEN1,BUF2,LEN2,LEN3
* CHARCNV ASCII,BUF1,LEN1,BUF2,LEN2,LEN3
*
* LEN1 = SOURCE BUFFER LENGTH IN SOURCE CHARACTERS
* LEN2 = MAXIMUM DESTINATION BUFFER LENGTH IN WORDS
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
* LEN3 = DESTINATION BUFFER LENGTH IN CHARACTERS
SPACE 5,11
IPCC OVRLAY
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
CALL SYSTEST VERIFY A SYSTEM LESSON
* DETERMINE IPC KEYWORD
CALL NXTNAM
BX7 X1
SA7 LASTKEY
SB2 B0
SA2 IPCCA -IPC- KEYWORD TABLE
SA1 OVARG1
ZR X1,IPCC1 IF IPC COMMAND
SA2 IPCCB -CHARCNV- KEYWORD TABLE
IPCC1 ZR X2,ERRNAME IF KEYWORD NOT FOUND
IX3 X6-X2
ZR X3,IPCC2 IF KEYWORD FOUND
SB2 B2+1
SA2 A2+2
EQ IPCC1 CHECK NEXT ENTRY
IPCC2 SX6 1 COUNT TAGS IN VARBUF
SA6 VARBUF
SX6 B2
SA6 VARBUF+1 SET IPC COMMAND TYPE
SA2 A2+1 (X2) = COMMAND DESCRIPTOR
MX0 -6
LX2 6
BX6 X2
SA6 IPCCC SAVE DESCRIPTOR WORD
BX6 -X0*X2
SA6 IPCCD SAVE ARGUMENT COUNT
* PROCESS ARGUMENTS
IPC3 SA1 IPCCD
NZ X1,IPC4 IF MORE ARGUMENTS
SA1 LASTKEY VERIFY NOT TOO MANY ARGUMENTS
NZ X1,ERR2MNY IF MORE ARGUMENTS
EQ MRKLAST PACK COMMAND ARGUMENTS
IPC4 SX6 X1-1 DECREMENT ARGUMENTS LEFT
SA6 A1
SA1 IPCCC
MX0 -6
LX1 6
BX6 X1
SA6 A1 SAVE DESCRIPTOR WORD
BX1 -X0*X1
SA2 LASTKEY
ZR X2,ERR2FEW IF NO MORE ARGUMENTS
SX2 X2-1R,
NZ X2,ERRTERM IF NO A COMMA SEPARATOR
ZR X1,IPC5 IF READ-ONLY ARGUMENT OKAY
* PROCESS STOREABLE ARGUMENTS
CALL VARDO2
SA1 VARBUF
SA1 VARBUF+X1 (X1) = LAST ARGUMENT
NG X1,ERRSTOR IF NOT STORABLE
EQ IPC3 PROCESS NEXT ARGUMENT
* PROCESS READ-ONLY ARGUMENTS
IPC5 CALL VARDO2
EQ IPC3
* IPC KEYWORD / ARGUMENT TABLE
*
* 6/ARGUMENT COUNT
* 6/0 - READ-ONLY, 1 - STORABLE
IPCCA DATA 0LCONNECT
VFD 6/0,54/0
DATA 0LDISCONNECT
VFD 6/0,54/0
DATA 0LSEND
VFD 6/4,6/1,6/0,6/0,6/0,30/0
DATA 0LGET
VFD 6/4,6/1,6/1,6/1,6/1,30/0
DATA 0LSTATUS
VFD 6/3,6/1,6/1,6/1,36/0
DATA 0LRESET
VFD 6/0,54/0
DATA 0
IPCCB DATA 0LPLATO
VFD 6/5,6/1,6/0,6/1,6/0,6/1,24/0
DATA 0LASCII
VFD 6/5,6/1,6/0,6/1,6/0,6/1,24/0
DATA 0
* /--- BLOCK TSLINKC 00 000 80/08/28 09.33
IPCCC DATA 0 DESCRIPTOR WORD
IPCCD DATA 0 ARGUMENT COUNT
ENDOV
* /--- BLOCK NSETOV 00 000 79/02/04 15.42
TITLE NAMESET COMMAND READINS
*
*
NSETOV OVRLAY
*
SA1 OVARG1 GET OVARLAY ARGUMENT
SB1 X1
JP B1+*+1 JUMP TO ROUTINE FOR COMMAND
*
+ EQ SETNAMC 0 = -SETNAME- COMMAND
+ EQ GETNAMC 1 = -GETNAME- COMMAND
+ EQ RENAMEC 2 = -RENAME- COMMAND
+ EQ ADDNAMC 3 = -ADDNAME- COMMAND
+ EQ NAMESC 4 = -NAMES- COMMAND
+ EQ DELRECC 5 = -DELRECS- COMMAND
+ EQ ADDRECC 6 = -ADDRECS- COMMAND
* /--- BLOCK SETNAME 00 000 79/02/04 15.35
*
* SETNAME HAS THE FOLLOWING FORMS --
*
* -SETNAME <VAR>- VAR CONTAINS FIRST WORD OF NAME
* -SETNAME NEXTNAME- SET TO NEXT NAME IN SEQUENCE
* -SETNAME BACKNAME- SET TO PREVIOUS NAME IN SEQ.
* -SETNAME (BLANK)- INDICATE NO NAME SELECTED
*
SETNAMC CALL NXTNAMP GET NEXT TAG IN X6
* X6 = TAG, WORDPT NOT UPDATED IN CASE TAG NOT -NEXTNAME-
SX7 1 1 = NEXTNAME TAG
SA1 NEXTNAME X1 = 8LNEXTNAME
BX1 X6-X1
ZR X1,SETNAM2 --- IF SO, SET TYPE CODE
SX7 2 2 = BACKNAME TAG
SA1 BACKNAME X1 = 8LBACKNAME
BX1 X6-X1
ZR X1,SETNAM2 --- IF SO, SET TYPE CODE
SX7 3 3 = BLANK TAG
SA1 TAGCNT GET NUMBER OF TAGS
ZR X1,SETNAM2 --- IF NONE, SET TYPE CODE
CALL VARDO1 GET ARGUMENT
SA1 VARBUF+1 GET FIRST GETVAR CODE
PL X1,SETNAM1 --- JUMP IF STOREABLE ADDRESS
MX0 -XCODEL MASK FOR GETVAR CODE
BX1 -X0*X1 MASK OFF STORABILITY FLAG
MX6 1
LX6 XCODEL SHIFT TO TOP BIT OF GETVAR
BX1 X6+X1 INSERT TOP BIT = NOT STORABLE
*
SETNAM1 BX6 X1 0 = NAME SPECIFIED
LX6 -2*XCODEL SHIFT TO SECOND 20 BITS
SA2 LASTKEY
NZ X2,ERR2MNY ONLY ALLOW ONE ARGUMENT
EQ PUTCODE
*
SETNAM2 BX6 X7
LX6 -XCODEL SHIFT TO TOP 20 BITS
EQ PUTCODE
*
NEXTNAME DATA 8LNEXTNAME
BACKNAME DATA 8LBACKNAME
* /--- BLOCK GETNAME 00 000 79/02/04 15.35
*
*
* GETNAME HAS ONE OR TWO ARGUMENTS --
* 1ST = STARTING VARIABLE IN WHICH TO STORE NAME
* 2ND = (OPTIONAL) LOCATION TO STORE EXTRA INFO
*
GETNAMC CALL VARDO GET ARGUMENTS
SA1 VARBUF CHECK NUMBER OF TAGS
SX2 X1-3
PL X2,ERR2MNY --- ERROR IF TOO MANY TAGS
SA2 VARBUF+1 CHECK IF STORABLE
NG X2,ERRSTOR --- 1ST ARG MUST BE STORABLE
SX2 X1-2 CHECK IF TWO ARGUMENTS
NG X2,MRKLAST --- PACK UP SINGLE ARGUMENT
SA2 VARBUF+2 CHECK IF STORABLE
NG X2,ERRSTOR --- 2ND ARG MUST BE STORABLE
EQ MRKLAST EXIT TO PACK UP TAGS
*
*
*
* RENAME HAS ONE OR TWO ARGUMENTS --
* 1ST = STARTING VARIABLE IN WHICH TO STORE NAME
* 2ND = (OPTIONAL) LOCATION OF NEW EXTRA INFO
*
RENAMEC CALL VARDO OBTAIN ARGUMENTS
SA1 VARBUF CHECK NUMBER OF TAGS
SX2 X1-3
NG X2,RENAME1 OK IF .LE. 2 ARGS
SA2 SYSFLG (X2) = SYSTEM LESSON FLAGS
LX2 ZSLDSHF POSITION SYSTEM COMMAND FLAG
PL X2,ERR2MNY --- ERROR IF NOT SYSTEM LESSON
SX2 X1-4 3 ARGS IS OK FOR SYSTEM LESSON
PL X2,ERR2MNY --- ERROR IF .GT. 3 ARGS
RENAME1 SA2 VARBUF+1 (X2) = FIRST ARG
NG X2,ERRSTOR --- 1ST ARG MUST BE STORABLE
EQ MRKLAST EXIT TO PACK UP TAGS
* /--- BLOCK ADDNAME 00 000 79/09/11 03.13
*
* ADDNAME HAS UP TO THREE ARGUMENTS--
* 1ST = STARTING VARIABLE CONTAINING NAME
* 2ND = NUMBER OF RECORDS (OPTIONAL)
* 3RD = EXTRA INFO (OPTIONAL)
*
ADDNAMC RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF GET NUMBER OF ARGS FOUND
SX2 X1-4
NG X2,ADDNAM1 OK IF .LE. 3 ARGS
SA2 SYSFLG (X2) = SYSTEM LESSON FLAGS
LX2 ZSLDSHF POSITION SYSTEM COMMAND FLAG
PL X2,ERR2MNY --- ERROR IF NOT SYSTEM LESSON
SX2 X1-5 4 ARGS IS OK FOR SYSTEM LESSON
PL X2,ERR2MNY --- ERROR IF .GT. 4 ARGS
ADDNAM1 SA2 VARBUF+1 (X2) = FIRST ARG
NG X2,ERRSTOR --- 1ST ARG MUST BE STOREABLE
EQ MRKLAST FINISH PROCESSING
*
* -NAMES- HAS FOUR ARGUMENTS-
*
* 1ST = ORDINAL NUMBER OF FIRST NAME
* ...OR IT CAN BE OMITTED.
* 2ND = STARTING LOCATION OF USER BUFFER
* 3RD = SIZE OF USER BUFFER IN WORDS
* 4TH = VARIABLE TO RETURN COUNT
*
NAMESC RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF GET NUMBER OF ARGS FOUND
SX2 X1-3 SEE IF 1ST ARG IS TO BE OMITTED
NZ X2,NAMES4 --- BRIF IF NOT 3 ARG CASE
SX6 X1+1 RESET *VARBUF* TO A 4 ARG CASE
SA6 A1
*
SA1 VARBUF+3 ... SHUFFLE OTHER ARGS DOWN
SA2 A1-1
BX7 X1
BX6 X2
SA7 A1+1 VARBUF+4 _ VARBUF+3
SA6 A1 VARBUF+3 _ VARBUF+2
SA1 VARBUF+1
BX6 X1
SA6 A2 VARBUF+2 _ VARBUF+1
MX6 1 NOW MARK FIRST ARGUMENT OMITTED
LX6 XCODEL
SA6 VARBUF+1 STORE AS A DUMMY ARGUMENT
SA1 VARBUF
EQ NAMES2 ... NOW CHECK OTHER ARGUMENTS
*
NAMES4 SX2 X1-4
NZ X2,ERRTAGS --- IS NO GOOD IF NOT 3 OR 4 ARGS
NAMES2 SA2 VARBUF+2
NG X2,ERRSTOR --- 2ND ARG MUST BE STOREABLE
SA2 VARBUF+4
NG X2,ERRSTOR --- 4TH ARG MUST BE STOREABLE
EQ VARFIN FINISH PROCESSING
*
* ADDRECS, DELRECS CAN HAVE 1 OR 2 ARGUMENTS--
* 1ST = NUMBER OF RECORDS TO ADD (AT END)
* OR
* 1ST = RECORD NUMBER THAT NEW RECORDS START AT
* 2ND = NUMBER OF RECORDS
*
DELRECC BSS 0
ADDRECC RJ VARDO GET COMMA SEPARATED VARIABLES
SA1 VARBUF GET NUMBER OF ARGS FOUND
SX2 X1-3
PL X2,ERR2MNY
EQ MRKLAST FINISH PROCESSING
* /--- BLOCK ENDOV 00 000 79/02/04 15.39
*
ENDOV
* /--- BLOCK COVL3B 00 000 81/05/12 15.01
*
COVL3B OVRLAY
SA1 OVARG1
SB1 X1
JP B1+*+1
*
+ EQ SETSYSC 0 = -SETSYS- COMMAND
+ EQ FILNAMC 1 = -FILENAM- COMMAND
+ EQ NVERSC 2 = -NVERS- COMMAND
+ EQ NETIOC 3 = -NETIO- COMMAND
+ EQ ITOAC 4 = -ITOA- COMMAND
+ EQ OTOAIN 5 = -OTOA- -HTOA- COMMANDS
+ EQ DIOC 6 = -DREAD- -DWRITE- COMMANDS
+ EQ DATAIOC 7 = -DATAIN- -DATAOUT- COMMANDS
+ EQ FIOC 8 = -READF- -WRITEF- COMMANDS
+ EQ READIN 9 = -READECS- -READTCM-
+ EQ WREADIN 10 = -WRITECS- -WRITTCM-
+ EQ SBREADC 11 = -SBREAD- -READLES-
+ EQ SBWRITC 12 = -SBWRITE- -WRITLES-
+ EQ SBCHANC 13 = -SBCHANG- -STCHANG-
+ EQ SIZEC 14 = -SIZE-
+ EQ TEXTNIN 15 = TEXTN
+ EQ TRANSIN 16 = TRANSFR
* /--- BLOCK SETSYS 00 000 85/07/29 15.37
TITLE -SETSYS- COMMAND
*
* -SETSYS- HAS THE FOLLOWING FORMS --
*
* SETSYS NEXTSYS,(BUFFER),(LTH)
* SETSYS BACKSYS,(BUFFER),(LTH)
* SETSYS (SYSTEM),(BUFFER),(LTH)[,RID]
*
SETSYSC CALL SYSTEST MUST BE SYSTEM LESSON
*
SA1 TAGCNT
ZR X1,ERR2FEW -- ERROR EXIT
*
CALL NXTNAMP GET FIRST TAG IN X6
* X6 = TAG, B1 = NEXT *WORDPT*, X1 = TERMINATOR CHARACTER
*
MX7 0 0 = NEXTSYS TAG
SA2 NEXTSYS X2 = 7LNEXTSYS
BX2 X6-X2
ZR X2,SETSYS2
*
SX7 1 1 = BACKSYS TAG
SA2 BACKSYS X2 = 7LBACKSYS
BX2 X6-X2
NZ X2,SETSYS3 NOT *NEXTSYS* OR *BACKSYS*
*
SETSYS2 MX6 1 BUILD SPECIAL CODE
LX6 XCODEL
BX6 X6+X7
SX7 B1 UPDATE *WORDPT*
SA6 VARBUF+1
SA7 WORDPT
SX6 1
SA6 VARBUF SHOW ONE ARGUMENT SO FAR
EQ SETSYS4 CONTINUE TO SECOND TAG
*
SETSYS3 CALL VARDO1 GET SYSTEM NAME AS FIRST ARG
SA1 LASTKEY GET DELIMITER
*
SETSYS4 ZR X1,ERR2FEW --- ERROR IF NO BUFFER GIVEN
*
CALL VARDO2 GET BUFFER ADDRESS
NZ B1,ERRSTOR -- ERROR IF NOT STORABLE
SA1 LASTKEY CHECK IF DONE
ZR X1,ERR2FEW -- MUST SPECIFY BUFFER LTH
*
CALL VARDO2 GET BUFFER LENGTH
SA2 LASTKEY CHECK IF MORE ARGS
MX7 0
ZR X2,SETSYS9 -- EXIT IF DONE
*
CALL NXTNAM CHECK FOR RID KEYWORD
NZ X1,ERR2MNY --- ERROR IF MORE ARGS
SA1 RIDTAG
BX1 X1-X6
SX7 1
NZ X1,ERRNAME --- ERROR IF NOT -RID-
SETSYS9 BSS 0
MX6 1
LX6 XCODEL FLAG SPECIAL ARG
BX6 X6+X7
SA6 VARBUF+4
SX1 4 (VARFIN REQUIRES NUM OF TAGS)
BX6 X1
SA6 VARBUF ALSO SET TO 4
EQ VARFIN -- EXIT
*
*
NEXTSYS DATA 7LNEXTSYS
BACKSYS DATA 7LBACKSYS
RIDTAG DATA 3LRID
*
*
* /--- BLOCK FILENAM 00 000 85/07/29 15.34
TITLE -FILENAM- COMMAND
*
* -FILENAM- HAS TWO POSSIBLE FORMS --
*
* FILENAM ACCOUNT';FILE,ONEWORD (FORM 0)
* FILENAM ONEWORD,ACCOUNT';FILE (FORM 1)
*
* THE FIRST GETVAR CODE IS SET UP AS A FAKE ARGUMENT
* TO INDICATE WHICH FORM IS USED.
*
FILNAMC BSS 0
SA1 TAGCNT
ZR X1,ERR2FEW IF BLANK TAG
* LOOK FOR COLON TO DETERMINE WHICH FORM IS USED
CALL COLONCK SEE IF COLON AFTER FIRST ARG
ZR X6,FN10 IF FIRST SEPARATOR IS COLON
SX6 1 SET TO FORM 1
FN10 SA6 VARBUF+1 SET UP FIRST GETVAR CODE
SX6 1
SA6 VARBUF INITIALIZE TO 1 ARGUMENT SO FAR
* COMPILE FIRST REAL ARGUMENT
CALL VARDO2
SA1 LASTKEY CHECK FOR END OF LINE
ZR X1,ERR2FEW IF ONLY ONE ARGUMENT
CALL COLONCK SEE IF NEXT SEPARATOR IS COLON
SA1 VARBUF+1 RETRIEVE COMMAND FORM
ZR X1,FN15 IF FIRST SEPARATOR WAS COLON
ZR X6,FN20 IF SECOND SEPARATOR WAS COLON
EQ ERRTERM IF NO COLON AT ALL
FN15 ZR X6,ERRTERM IF BOTH SEPARATORS ARE COLONS
* COMPILE SECOND ARGUMENT
CALL VARDO2 GENERATE GETVAR CODE
EQ FN30
FN20 CALL PUTDO2 GENERATE PUTVAR CODE
* COMPILE THIRD ARGUMENT
FN30 SA1 LASTKEY CHECK FOR END OF LINE
ZR X1,ERR2FEW IF NO THIRD ARGUMENT
CALL PUTDO2 ALWAYS PUTVAR CODE FOR 3RD ARG
SA1 LASTKEY
NZ X1,ERR2MNY IF MORE THAN 3 ARGUMENTS
SX1 4 NUMBER OF GETVAR CODES ALLOWED
EQ VARFIN
* /--- BLOCK NVERS 00 000 85/07/29 15.34
TITLE -NVERS- COMMAND
*
* -NVERS- COMMAND
*
* NVERS ACCOUNT';FILE,ACCOUNT';FILE
*
* CONVERTS SPECIFIED FILE NAME TO ITS N-VERSION FORM.
*
NVERSC BSS 0
CALL SYSTEST SYSTEM LESSONS ONLY
CALL ACCFILE,VARBUF+1,0 GET FIRST FILE NAME
SA1 LASTKEY
ZR X1,ERR2FEW
CALL COLONCK LOOK FOR COLON IN 2ND NAME
NZ X6,NV20 IF NO COLON
SX6 2
SA6 VARBUF 2 ARGUMENTS SO FAR
CALL VARDO2 VAR FOR ACCOUNT NAME RETURN
NG X6,ERRSTOR IF NOT STOREABLE
NV10 CALL VARDO2 VAR FOR FILE NAME RETURN
NG X6,ERRSTOR IF NOT STOREABLE
SA1 LASTKEY
NZ X1,ERR2MNY IF EXTRA ARGUMENTS
SX1 4 4 ARGUMENTS
EQ VARFIN
NV20 SX6 0 FAKE UP 3RD ARGUMENT
SA6 VARBUF+3
SX6 3
SA6 VARBUF
EQ NV10
* /--- BLOCK NETIO 00 000 79/02/04 23.36
TITLE NETWORK I/O COMMAND - NETIO
*
* -NETIO- (CODE = 107)
*
* NETIO REQUEST,RESPONSE
*
* REQUEST AND RESPONSE MUST BE STOREABLE VAIABLES.
*
NETIOC BSS 0
* ALLOW ONLY SYSTEM LESSONS WITH -NETIO- PERMISSION.
SA1 SYSFLG
LX1 ZSLDSHF
PL X1,ERRORC IF NOT A SYSTEM LESSON
LX1 ZNIOSHF-ZSLDSHF
PL X1,ERRORC IF NO -NETIO- PERMISSION
*
* * * COMPILE PARAMETERS
CALL VARDO
*
* * * CHECK NUMBER OF ARGUEMENTS, MUST BE TWO
SA1 VARBUF VARIABLE COUNT
SX2 X1-2
NG X2,ERR2FEW JUMP IF NOT ENOUGH
NZ X2,ERR2MNY JUMP IF TOO MANY
*
* * * BOTH ARGUEMENTS MUST BE STOREABLE
SA2 VARBUF+1 FIRST VARIABLE
NG X2,ERRSTOR JUMP IF NOT STOREABLE
SA2 VARBUF+2 SECOND VARIABLE
NG X2,ERRSTOR JUMP IF NOT STOREABLE
*
* * * PACK VARBUF VARIABLES (X1=VARIABLE COUNT)
EQ VARFIN
*
*
* /--- BLOCK OTOAIN 00 000 77/02/18 21.40
*
* -ITOA- (CODE=220)
*
* 1ST ENTRY=INTEGER,
* 2ND ENTRY=ALPHA STORAGE LOCATION
* 3RD ENTRY=RETURN ALPHA CHARACTER COUNT
*
ITOAC RJ VARDO ENCODE VARIABLES
SA1 VARBUF X1 = NUMBER OF VARIABLES
SX2 X1-2
NZ X2,ITOAC1 JUMP IF NOT 2 VARIABLES
SA1 VARBUF+1
SA2 VARBUF+2
NG X2,ERRSTOR MUST BE ABLE TO STORE INTO
MX0 -XCODEL
BX1 -X0*X1
BX2 -X0*X2
LX1 60-XCODEL
LX2 60-2*XCODEL
BX6 X1+X2
MX1 1
LX1 60-2*XCODEL
BX6 X6+X1 SET BIT TO FLAG 2 ARGS
EQ PUTCODE --- EXIT TO ADD COMMAND CODE AND STORE
ITOAC1 SX2 X2-1
NZ X2,ERRTAGS --- ERROR EXIT IF NOT 3 VARIABLES
SA2 VARBUF+2
NG X2,ERRSTOR MUST BE ABLE TO STORE INTO ALPHA STORAGE
SA2 VARBUF+3
NG X2,ERRSTOR MUST BE ABLE TO STORE CHAR COUNT
EQ VARFIN --- EXIT TO PACK UP VARIABLES
*
*
TITLE OTOA/HTOA
*
* -OTOA-
* -HTOA-
*
* FIRST ARG IS OCTAL WORD
* 2ND ARG GIVES FWA OF 2 WORD STOREABLE BUFFER
* TO CONTAIN THE 20 CHAR ALPHA STRING.
* OPTIONAL 3RD ARGUMENT IS CHARACTER COUNT
*
* FORCES GETVAR CODE OF 1ST ARG TO INTEGER
* CHECKS TO SEE THAT 2ND ARG IS STOREABLE
*
OTOAIN RJ VARDO
SA1 VARBUF X1= NO. OF ARGS
SX2 X1-2
ZR X2,OKTAGS --- IF 2 ARGS IT IS OK
SX2 X1-3
NZ X2,ERRTAGS --- ERROR IF NOT 2 OR 3 TAGS
OKTAGS SA2 VARBUF+1
MX0 1
LX0 18 2**17 BIT IS I/F FLAG
BX6 -X0*X2 MAKE GETVAR CODE INTEGER
SA6 A2 PUT IT BACK FOR VARFIN
SA2 VARBUF+2
NG X2,ERRSTOR --- ERROR IF 2ND NOT STOREABLE
EQ MRKLAST --- EXIT AND MARK LAST CODE
*
*
* /--- BLOCK DREAD 00 000 79/07/12 04.51
TITLE DREAD, DWRITE
* -DREAD- (CODE=193)
* -DWRITE- (CODE=194)
*
* MAY HAVE 2 OR 3 ARGUMENTS
*
*
DIOC RJ SYSTEST SYSTEM LESSON CHECK
*
DIOC1 SX6 1 SET UP SHORT LITERAL
SA6 VARBUF+3
RJ VARDO DECODE VARIABLES TO *VARBUF*
SA1 VARBUF
SX2 X1-2
ZR X2,DIOC2 OK IF 2 ARGUMENTS
SX2 X1-3
NZ X2,ERRTAGS --- ERROR IF NOT 3 ARGUMENTS
*
DIOC2 MX0 -XCODEL
SA1 VARBUF+1 LOAD 1ST -GETVAR- CODE
BX6 -X0*X1
LX6 60-XCODEL
SA1 VARBUF+2 LOAD 2ND -GETVAR- CODE
BX1 -X0*X1
LX1 60-2*XCODEL
BX6 X1+X6 COMBINE
SA1 VARBUF+3 LOAD 3RD -GETVAR- CODE
BX1 -X0*X1
LX1 60-3*XCODEL
BX6 X6+X1 FINISH UP XSTOR WORD
SA1 INX
SA6 X1+INFO PUT -GETVAR- CODES IN XSTOR
SX6 X1+1
SA6 A1 UPDATE XSTOR POINTER
BX6 X1
LX6 60-18 POSITION XSTOR POINTER
EQ PUTCODE
* /--- BLOCK DATAIOC 00 000 81/04/27 23.28
TITLE DATAIOC
*
*
* CONDENSE ROUTINE FOR -DATAIN- AND -DATAOUT-
* 1ST ARG = BLOCK NUMBER
* 2ND ARG = DATA LOCATION
* 3RD ARG = NUMBER OF RECORDS (OPTIONAL)
*
* DATA LOCATION CAN BE OF FOLLOWING TYPES -
*
* N1 STUDENT BANK (TYPE 0)
* V1 STUDENT BANK (TYPE 0)
* C,1 COMMON (TYPE 1)
* COMMON,1 COMMON (TYPE 1)
* S,1 STORAGE (TYPE 2)
* STORAGE,1 STORAGE (TYPE 2)
* NC1 CM VARIABLES (TYPE 3)
* VC1 CM VARIABLES (TYPE 3)
*
* REFERENCES TO NC/VC VARIABLES (TYPE 3) ARE
* CONDENSED AS N/V VARIABLES (TYPE 0). DURING THE
* BOUNDS CHECKS AT EXECUTION TIME THE NC/VC
* REFERENCES ARE DETECTED AND THE TYPE IS CHANGED.
* THIS IS NECESSARY SINCE REFERENCES LIKE NC(N1)
* ARE CONDENSED WITH COMPILED CODE AND CANNOT BE
* DETECTED EASILY HERE.
*
*
DATAIOC SA1 COMNUM -DATAOUT- IS PUBLISH ERROR
SB1 =XDATOT=
SB2 X1
NE B1,B2,DATIOC0 IF NOT -DATAOUT-
*
SB1 FSDATOT LOG PUBLISH ERROR
RJ =XPUBERRS
DATIOC0 CALL VARDO1 GET BLOCK NUMBER
SA1 LASTKEY GET TERMINATOR
SX1 X1-1R; INSIST ON PROPER SYNTAX
NZ X1,ERRTERM ERROR IF BAD SEPARATOR
SX7 DIO.SV PRESET FOR STUDENT VARIABLES
SA7 VARBUF+2 PRESET TYPE IN 2ND ARG
CALL NXTNAMR GET ANY SYMBOL
SX4 X1-1R, CHECK FOR COMMA
NZ X4,DATIOC3 JUMP IF NOT C,S
SX7 DIO.COM PRESET FOR COMMON
SA2 KCOM
BX2 X3*X2
IX2 X2-X6
ZR X2,DATIOC2 IF COMMON
SX7 DIO.STO PRESET FOR STORAGE
SA2 KSTO
BX2 X3*X2
IX2 X2-X6
NZ X2,DATIOC3 IF NOT STORAGE
DATIOC2 SA7 VARBUF+2 STORE TYPE AS 2ND ARG
SX7 B1 B1 HAS BEEN SAVED TO HERE
SA7 WORDPT
DATIOC3 SX6 2
SA6 VARBUF RESET ARGS TO 2
CALL VARDO2 GET DATA LOCATION
SA2 VARBUF+2 TYPE CODE
NZ X2,DATIOC4 IF NOT STUDENT BANK
NZ B1,ERRSTOR ERROR IF NOT STOREABLE
DATIOC4 SX6 1 CONSTANT 1
SA6 VARBUF+4 PRESET NUMBER OF RECORDS
SA1 LASTKEY GET TERMINATOR
ZR X1,DATIOC5 IF ONLY 2 ARGS
SX1 X1-1R; INSIST ON PROPER SYNTAX
NZ X1,ERRTERM ERROR IF BAD SEPARATOR
CALL VARDO2 GET NUMBER OF RECORDS
SA1 LASTKEY GET FINAL TERMINATOR
* /--- BLOCK DATAIOC 00 000 81/04/27 23.28
NZ X1,ERR2MNY ERROR IF NOT E-O-L
DATIOC5 SX1 4 4 ARGS REQUIRED
BX6 X1
SA6 VARBUF AND GUARANTEED IN ALL CASES
EQ VARFIN
*
KCOM DATA 6LCOMMON
KSTO DATA 7LSTORAGE
*
* /--- BLOCK FIOC 00 000 77/03/10 00.15
EJECT
*
* -READF- (CODE = 450)
* -WRITEF- (CODE = 451)
*
* READF FIP,BLOCK NUMBER,STORAGE ADDRESS,NO. BLOCKS
*
* NO. OF BLOCKS IS AN OPTIONAL PARAMETER WHICH IS
* ASSUMED ONE IF MISSING. FILE INFORMATION
* PACKET(FIP) MUST BE A STOREABLE VARIABLE.
*
FIOC BSS 0
*
* * * MUST BE SYSTEM LESSON
CALL SYSTEST
*
* * * INITIALIZE NO. OF BLOCKS AND NO. OF ARGUMENTS TO 1
SX6 1
SA6 VARBUF+4 PUT IN FOURTH PARAMETER SLOT
SA6 VARBUF NUMBER OF ARGUMENTS
*
* * * EVALUATE THE FIRST ARGUMENT
CALL COMPILE
NZ B1,ERRSTOR ERROR IF NOT STOREABLE
*
* * * PUT GETVAR CODE INTO BUFFER.
BX6 X1
SA6 VARBUF+1
*
* * * COMPILE THE REMAINING ARGUMENTS
FIOC1 BSS 0
SA1 LASTKEY WAS THAT THE LAST ONE
ZR X1,FIOC2 JUMP IF NO MORE
CALL VARDO2 COMPILE NEXT ARGUMENT
EQ FIOC1
*
* * * CHECK FOR CORRECT NUMBER OF ARGUMENTS
FIOC2 BSS 0
SA1 VARBUF ARGUMENT COUNT
SX2 X1-4
ZR X2,FIOC3 JUMP IF 4
SX2 X1-3
NZ X2,ERRTAGS ERROR IF NOT 3 OR 4
*
* * * ONLY THREE ARGUMENTS FORCE TO FOUR
SX1 X1+1
*
* * * SET NUMBER OF VARIABLES AND GO PACK CODES
FIOC3 BSS 0
BX6 X1
SA6 VARBUF
EQ VARFIN
* /--- BLOCK READECS 00 000 79/03/20 20.14
*
TITLE -READECS-
* -READECS- (CODE=182)
* -READTCM- (CODE=248)
*
READIN RJ SYSTEST CHECK IF SYSTEM LESSON
READIN1 RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+1
NG X1,ERRSTOR ERROR IF VARIABLE NOT STOREABLE
SX1 3 MUST BE 3 VARIABLES
EQ VARFIN --- EXIT TO STORE CODE
*
*
* -WRITECS- (CODE=219)
* -WRITTCM- (CODE=250)
*
WREADIN RJ SYSTST1 CHECK IF SPECIAL SYSTEM LESSON
EQ READIN1
*
*
*
* -SBREAD- (CODE=148)
* -READLES-
*
SBREADC RJ SYSTEST CHECK IF SYSTEM LESSON
SBREAD1 RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+3
NG X1,ERRSTOR 3RD ARG MUST BE STORABLE
SX1 4 MUST BE 4 VARIABLES
EQ VARFIN --- EXIT TO STORE CODE
*
* -SBWRITE- (CODE=149)
* -WRITLES-
*
SBWRITC RJ SYSTST1 CHECK IF SPECIAL SYSTEM LESSON
EQ SBREAD1
* -SBCHANG- (CODE = 314)
* -STCHANG- (CODE = 315)
SBCHANC RJ SYSTST1 CHECK IF SPECIAL SYSTEM LESSON
RJ VARDO PROCESS COMMA-SEPARATED ARGS
SX1 4 THERE MUST BE 4 ARGUMENTS
EQ VARFIN PACK UP GETVAR CODES AND EXIT
TITLE -SIZE- COMMAND.
** SIZEC - SIZE COMMAND CONDENSE ROUTINE.
*
* COMMAND SYNTAX -
* SIZE <BLANK>
* SIZE 2
* SIZE 2,1.5
* SIZE BOLD
* CHECK FOR -BOLD- KEYWORD. IF NOT BOLD, JUMP
* TO STANDARD CONDENSE ROUTINE ',ONE2IN0', TO
* PROCESS ZERO TO TWO ARGUMENT COMMANDS.
SIZEC RJ NXTNAMP
SA1 BOLDNAM
BX1 X6-X1
NZ X1,=XONE2IN0 IF NOT -BOLD-
* MAKE SURE THERE ARE NO MORE TAGS.
SX2 X2-EOL
NZ X2,ERR2MNY IF NOT END OF LINE
* SET BIT 58 TO INDICATE THAT THIS IS A -SIZE BOLD-.
MX6 1
LX6 58-59+60
EQ PUTCODE
BOLDNAM DATA 4LBOLD
* /--- BLOCK TEXTN 00 000 83/06/13 11.57
TITLE TEXTN COMMAND READIN
*
* ALLOWS 4 OR 5 OR 6 OR 7 ARGUMENTS WITH LAST
* ARGUMENT MARKED WITH SIGN BIT SET.
* FIRST AND SECOND ARGUMENTS MUST BE STOREABLE.
*
*
TEXTNIN RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+1 FIRST GETVAR WORD
NG X1,ERRSTOR MUST BE STOREABLE
SA1 VARBUF+2 SECOND GETVAR WORD
NG X1,ERRSTOR MUST BE STOREABLE
SA1 VARBUF X1= NO. OF ARGS
SX2 X1-4
ZR X2,MRKLAST --- IF 4 ARGS IT IS OK
SX2 X1-5
ZR X2,MRKLAST --- IF 5 ARGS IT IS OK
SX2 X1-6
ZR X2,MRKLAST --- IF 6 ARGS IT IS OK
SX2 X1-7
ZR X2,MRKLAST --- IF 7 ARGS IT IS OK
EQ ERRTAGS --- EXIT TO CONDENSE ERROR
*
* /--- BLOCK TRANSFR 00 000 79/07/12 05.23
TITLE -TRANSFR-
*
*
*
* -TRANSFR- COMMAND READIN
*
TRANSIN SX6 2
SA6 VARBUF SET ARGS TO 2
MX6 0
SA6 VARBUF+2 CLEAR TRANSFER TYPE TO 0
CALL NXTNAMR GET FIRST SYMBOL
ZR X1,SYNERR CHECK FOR PREMATURE EOL
SX4 X1-1R, CHECK FOR COMMA
NZ X4,TRANSFR GO GET -FROM- IF NOT C,S
SB3 1 SET TYPE
SA2 KCOM
BX2 X3*X2
IX2 X2-X6
ZR X2,TRANSFC COMMON
SB3 B3+B3
SA2 KSTO
BX2 X3*X2
IX2 X2-X6
ZR X2,TRANSFC STORAGE
SB3 B3+1
SA2 KROUT
BX2 X3*X2
IX2 X2-X6
ZR X2,TFCR JUMP IF -ROUTER-
SB3 B3+1
SA2 KROUTV
BX2 X3*X2
IX2 X2-X6
NZ X2,TRANSFR NOT -ROUTVARS-
*
* /--- BLOCK TRANSFR 00 000 79/07/12 05.07
*
TFCR SA2 ROUTER
NZ X2,ERROUTR ERROR IF THIS IS A ROUTER
*
TRANSFC SX7 B3 PICK UP FLAG
SA7 VARBUF+2 STORE IN SECOND ARGUMENT
SX7 B1 B1 HAS BEEN SAVED TO HERE
SA7 WORDPT
*
*
TRANSFR CALL VARDO2 GET -FROM- VARIABLE
SA1 LASTKEY GET TERMINATOR
SX1 X1-1R; FORCE SYNTAX
NZ X1,ERRTERM TO BE CLEAR
EQ B1,B0,TRANST OK IF STOREABLE
SA3 VARBUF+2 GET TYPE OF TRANSFER
ZR X3,ERRSTOR ERROR IF -CM FROM- NOT A USER
* ARRAY ADDRESS
*
TRANST CALL NXTNAMR SCAN FOR NEXT TERMINATOR
ZR X1,SYNERR CHECK FOR PREMATURE EOL
SX4 X1-1R, CHECK FOR COMMA
NZ X4,TRANSTO GO GET -TO- IF NOT C,S
SB3 1 SET TYPE
SA2 KCOM
BX2 X3*X2
IX2 X2-X6
ZR X2,TRANSTC COMMON
SB3 B3+B3
SA2 KSTO
BX2 X3*X2
IX2 X2-X6
ZR X2,TRANSTC STORAGE
SB3 B3+1
SA2 KROUT
BX2 X3*X2
IX2 X2-X6
NZ X2,TRANSTO NOT ROUTER
SA2 ROUTER
NZ X2,ERROUTR ERROR IF THIS IS A ROUTER
*
* /--- BLOCK TRANSFR 00 000 79/07/12 05.08
*
TRANSTC SX7 B3 PICK UP TYPE
SA3 VARBUF+2
LX7 3 MOVE -TO- TYPE INTO PLACE
IX7 X7+X3 ADD IT IN
SA7 A3 RE-STORE
SX7 B1 B1 HAS BEEN PRESERVED
SA7 WORDPT
*
TRANSTO RJ VARDO2 GET -TO- ARGUMENT
SA1 LASTKEY GET TERMINATOR
SX1 X1-1R; FORCE SYNTAX
NZ X1,ERRTERM TO BE CLEAR
EQ B1,B0,TRANSL OK IF STOREABLE
SA3 VARBUF+2 GET TRANSFER TYPE
AX3 3 OF -TO- ARG
ZR X3,ERRSTOR ERROR IF -CM TO- ADDRESS NOT
* STOREABLE
*
TRANSL RJ VARDO2 GET -LENGTH-
SA1 LASTKEY CHECK FINAL TERMINATOR
NZ X1,ERR2MNY
SA1 VARBUF+5 PICK UP LENGTH
BX6 X1
SA6 VARBUF+1 MOVE INTO SAVED SLOT
SX1 4 HAVE 4 ARGUMENTS (SURE)
BX6 X1
SA6 VARBUF ENSURE THAT ARG CHECK IS OK
EQ VARFIN GO PACK IT ALL UP
*
SYNERR SX7 B1 UPDATE CHARACTER POINTER
SA7 WORDPT
EQ ERR2FEW
*
KROUT DATA 6LROUTER
KROUTV DATA 8LROUTVARS
*
* /--- BLOCK ENDOV 00 000 79/02/04 23.39
*
ENDOV
* /--- BLOCK KEYWDOV 00 000 79/11/15 20.36
TITLE KEYWORD COMMAND OVERLAY
KEYWDOV OVRLAY
*
* * OVERLAY TO CONDENSE KEYWORD-ORIENTED COMMANDS
* *
* * KEYWD MACRO
* *
* * KEYWD NUMBER,NAME,ADDRESS,FLPTFLG
* *
* * NUMBER = NUMBER OF KEYWORD
* * NAME = NAME OF KEYWORD
* * ADDRESS = ADDRESS OF ROUTINE TO PROCESS TAG
* * FLPTFLG = ALPHA TO SUPPRESS F/I CONVERSION
*
PURGMAC KEYWD
KEYWD MACRO NUMBER,NAME,ADDRESS,FLPTFLG
LOCAL FICONV,UNUSED
UNUSED SET 0
IFC EQ,*FLPTFLG*ALPHA*
FICONV SET 1
ELSE
FICONV SET 0
ENDIF
DATA L*NAME*
VFD 1/FICONV,14/UNUSED,9/0,18/ADDRESS,18/NUMBER
ENDM
* /--- BLOCK COMMANDS 00 000 80/02/08 23.45
SA1 OVARG1
SB1 X1
JP B1+*+1 JUMP TO ROUTINE FOR COMMAND
+ EQ ATTF 0 = -ATTACHF-
+ EQ DETF 1 = -DETACHF-
+ EQ FILEF 2 = -FILEF-
+ EQ SYSFILE 3 = -SYSFILE-
*
* * -ATTACHF- COMMAND
*
ATTF CALL SYSTEST
CALL VARDO1 GET FIP
NG X1,ERRSTOR --- ERROR IF NOT STORABLE
CALL KEYWORDS,ATTFTAB,0
EQ MRKLAST --- PACK UP VARBUF AND EXIT
ATTFTAB BSS 0 TABLE OF -ATTACHF- KEYWORDS
KEYWD 0,FILE,FILE,ALPHA
KEYWD 1,PACK,WORD,ALPHA
KEYWD 2,MODE,WORD
DATA 0 MARK END OF TABLE
*
* * -DETACHF- COMMAND
*
DETF CALL SYSTEST
CALL VARDO1 GET FIP
NG X1,ERRSTOR --- ERROR IF NOT STORABLE
CALL KEYWORDS,DETFTAB,0
EQ MRKLAST --- PACK UP VARBUF AND EXIT
DETFTAB BSS 0 TABLE OF -DETACHF- KEYWORDS
KEYWD 0,FILE,FILE,ALPHA
KEYWD 1,PACK,WORD,ALPHA
KEYWD 2,STATION,NEXTKEYW
KEYWD 3,MASTER,NEXTKEYW
DATA 0 MARK END OF TABLE
*
* * -FILEF- COMMAND (KEYWORDS MUST CORRESPOND TO
* * THE KEYWORDS FOR -ATTACHF-)
*
FILEF CALL SYSTEST
CALL VARDO1 GET FIP
NG X1,ERRSTOR --- ERROR IF NOT STORABLE
CALL KEYWORDS,FILEFTAB,0
EQ MRKLAST --- PACK UP VARBUF AND EXIT
FILEFTAB BSS 0 TABLE OF -FILEF- KEYWORDS
KEYWD 0,FILE,FILE,ALPHA
KEYWD 1,PACK,WORD,ALPHA
DATA 0 MARK END OF TABLE
EJECT
*
* * -SYSFILE- COMMAND
* *
* * PRIMARY FUNCTIONS -
* *
* * ATTACH
* * DETACH
* * CHECK EXISTENCE OF A FILE
* * READ
* * WRITE
* * CREATE
* * DESTROY
* * RENAME
* * CHANGE FILE TYPE
* *
* * EACH PRIMARY FUNCTION IS FOLLOWED BY SECONDARY
* * KEYWORDS OR ARGUMENTS
*
SYSFILE CALL SYSTEST ERROR IF NOT SYSTEM LESSON
CALL VARDO1 GET FIP
NG X1,ERRSTOR --- ERROR IF NOT STORABLE
CALL GET1ARG (X6) = PRIMARY KEYWORD
ZR X6,ERR2FEW --- ERROR IF NO KEYWORD
* /--- BLOCK COMMANDS 00 000 80/02/08 23.45
SA1 SYSFPTAB-1 (A1) = ADDR. OF 0TH KEYWORD
MX0 48 (X0) = MASK FOR KEYWORD NAME
SYSFIL1 SA1 A1+1 (X1) = NEXT KEYWORD TABLE ENTRY
ZR X1,ERRNAME --- ERROR IF END OF TABLE
BX2 X0*X1 (X2) = NEXT KEYWORD
BX2 X2-X6 TEST IF SAME
NZ X2,SYSFIL1 --- RELOOP IF NO MATCH
BX1 -X0*X1 (X1) = TYPE OF KEYWORD
SX6 A1-SYSFPTAB (X6) = PRIMARY KEYWORD NUMBER
SA2 VARBUF (X2) = CURRENT VARBUF POINTER
SX7 X2+1 UPDATE VARBUF POINTER
SA7 A2+0 STORE INCREMENTED POINTER
SA6 VARBUF+X7 STORE KEYWORD NUMBER
NZ X1,SYSFIL2 --- READ/WRITE ARE SPECIAL
SB1 SYSFSTAB (B1) = ADDR OF SECONDARY KEYWDS
SB2 X6+13 (B2) = KEYWORD SHIFT
RJ KEYWORDS PROCESS SECONDARY KEYWORDS
EQ MRKLAST --- PACK UP VARBUF AND EXIT
SYSFIL2 CALL NEXTARG GET STARTING SECTOR NUMBER
CALL NEXTARG GET STORAGE INDEX
SA1 LASTKEY (X1) = LAST CHARACTER PROCESSED
ZR X1,SYSFIL3 --- IF END-OF-LINE REACHED
SX1 X1-KSEMIC CHECK IF SEMI-COLON
ZR X1,SYSFIL3 IF MORE KEYWORDS ARE PRESENT
CALL NEXTARG PROCESS NUMBER OF SECTORS
EQ SYSFIL4
SYSFIL3 CALL OMITTED MARK NO. OF SECTORS OMITTED
SYSFIL4 CALL GET1ARG (X6) = NEXT KEYWORD
ZR X6,MRKLAST IF NO MORE KEYWORDS
SA1 KMSG (X1) = 7LMESSAGE
IX6 X1-X6
NZ X6,ERRNAME IF NOT MESSAGE KEYWORD
CALL NEXTARG GET VAR FOR ERROR MESSAGE
SA1 LASTKEY (X1) = LAST KEY PROCESSED
NZ X1,ERR2MNY ERROR IF NOT END-OF-LINE
SYSFIL5 SA1 NEXTCOM (X1) = NEXT COMMAND
SA2 COMCONT (X2) = CURRENT COMMAND
BX1 X1-X2 TEST IF CONTINUED
NZ X1,MRKLAST --- FINISH UP IF ALL OK
EQ ERR2MNY --- ERROR IF CONTINUED COMMAND
*
* * PRIMARY -SYSFILE- KEYWORDS
* *
* * *SYSFIL* MACRO PARAMETERS --
* *
* * PRIMARY = PRIMARY KEYWORD (ATTACH, ETC.)
* * TYPE = 0 IF SECONDARY KEYWORDS, 1 IF
* * SPECIAL HANDLING
*
PURGMAC SYSFIL
MACREF SYSFIL$
SYSFIL MACRO PRIMARY,TYPE
MACREF SYSFIL
VFD 48/0L_PRIMARY,12/TYPE
ENDM
SYSFPTAB SYSFIL ATTACH,0 ATTACH FILE
* /--- BLOCK COMMANDS 00 000 80/02/08 23.45
SYSFIL DETACH,0 DETACH FILE
SYSFIL CHECK,0 CHECK EXISTENCE OF A FILE
SYSFIL READ,1 READ FILE
SYSFIL WRITE,1 WRITE FILE
SYSFIL CREATE,0 CREATE FILE
SYSFIL DESTROY,0 DESTROY FILE
SYSFIL RENAME,0 RENAME FILE
SYSFIL RETYPE,0 CHANGE FILE TYPE
SYSFIL FBIT,0 SET/CLEAR BACKUP BIT
SYSFIL RECREATE,0
DATA 0 MARK END OF TABLE
PURGMAC SELECT
MACREF SELECT$
SELECT MACRO ATR
MACREF SELECT
IRP ATR
ATR SET 1
IRP
ENDM
PURGMAC CLEAR
MACREF CLEAR$
CLEAR MACRO ATR
MACREF CLEAR
IRP ATR
ATR SET 0
IRP
ENDM
*
* * SECONDARY KEYWORD TABLE
* *
* * *SYSFKEY* MACRO PARAMETERS
* *
* * NUMBER = NUMBER OF KEYWORD
* * NAME = NAME OF KEYWORD
* * ADDRESS = ADDRESS OF ROUTINE TO PROCESS TAG
* * FLPTFLG = ALPHA TO SUPPRESS F/I CONVERSION
* * OPTS = COMMAND OPTIONS FOR WHICH THIS
* * SECONDARY KEYWORD IS AVAILABLE
*
PURGMAC SYSFKEY
SYSFKEY MACRO NUMBER,NAME,ADDRESS,FLPTFLG,OPTS
LOCAL FICONV,UNUSED
LOCAL FATTACH,FDETACH,FCHECK,FREAD,FWRITE
LOCAL FCREATE,FDEST,FRENAME,FRETYPE
LOCAL FFBIT
LOCAL FRECRE
UNUSED SET 0
IFC EQ,*FLPTFLG*ALPHA*
FICONV SET 1
ELSE
FICONV SET 0
ENDIF
CLEAR (FATTACH,FDETACH,FCHECK,FREAD,FWRITE)
CLEAR (FCREATE,FDEST,FRENAME,FRETYPE)
CLEAR FFBIT
CLEAR FRECRE
IRP OPTS
ALLIF IFC EQ,*OPTS*ALL*
SELECT (FATTACH,FDETACH,FCHECK,FREAD,FWRITE)
SELECT (FCREATE,FDEST,FRENAME,FRETYPE)
SELECT FFBIT
SELECT FRECRE
ALLIF ELSE
IFC EQ,*OPTS*ATTACH*,1
SELECT FATTACH
* /--- BLOCK COMMANDS 00 000 80/02/08 23.45
IFC EQ,*OPTS*DETACH*,1
SELECT FDETACH
IFC EQ,*OPTS*CHECK*,1
SELECT FCHECK
* /--- BLOCK COMMANDS 00 000 80/02/08 23.45
IFC EQ,*OPTS*READ*,1
ERR NOT WITH THIS FUNCTION, TURKEY.
IFC EQ,*OPTS*WRITE*,1
ERR NOT WITH THIS FUNCTION, TURKEY.
IFC EQ,*OPTS*CREATE*,1
SELECT FCREATE
IFC EQ,*OPTS*DESTROY*,1
SELECT FDEST
IFC EQ,*OPTS*RENAME*,1
SELECT FRENAME
IFC EQ,*OPTS*RETYPE*,1
SELECT FRETYPE
IFC EQ,*OPTS*FBIT*,1
SELECT FFBIT
IFC EQ,*OPTS*RECREATE*,1
SELECT FRECRE
ALLIF ENDIF
IRP
DATA L*NAME*
VFD 1/FICONV,12/UNUSED
VFD 1/FATTACH,1/FDETACH,1/FCHECK,1/FREAD
VFD 1/FWRITE,1/FCREATE,1/FDEST,1/FRENAME
VFD 1/FRETYPE
VFD 1/FFBIT
VFD 1/FRECRE
VFD 18/ADDRESS,18/NUMBER
ENDM
SYSFSTAB SYSFKEY 0,FILE,FILE,ALPHA,(ALL)
SYSFKEY 1,PACK,WORD,ALPHA,(ALL)
SYSFKEY 2,DIRECTORY,WORD,ALPHA,(ALL)
SYSFKEY 3,MODE,WORD,,(ATTACH)
SYSFKEY 4,STATION,NEXTKEYW,,(DETACH)
SYSFKEY 5,MASTER,NEXTKEYW,,(DETACH)
SYSFKEY 6,TYPE,WORD,,(ALL)
SYSFKEY 7,LENGTH,WORD,,(CREATE,RECREATE)
SYSFKEY 8,NPDWRITE,NEXTKEYW,,(CREATE)
SYSFKEY 9,NEWNAME,FILE,ALPHA,(RENAME)
SYSFKEY 9,(NEW NAME),FILE,ALPHA,(RENAME)
SYSFKEY 10,DIRSIZE,WORD,,(CREATE,RECREATE)
SYSFKEY 10,(DIR SIZE),WORD,,(CREATE,RECREATE)
SYSFKEY 11,RMTSIZE,WORD,,(CREATE,RECREATE)
SYSFKEY 11,(RMT SIZE),WORD,,(CREATE,RECREATE)
SYSFKEY 12,ON,NEXTKEYW,,(FBIT)
SYSFKEY 13,OFF,NEXTKEYW,,(FBIT)
SYSFKEY 14,OLDPACK,WORD,ALPHA,(ALL)
SYSFKEY 15,MESSAGE,WORD,ALPHA,(ALL)
SYSFKEY 16,NOATTACH,NEXTKEYW,,(CHECK)
SYSFKEY 17,ACCTRES,WORD,ALPHA,(ALL)
SYSFKEY 18,SUBACCT,WORD,ALPHA,(CREATE,RECREATE,RENAME)
SYSFKEY 19,ORIGINAL,WORD,,(CREATE,RECREATE,RENAME)
DATA 0 MARK END OF TABLE
* /--- BLOCK KEYWORDS 00 000 79/10/28 04.23
TITLE KEYWORD PROCESSING ROUTINES
*
* * -KEYWORDS- SUBROUTINE
* *
* * SEARCHES TABLE OF KEYWORDS AND JUMPS TO
* * APPROPRIATE ROUTINES FOR PROCESSING
* *
* * ON ENTRY, B1 = ADDRESS OF KEYWORD TABLE
* * B2 = PRIMARY KEYWORD SHIFT, 0 IF
* * DOES NOT APPLY
*
KEYWORDS EQ *
SX6 B1
SX7 B2 (X7) = PRIMARY KEYWORD SHIFT
SA6 KEYWTAB SAVE ADDR. OF KEYWORD TABLE
SA7 KEYWSHF STORE KEYWORD SHIFT
NEXTKEYW CALL GET1ARG (X6) = NEXT KEYWORD
ZR X6,KEYWORDS --- IF ALL KEYWORDS PROCESSED
SA1 KEYWTAB X1 = ADDR. OF KEYWORD TABLE
SA1 X1-2 INITIALIZE FOR KEYWORD SEARCH
NEXTKEY2 SA1 A1+2 (X1) = NEXT KEYWORD
ZR X1,ERRNAME --- ERROR IF END OF TABLE
BX1 X1-X6 CHECK IF SAME
NZ X1,NEXTKEY2 --- IF NO MATCH
SA1 A1+1 X1 = KEYWORD INFO WORD
SA2 KEYWSHF (X2) = KEYWORD SHIFT
ZR X2,NEXTKEY3 --- IF NOT TO CHECK
SB2 X2
LX2 X1,B2 SHIFT COMMAND BIT TO SIGN
PL X2,ERRNAME --- IF THIS KEYWORD ILLEGAL
NEXTKEY3 BX6 X1 (X6) = KEYWORD INFO WORD
SA6 KEYWINFO SAVE A COPY
SX6 X6 X6 = KEYWORD NUMBER
SA2 VARBUF X2 = GETVAR CODE COUNTER
SX7 X2+1 INCREMENT COUNTER
SX3 X7-VARBUFL TEST IF VARBUF FULL
PL X3,ERR2MNY --- ERROR IF VARBUF FULL
SA7 A2 STORE UPDATE COUNTER
SA6 VARBUF+X7 STORE KEYWORD NUMBER
AX1 18 SHIFT TO ADDR. FIELD
SB1 X1 B1 = ADDR OF PROCESSING ROUTINE
JP B1 --- PROCESS KEYWORD ARGUMENT
* /--- BLOCK KEYWORDS 00 000 80/02/08 23.45
*
* * ROUTINE TO PROCESS SINGLE ARGUMENT KEYWORDS
*
WORD CALL NEXTARG PROCESS NEXT ARGUMENT
CALL CHKFLOAT FLOATING POINT CHECK
EQ NEXTKEYW --- PROCESS NEXT KEYWORD
*
* * PROCESS ACCOUNT';FILE AND <LESLIST> ARGUMENTS
*
FILE SB1 1
SA1 WORDPT X1 = ADDR OF NEXT CHAR
SX1 X1-1 BACK UP FOR LOOP
FILE1 SX1 X1+B1 X1 = ADDR OF NEXT CHAR
SA2 X1 X2 = NEXT CHAR
SX0 X2-1R CHECK IF BLANK
ZR X0,FILE1 SKIP BLANKS
ZR X2,ERR2FEW --- ERROR IF END OF LINE
SX0 X2-KLT CHECK FOR LESLIST BRACKET
ZR X0,FILE5 --- IF LESLIST BRACKET
SA3 X2+KEYTYPE
SX0 X3-OPCOMMA CHECK IF SEPARATOR
ZR X0,ERR2FEW --- IF SEPARATOR REACHED
SX0 0 X0 = 0 = NO SPECIAL TERMINATOR
CALL PSCAN FIND END OF FIRST NAME
SX0 X1-KSEMIC CHECK IF SEMI-COLON
NZ X0,FILE2 --- IF NOT SEMI-COLON
SA3 B1-1 X3 = PRECEDING CHAR
SX0 X3-KUP CHECK IF SHIFT CODE
NZ X0,FILE2 --- IF NOT SHIFT CODE
EQ FILE3 --- IF ACCOUNT NAME PRESENT
*
* * ACCOUNT NAME OMITTED
*
FILE2 CALL OMITTED STORE OMITTED ARG GETVAR CODE
EQ FILE4 --- PROCESS FILE NAME
*
* * PROCESS ACCOUNT NAME
*
FILE3 SX6 1R X6 = BLANK
SA6 A3 REPLACE SHIFT CODE WITH BLANK
*////// TEMPORARY -- ACCOUNT NAME LEGAL ONLY IN SYSTEM LESSONS
SA1 SYSFLG
LX1 ZSLDSHF
PL X1,ERRNAME ERROR IF NOT SYSTEM LESSON
*////// END TEMPORARY
CALL NEXTARG PROCESS ACCOUNT NAME
CALL CHKFLOAT MASK OUT FLOATING POINT BIT
*
* * PROCESS FILE NAME
*
FILE4 CALL NEXTARG PROCESS FILE NAME
CALL CHKFLOAT MASK OUT FLOATING POINT BIT
EQ NEXTKEYW --- ADVANCE TO NEXT KEYWORD
* /--- BLOCK KEYWORDS 00 000 80/02/08 23.45
*
* * PROCESS <LESLIST> REFERENCE
*
FILE5 SX1 X1+B1 ADVANCE PAST LEFT BRACKET
BX6 X1
SA6 WORDPT UPDATE POINTER TO NEXT CHAR
SX0 KGT SCAN FOR RIGHT BRACKET
CALL PSCAN
SX0 X1-KGT CHECK IF RIGHT BRACKET FOUND
NZ X0,ERRTERM --- IF RIGHT BRACKET NOT FOUND
SX6 1R
SA6 B1 REPLACE RIGHT BRACKET W/BLANK
SA1 VARBUF X1 = CURRENT VARBUF INDEX
SX7 X1+1
SX2 X7-VARBUFL CHECK IF OVERFLOWING VARBUF
PL X2,ERR2MNY --- IF VARBUF FULL
SA7 A1 UPDATE VARBUF INDEX
SA2 LESLCOD X2 = LESLIST GETVAR CODE
BX6 X2
SA6 VARBUF+X7 STORE LESLIST CODE
CALL NEXTARG
EQ NEXTKEYW --- PROCESS NEXT KEYWORD
LESLCOD VFD 60/LLCODE
* /--- BLOCK KEYWORDS 00 000 80/02/08 23.45
*
* * -NEXTARG-
* *
* * PROCESSES NEXT VARIABLE ARGUMENT
*
NEXTARG EQ *
SA1 WORDPT CURRENT POSITION
SA1 X1
ZR X1,ERR2FEW --- IF END OF LINE REACHED
CALL VARDO2
EQ NEXTARG
*
* * -GET1ARG-
* *
* * GET NEXT KEYWORD
* *
* * ON ENTRY, (WORDPT) = ADDR. OF NEXT CHARACTER
* * (LASTKEY) = PREVIOUS DELIMITER
* *
* * ON EXIT, (X6) = NEXT KEYWORD, 0 IF NO MORE
*
GET1ARG EQ *
SA1 WORDPT CHECK NEXT CHARACTER
SA1 X1 (X1) = NEXT CHARACTER
ZR X1,GET1ARG2 --- IF EOL, READ NEXT LINE
SA1 LASTKEY (X1) = DELIMITER
SX6 X1-KSEMIC CHECK FOR SEMI-COLON
ZR X6,GET1ARG3 --- GO READ NEXT LINE
EQ ERR2MNY --- ERROR IF NO DELIMITER
GET1ARG2 SA1 NEXTCOM (X1) = COMMAND FOR NEXT LINE
SA2 COMCONT (X2) = CURRENT COMMAND
BX3 X1-X2 CHECK IF CONTINUED COMMAND
NZ X3,GET1ARG4 --- IF NOT CONTINUED LINE
CALL GETLINE READ NEXT LINE
GET1ARG3 CALL NXTNAM (X6) = TAG, (X1) = SEPARATOR
ZR X6,ERRNAME --- ERROR IF NONE OR TOO LONG
BX7 X1 (X7) = SEPARATOR
SA7 LASTKEY SAVE DELIMITER
EQ GET1ARG --- RETURN
GET1ARG4 MX6 0 (X6) = 0 IF NO MORE KEYWORDS
EQ GET1ARG --- RETURN
*
* * CHKFLOAT MASKS OUT THE FLOATING POINT BIT SO THAT
* * ALPHAMERIC FIELDS WILL NOT BE CONVERTED TO
* * INTEGER IF DEFINED IN V-TYPE VARIABLES
*
CHKFLOAT EQ *
SA1 KEYWINFO X1 = KEYWORD INFO WORD
PL X1,CHKFLOAT --- IF NOT ALPHAMERIC
SA1 VARBUF X1 = NO. OF GETVAR CODES
SB2 X1
SA1 A1+B2 X1 = LAST GETVAR CODE
MX0 61-XCODEL+XFBIT
BX6 -X0*X1 GET RID OF FLOATING POINT BIT
SA6 A1 PUT GETVAR CODE BACK IN PLACE
EQ CHKFLOAT --- RETURN
*
* * STORE SPECIAL CODE FOR OMITTED ARGUMENTS
*
OMITTED EQ *
MX6 1
LX6 19 SET 19TH BIT = OMITTED ARGUMENT
SA1 VARBUF CURRENT VARBUF INDEX
SX7 X1+1
* /--- BLOCK KEYWORDS 00 000 80/02/08 23.45
SX2 X7-VARBUFL SUBTRACT OFF SIZE OF VARBUF
PL X2,ERR2MNY EXIT IF VARBUF BUFFER FULL
SA7 A1
SA6 VARBUF+X7 STORE DUMMY ARGUMENT
EQ OMITTED
*
* * VARIABLES
*
KEYWTAB BSS 1 ADDRESS OF KEYWORD TABLE
KEYWSHF BSS 1 PRIMARY KEYWORD NUMBER/SHIFT
KEYWINFO BSS 1 1/ALPHA FLAG,23/0,18/ADDR,18/NO
KMSG DATA 7LMESSAGE
ENDOV
* /--- BLOCK END 00 000 76/07/21 20.45
*
*
OVTABLE
*
*
END COVLY3$