COVLAY4
* /--- FILE TYPE = E
* /--- BLOCK COVLAY4 00 000 75/10/04 11.48
IDENT COVLAY4
LCC OVERLAY(1,1)
*
TITLE OVERLAYS FOR COMMAND READINS
*
*
CST
*
*
EXT ERRORC,PUTCODE,DATAON=,CALCODE
EXT COMCONT,VARFIN,NXTLINE,ALTCODE
EXT ECSPRTY,KEYTYPE,NKLIST,NKLEND
EXT LNGUNIT,COMPNAM,SCANNER,UARGS,CSSCAN
EXT UNIT=,ARG=,DO=,DOJ=,DOC=,UNITOP=
EXT STORE=
EXT JOIN=,JOINC=,JDO=,IEUEND=
EXT ITFFTI,DOVTYPE,ERRCALL
EXT PSCAN,PAUSE2
EXT PUTTWO
EXT ERRTAGS,ERRNAME,ERRSTOR
EXT ERRXYTG,ERR2MNY,ERR2FEW
EXT ERRTERM,ERRUARG,ERRVTYP
EXT ERROUTR,ERRCNTD,ERRXORQ
EXT ERRBAL
EXT NOINDT,UDONE
EXT ONETWO1,NOTAG,ERR
EXT MRKLAST
EXT RJERNOZ
*
*
COVLY4$ OVFILE
*
*
* /--- BLOCK COV4 00 000 80/06/24 21.42
TITLE -COV4- COMMAND OVERLAY
*
*
*
COV4 OVRLAY
SA1 OVARG1 GET ARGUMENT
SB1 X1
JP B1+*+1
*
+ EQ SLOADIN 0 = -STOLOAD-
+ EQ ABORTIN 1 = -ABORT-
+ EQ CLEANC 2 = -CLEAN-
+ EQ SENDC 3 = -SEND-
+ EQ MASREQC 4 = -MASREQ-
+ EQ RESERVC 5 = -RESERVE-
+ EQ SYSDIN 6 = -SYSDATA-
+ EQ FBITIN 7 = -FBIT-
+ EQ ADD1IN 8 = -ADD1-
+ EQ ZEROC 9 = -ZERO-
+ EQ * 10 = UNUSED
+ EQ ALLOWC 11 = -ALLOW-
+ EQ STEPC 12 = -STEP-
+ EQ LESSINC 13 = -LESSIN-
+ EQ * 14 = UNUSED
+ EQ * 15 = UNUSED
+ EQ INDENTC 16 = -INDENT-
+ EQ SETIN 17 = -SET-
+ EQ TEKTRON 18 = -TEKTRON-
+ EQ REPLACC 19 = -REPLACE-
+ EQ GETCDIN 20 = -GETCODE-
+ EQ PERMITC 21 = -PERMIT-
+ EQ TSTBINC 22 = -TESTBIN-
+ EQ LBC 23 = -FINDLB-, -DELLB-, -SYSABRT-
+ EQ ADDLBC 24 = -ADDLB-
+ EQ ERRORC
*
*
* /--- BLOCK -STOLOAD- 00 000 77/04/24 20.48
TITLE -STOLOAD- AND -COMLOAD-
*
*
*
* -STOLOAD- AND -COMLOAD- COMMANDS
*
*
SLOADIN MX6 0
SA1 TAGCNT SEE IF BLANK TAG
ZR X1,SLBLANK
SA6 NCONT CLEAR CONTINUE COUNT
SA6 VARBUF+1 FIRST IS NUMBER OF LOADS
SA6 VARBUF+2 SECOND IS UNUSED
SX6 2
SA6 VARBUF INITIALIZE VARIABLE COUNT
*
SLOLP CALL VARDO2 GET FIRST VARIABLE
SA1 VARBUF
SA2 X1+VARBUF LOAD -GETVAR- CODE
NG X2,ERRSTOR EXIT IF NOT STOREABLE
MX0 -3
AX2 XCODEAL POSITION TYPE CODE
BX2 -X0*X2
SX2 X2-2 SEE IF STUDENT BANK REFERENCE
ZR X2,SLERR2
CALL VARDO2 GET NEXT TWO VARIABLES
CALL VARDO2
SA1 LASTKEY
NZ X1,ERR2MNY MUST BE E-O-L
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED
BX2 X1-X2
ZR X2,ISSCONT JUMP IF CONTINUED
SA1 NCONT
SX6 X1+1 NUMBER OF LOAD SELECTIONS
SA6 VARBUF+1
SA1 VARBUF NUMBER OF -GETVAR- CODES
EQ VARFIN PACK UP -GETVAR- CODES
*
ISSCONT CALL GETLINE GET NEXT LINE OF COMMAND
SA1 NCONT
SX2 X1-2 SEE IF TOO MANY CONTINUES
PL X2,SLERR1
SX6 X1+1
SA6 A1
EQ SLOLP
*
SLBLANK SA1 NEXTCOM SEE IF CONTINUED
SA2 COMCONT
BX2 X1-X2
ZR X2,ERRCNTD ERROR IF CONTINUED
EQ PUTCODE
*
SLERR1 SB1 49 TOO MANY
EQ =XERR
*
SLERR2 SB1 50 NOT COMMON
EQ =XERR
*
NCONT BSS 1
*
*
* /--- BLOCK ABORT 00 000 80/02/15 22.08
TITLE -ABORT- COMMAND
*
*
* -ABORT- COMMAND
* ABORT VARIOUS SYSTEM FUNCTIONS
*
*
ABORTIN SB1 ABLIST
SB2 ABEND
MX5 60
RJ SCANNER
ZR X0,PUTCODE
EQ ERRNAME
*
ABLIST VFD 60/6LCOMMON
VFD 60/6LRECORD
VFD 60/9LAUTOCHECK
VFD 60/7LLESLIST
ABEND BSS 1
*
*
*
* CONDENSE ROUTINE FOR LESSON BUFFER COMMANDS
* USED BY -FINDLB-, -DELLB-, -SYSABRT-
*
LBC CALL SYSTEST SYSTEM LESSONS ONLY
CALL FILEBLK GET ACCOUNT';FILE, BLOCK
ZR X1,ERR2FEW ERROR IF BLANK TAG
CALL VARDOR GET LESSON BUFFER TYPE
SX1 4 4 ARGUMENTS LEGAL
EQ VARFIN
*
*
* -ADDLB- COMMAND
*
ADDLBC CALL SYSTEST SYSTEM LESSONS ONLY
CALL FILEBLK GET ACCOUNT';FILE, BLOCK
ZR X1,ERR2FEW ERROR IF BLANK TAG
CALL VARDOR GET BUFFER TYPE AND LENGTH
SX1 5 5 ARGUMENTS LEGAL
EQ VARFIN
*
* /--- BLOCK CLEAN 00 000 80/06/24 22.28
*
* * -CLEAN- COMMAND
*
CLEANC RJ VARDO COMMA SEPARATED VARIABLES
SX1 2 PRESET TO 2 ARGS FOR *VARFIN*
SA2 VARBUF CHECK NUMBER OF ARGUMENTS
ZR X2,ERR2FEW MUST BE AT LEAST 1
SA3 VARBUF+1
NG X3,ERRSTOR --- 1ST ARG MUST BE STOREABLE
SX2 X2-2 CHECK IF 1 OR 2 ARGUMENTS
ZR X2,VARFIN --- DONE IF 2 ARGUMENTS
PL X2,ERR2MNY --- ERROR IF > 2 ARGUMENTS
SX6 1
SA6 VARBUF+2 FAKE 2ND GETVAR CODE = 1
SX6 2
SA6 VARBUF SET NUMBER OF ARGUMENTS TO 2
EQ VARFIN --- FINISH UP
* /--- BLOCK SEND 00 000 80/03/16 06.34
TITLE -SEND-
*
* -SEND- COMMAND
*
* SEND STATION,WHERE,BUFFER,LENGTH
* SEND STATION,BEEP
* SEND STATION,ERASE
*
* SEND STATION,ON,WHERE,BUFFER,LENGTH
* SEND STATION,OFF,WHERE,BUFFER,LENGTH
* SEND STATION,ALL,WHERE,BUFFER,LENGTH
*
* SEND STATION,ON,BEEP
* SEND STATION,OFF,BEEP
* SEND STATION,ALL,BEEP
*
* SEND STATION,ON,ERASE
* SEND STATION,OFF,ERASE
* SEND STATION,ALL,ERASE
*
*
* -SEND- IS A SYSTEM COMMAND TO SEND TEXT,
* BEEPS AND FULL-SCREEN ERASES TO ACTIVE OR
* INACTIVE TERMINALS OR BOTH (ONLY ACTIVE
* TERMINALS CAN BE BEEPED)
*
* THE GETVAR CODES ARE USED AS FOLLOWS --
*
* CODE 1 -- STATION NUMBER (-1 IF OUTPUT
* IS FOR ALL STATION)
* CODE 2 -- 10/0,5/STYPE,5/SWHO
* CODE 3 -- SCREEN POSITION IF TEXT OPTION
* CODE 4 -- BUFFER WITH TEXT
* CODE 5 -- LENGTH OF TEXT IN CHARACTERS
*
* STYPE = 0 = TEXT
* 1 = BEEP
* 2 = ERASE
*
* SWHO = 0 = ACTIVE STATIONS
* 1 = BOTH
* 2 = INACTIVE STATIONS
*
* AT EXECUTION TIME *STYPE* AND *SWHO* ARE
* CHANGED TO DECREMENTED BY 1.
*
* /--- BLOCK SEND 00 000 80/03/16 06.44
SENDC CALL SYSTEST
CALL VARDO1 DECODE FIRST ARGUMENT
SX6 0
SA6 SWHO PRESET FOR ACTIVE STATIONS
SA1 WORDPT
BX6 X1
SA6 OLDPT SAVE CHAR POINTER
SX6 2 SAVE 2ND VARBUF CODE
SA6 VARBUF
CALL NXTNAME NEXT TAG RETURNED IN X6
* SEPARATOR IN X1
ZR X1,SBEEP
SA1 ONOFFTAB-1 PRESET (A1) FOR SEARCH
MX0 48
ONOFFL SA1 A1+1 (X1) = NEXT KEYWORD
ZR X1,SENORM OLD TEXT -SEND- IF END OF TABLE
BX2 X0*X1
BX2 X2-X6
NZ X2,ONOFFL --- IF NO MATCH
BX6 -X0*X1 (X6) = ACTIVE/INACTIVE CODE
SA6 SWHO
SA1 WORDPT
BX6 X1
SA6 OLDPT ADVANCE SAVED CHAR POINTER
CALL NXTNAME (X6) = PARAMETER, (X) = SEP.
NZ X1,SENORM --- NORMAL TEXT IF NOT EOL
SBEEP SA1 KBEEP
BX2 X6-X1 SEE IF 4LBEEP
NZ X2,SERASE --- IF NOT BEEP OPTION
SX6 1 TYPE 1 = BEEP
EQ SENDFIN
SERASE SA1 KERASE
BX2 X1-X6 SEE IF 5LERASE
NZ X2,ERRTAGS --- IF NOT ERASE OPTION
SX6 2 TYPE 2 = ERASE
EQ SENDFIN
* /--- BLOCK SEND 00 000 80/03/16 06.42
*
BEEPCON VFD 20/0,1/1,19/1,20/0
KBEEP DATA 0LBEEP
KERASE DATA 0LERASE
*
ONOFFTAB VFD 48/0LON,12/0
VFD 48/0LALL,12/1
VFD 48/0LOFF,12/2
DATA 0 MARK END OF TABLE
*
SWHO BSS 1 FOR ACTIVE/INACTIVE/BOTH INFO
STYPE BSS 1 FOR TEXT/SEND/ERASE OPTION
*
* CONDENSE NORMAL TEXT -SEND-
*
SENORM SA1 OLDPT NORMAL SEND CONDENSE
BX6 X1
SA6 WORDPT RESTORE WORDPT
*
SGETA CALL VARDO2 GET NEXT ARGUMENT
SA1 LASTKEY
NZ X1,SGETA CONTINUE IF NOT E-O-L
*
SA1 VARBUF
SX1 X1-5 MUST BE 5 ARGUMENTS
NZ X1,ERRTAGS
SA1 VARBUF+4 4TH ARG MUST BE STOREABLE
NG X1,ERRSTOR
SX6 0 TYPE 0 = TEXT
*
* FORMAT SEND GETVAR CODE (10/0,5/STYPE,5/SWHO)
* AND EXIT TO *VARFIN*
*
* COME HERE WITH (X6) = TYPE OF SEND
*
SENDFIN LX6 5
SA2 SWHO
BX6 X6+X2
SA6 VARBUF+2
SA1 VARBUF (X1) = NUMBER OF VARBUF CODES
EQ VARFIN
MASREQC TITLE -MASREQ- READIN
MSRQKEY SPACE 4,15
** MSRQKEY - TABLE OF -MASREQ- KEYWORDS.
*
* MSRQKEY KEYWORD,NUMARGS,NUMPUTV,NUMSTOR
*
*T 42/7LKEYWORD,6/NUMARGS,6/NUMPUTV,6/NUMSTOR
*
* KEYWORD = VALID KEYWORD FOR -MASREQ- COMMAND
* NUMARGS = TOTAL NUMBER OF ARGUMENTS REQUIRED
* NUMPUTV = POSITION OF ARGUMENT REQUIRING A PUTVAR
* CODE. IF = 0, NONE IS REQUIRED.
* NUMSTOR = POSITION OF ARGUMENT WHICH MUST BE
* STOREABLE. IF = 0, NONE IS REQUIRED.
PURGMAC MSRQKEY
MACREF MSRQKEY$
MSRQKEY MACRO KEYWORD,NUMARGS,NUMPUTV,NUMSTOR
MACREF MSRQKEY
IFC EQ,*KEYWORD**
DATA 0
ELSE
VFD 42/0L_KEYWORD,6/NUMARGS,6/NUMPUTV,6/NUMSTOR
ENDIF
ENDM
MSRQTAB MSRQKEY ACTION,5,0,0
MSRQKEY CONSOLE,7,0,0
MSRQKEY JOBLIST,4,0,3
MSRQKEY JOBSTAT,4,4,0
MSRQKEY PPU,5,0,0
MSRQKEY SCR,3,0,3
MSRQKEY STATUS,3,3,0
MSRQKEY CONFIG,3,0,3
MSRQKEY END OF MSRQTAB
MASREQC SPACE 4,25
* /--- BLOCK SEND 00 000 80/03/16 06.42
** MASREQC - PROCESS -MASREQ- COMMAND.
*
* CALLS ERRSTOR, ERRTERM, ERR2FEW, ERR2MNY, MRKLAST,
* NXTNAM, PUTDO2, SYSTEST, VARDO1, VARDO2.
*
* MACROS CALL
MASREQC CALL SYSTEST CHECK FOR SYSTEM LESSON
SA1 SYSFLG (X1) = SYSTEM LESSON ATTRIBUTES
LX1 ZMASSHF SHIFT TO *MAS* PERMISSION BIT
PL X1,ERRORC IF NO -MASREQ- PERMISSION
CALL VARDO1 PROCESS *MFN* ARGUMENT
SA1 WORDPT (X1) = POINTER TO CURRENT CHAR
SA1 X1-1 (X1) = DELIMITER (PREVIOUS CHR)
ZR X1,ERR2FEW IF END OF LINE
SX6 X1-1R,
NZ X6,ERRTERM IF NOT A COMMA
CALL NXTNAM (X6) = NEXT TAG, (X1) = SEPARATOR
ZR X6,ERR2FEW IF END OF LINE
BX7 X1
SA7 LASTKEY SAVE LAST DELIMITER
* SEARCH FOR KEYWORD IN TABLE.
SA1 MSRQTAB-1
MX0 42
MAS1 SA1 A1+1
ZR X1,ERRNAME IF INVALID KEYWORD
BX2 X1*X0
BX3 X2-X6
NZ X3,MAS1 IF KEYWORD NOT FOUND
SX7 A1-MSRQTAB+1 STORE KEYWORD ORDINAL
SA7 VARBUF+2
MX0 -6 STORE STOREABLE NUMBER
BX7 -X0*X1
SA7 NUMSTOR
LX1 -6 STORE PUTVAR NUMBER
BX7 -X0*X1
SA7 NUMPUTV
LX1 -6 STORE NUMBER OF ARGUMENTS
BX7 -X0*X1
SA7 NUMARGS
SX7 2 CURRENT ARGUMENT POSITION
SA7 VARBUF
SA7 ARGCNT
MAS3 SA1 ARGCNT INCREMENT ARGUMENT COUNT
SX7 X1+1
SA7 ARGCNT
SA2 LASTKEY CHECK DELIMITER
ZR X2,ERR2FEW IF END OF LINE
SX6 X2-1R,
NZ X6,ERRTERM IF NOT A COMMA
SA2 NUMPUTV CHECK FOR PUTVAR REQUIRED
BX6 X7-X2
ZR X6,MAS5 IF PUTVAR REQUIRED
CALL VARDO2 GENERATE GETVAR CODE
SA2 NUMSTOR CHECK IF STORE NEEDED
SA3 ARGCNT
BX6 X3-X2
NZ X6,MAS10 IF NO STORE NEEDED
* /--- BLOCK SEND 00 000 80/03/16 06.42
NG X1,ERRSTOR IF NOT STOREABLE
EQ MAS10
MAS5 CALL PUTDO2 GENERATE PUTVAR CODE
MAS10 SA1 ARGCNT CHECK FOR LAST ARGUMENT
SA2 NUMARGS
BX3 X2-X1
NZ X3,MAS3 IF MORE ARGUMENTS
SA1 WORDPT CHECK FOR END OF LINE
SA1 X1
NZ X1,ERR2MNY IF TOO MANY ARGUMENTS
EQ MRKLAST TERMINATE GETVAR TABLE
ARGCNT OVDATA 1 CURRENT ARGUMENT NUMBER
NUMARGS OVDATA 1 NUMBER OF ARGUMENTS REQUIRED
NUMPUTV OVDATA 1 POSITION OF PUTVAR ARGUMENT
NUMSTOR OVDATA 1 POSITION OF STOREABLE ARGUMENT
*
*
*
* /--- BLOCK RESERVE 00 000 80/03/12 01.03
*
TITLE -RESERVE- / -RELEASE- COMMANDS
*
*
*
* -RESERVE- / -RELEASE- COMMANDS
*
* RESERVE COMMON
* RESERVE FILE
* RESERVE RECORDS,BLOCK (,NBLOCKS)
* RESERVE NAME
* RESERVE SIGNON (,PERMANENT) $$ SYSTEM LESSONS
* RESERVE DIRECTORY $$ DATASETS, NAMESETS, GROUPS
* RESERVE ATTACH
* RESERVE LESLIST
*
*
RESERVC CALL NXTNAME GET NAME IN X6, SEP. IN X1
SA3 KCOMM
BX3 X3-X6 CHECK FOR *COMMON*
ZR X3,RESVCOM
SA3 KFILE
BX3 X3-X6 CHECK FOR *FILE*
ZR X3,RESVFIL
SA3 KRECS
BX3 X3-X6 CHECK FOR *RECORDS*
ZR X3,RESVREC
SA3 KNAME
BX3 X3-X6 CHECK FOR *NAME*
ZR X3,RESVNAM
SA3 KSIGNON
BX3 X3-X6 CHECK FOR *SIGNON*
ZR X3,RESVSIG
SA3 KDIRECT
BX3 X3-X6 CHECK FOR *DIRECTORY*
ZR X3,RESVDIR
SA3 KATTACH
BX3 X3-X6 CHECK FOR *ATTACH*
ZR X3,RESVATT
SA3 KLESLST
IX3 X3-X6 CHECK FOR *LESLIST*
ZR X3,RESVLST
SA3 KSIGNO
BX3 X3-X6 CHECK FOR *SIGNOUT*
ZR X3,RESVSGN
EQ ERRNAME
*
RESVCOM NZ X1,ERR2MNY MUST BE E-O-L
MX6 0 0 = ENTIRE COMMON
EQ PUTCODE
*
RESVFIL NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
SX6 1 1 = ENTIRE FILE
LX6 XCMNDL SHIFT PAST COMMAND CODE
EQ PUTCODE
*
RESVNAM NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
SX6 2 2 = ENTIRE NAME (IN NAMESET)
LX6 XCMNDL
EQ PUTCODE
* /--- BLOCK RESERVE 00 000 80/08/07 02.17
*
*
RESVREC CALL VARDO
SA1 VARBUF
SX2 X1-2
ZR X2,RESVD2
PL X2,ERR2MNY
SX2 X1-1
NZ X2,ERRTAGS
* ONLY ONE ARG--SET DEFAULT VALUE
SX7 1
SA7 VARBUF+2
IX7 X7+X7
SA7 VARBUF RESET ARGUMENT COUNT
RESVD2 CALL VARFEM
MX2 -XSPTRL THIS IS BECAUSE VARFEM ALWAYS
LX2 XCMNDL INSERTS THE XSTOR POINTER
BX6 X2*X6 ZERO OUT EXTRA STORAGE POINTER
SX3 3 3 = DATASET RECORDS
LX3 XCMNDL SHIFT PAST COMMAND CODE
BX6 X6+X3 MARK AS A DATASET -RESERVE-
EQ PUTCODE
*
RESVSIG NZ X1,ERR2MNY --- IF ADDITIONAL TAGS
CALL SYSTST1 SYSTEM LESSONS ONLY
SX6 4 4 = PLATO SIGNON
LX6 XCMNDL
EQ PUTCODE
*
RESVDIR NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
SX6 5 5 = DIRECTORY
LX6 XCMNDL
EQ PUTCODE
*
RESVATT NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
CALL SYSTEST SYSTEM LESSONS ONLY
SX6 6 6 = ATTACH
LX6 XCMNDL
EQ PUTCODE
*
*
RESVLST NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
SX6 7 7 = LESLIST
LX6 XCMNDL
EQ PUTCODE
*
RESVSGN NZ X1,ERR2MNY MUST HAVE NO ARGUMENTS
CALL SYSTST1 SPECIAL SYSTEM LESSONS ONLY
SX6 8 6 = SIGNOUT
LX6 XCMNDL
EQ PUTCODE
*
KLESS DATA 0LLESSON
KCOMM DATA 0LCOMMON
KRECS DATA 0LRECORDS
KFILE DATA 0LFILE
KNAME DATA 0LNAME
KSIGNON DATA 0LSIGNON
KDIRECT DATA 0LDIRECTORY
KATTACH DATA 0LATTACH
KLESLST DATA 0LLESLIST
KSIGNO DATA 0LSIGNOUT
*
* /--- BLOCK -SYSDATA- 00 000 81/01/08 01.08
TITLE READ-IN FOR -SYSDATA- COMMAND
*
*
*
* -SYSDATA- COMMAND
*
SYSDIN CALL SYSTEST SYSTEM LESSONS ONLY
CALL NXTNAME DECODE OPTION NAME ****
SA1 KSETF
IX1 X1-X6
ZR X1,SDSET JUMP IF SETFILE
SA1 KREW
IX1 X1-X6
ZR X1,SDREW JUMP IF REWIND
SA1 KCHECK
IX1 X1-X6
ZR X1,SDCHK JUMP IF CHECKPT
EQ ERRNAME ERROR IF UNRECOGNIZED OPTION
*
* GET ACCOUNT';FILE FOR -SETFILE- FORM
*
SDSET CALL ACCFILE,VARBUF+2,0
ZR X1,ERR2FEW ERROR IF NO FILE GIVEN
SA1 LASTKEY
NZ X1,ERR2MNY ERROR IF EXTRA ARGUMENTS
SX6 0 SET OPTION NUMBER
SA6 VARBUF+1
SX6 3 THREE ARGUMENTS
SA6 VARBUF
BX1 X6
EQ VARFIN
*
SDREW SX6 1 REWIND OPTION
EQ SDRC
*
SDCHK SX6 2 CHECKPT OPTION
*
SDRC LX6 60-XCODEL POSITION OPTION NUMBER
SA1 WORDPT POINTER TO LAST CHARACTER
SA1 X1
ZR X1,PUTCODE EXIT IF END OF LINE
EQ ERR2MNY ERROR IF EXTRA ARGUMENTS
*
*
KSETF DATA 0LSETFILE
KREW DATA 0LREWIND
KCHECK DATA 0LCHECKPT
*
*
TITLE READ-IN FOR -FBIT- COMMAND
*
*
*
* -FBIT- COMMAND
* FIRST ARG = FILE NAME
* SECOND = ON OR OFF
*
*
FBITIN CALL SYSTEST SYSTEM LESSONS ONLY
CALL COMPILE GET -GETVAR- CODE FOR FILE NAME
LX1 60-XCODEL
BX6 X1 SAVE
SA6 VARBUF
CALL COMPSYM,FBLST,2
LX1 60-2*XCODEL
SA2 VARBUF
BX6 X1+X2
EQ PUTCODE
*
FBLST VFD 42/0LON,18/1
+ VFD 42/0LOFF,18/0
*
*
TITLE -TESTBIN-
*
* -TESTBIN- COMMAND
*
* CHECK FOR EXISTANCE OF BINARY
*
*
TSTBINC CALL SYSTEST SYSTEM LESSONS ONLY
CALL ACCFILF GET ACCOUNT';FILE NAME
ZR X1,ERR2FEW ERROR IF BLANK TAG
SA2 LASTKEY
ZR X2,MRKLAST EXIT IF END OF LINE
CALL VARDO2
SA2 LASTKEY
ZR X2,MRKLAST EXIT IF END OF LINE
EQ ERR2MNY NO MORE THAN 2 ARGUMENTS
*
* /--- BLOCK -ADD1- 00 000 77/04/24 20.21
TITLE ADD1, SUB1, ZERO AND ZERO* COMMANDS
*
*
* -ADD1- AND -SUB1- COMMANDS
*
*
ADD1IN CALL TAGSAVE SAVE *TAG* BUFFER
SA1 WORDPT
BX6 X1 SAVE *WORDPT*
SA6 VARBUF+1
CALL COMPILE
BX6 X1 SAVE -GETVAR- CODE
SA6 VARBUF
CALL TAGREST (COMPILE MAY MODIFY *TAG*)
SA1 VARBUF+1
BX6 X1
SA6 WORDPT RESET *WORDPT*
CALL PUTCOMP
SA2 VARBUF LOAD FIRST -GETVAR- CODE
LX2 60-XCODEL
LX1 60-XCODEL-XCODEL
BX6 X1+X2 MERGE READ/STORE -GETVAR- CODES
EQ PUTCODE
*
*
*
* -ZERO- COMMAND
*
*
ZEROC SA1 WORDPT POINTER TO FIRST CHARACTER
MX0 0 NO SPECIAL TERMINATOR
CALL PSCAN FIND END OF FIRST ELEMENT
NZ X1,ZERO2A JUMP IF TWO ARGUMENT COMMAND
CALL PUTCOMP
BX6 X1 POSITION -GETVAR- CODE
LX6 60-XCODEL
EQ PUTCODE
*
*
*
*MUST TEST THAT THERE ARE NO MORE THAN 2 ARGS.....
*
ZERO2A CALL COMPILE DECODE FIRST VARIABLE
NZ B1,ERRSTOR
BX6 X1
SA6 VARBUF SAVE -GETVAR- CODE
CALL COMPILE
SA2 WORDPT CHECK FOR END-OF-LINE
SA2 X2 DO INDIRECT ACCESS
NZ X2,ERR2MNY ERROR IF NOT EOL
SA2 VARBUF
LX2 60-XCODEL POSITION -GETVAR- CODES
LX1 60-XCODEL-XCODEL
BX6 X1+X2
SA1 COMNUM
SX1 X1+1 INCREMENT COMMAND NUMBER
BX6 X1+X6
EQ ALTCODE
*
*
* /--- BLOCK ALLOW 00 000 79/07/19 23.15
*
TITLE -ALLOW-
*
* -ALLOW- COMMAND
*
* ALLOW ACCESS TO ROUTER LESSONS COMMON
*
*
ALLOWC SA1 ROUTER MUST BE -ROUTER- LESSON
ZR X1,ERROUTR
CALL NXTNAME GET ALLOW TYPE ****
NZ X1,ERR2MNY MUST BE END-OF-LINE
SB1 B0
ZR X6,ALLW1 JUMP IF BLANK
SB1 B1+1
SA1 KRD
BX1 X1-X6
ZR X1,ALLW1 JUMP IF *READ*
SB1 B1+1
SA1 KWT
BX1 X1-X6
ZR X1,ALLW1 JUMP IF *WRITE*
SB1 B1+1
SA1 RVREAD
BX1 X1-X6
NZ X1,ERRNAME MUST BE *READ RVARS*
*
ALLW1 SX6 B1 PICK UP TYPE
LX6 60-12
EQ PUTCODE --- ADD COMMAND CODE AND STORE
*
RVREAD DATA 10LREAD RVARS
KRD DATA 0LREAD
KWT DATA 0LWRITE
*
*
TITLE -PERMIT-
*
* -PERMIT- COMMAND
*
* PERMIT VARIOUS THINGS IN A LESSON
*
*
PERMITC CALL NXTNAME GET ALLOW TYPE ****
NZ X1,ERR2MNY MUST BE END-OF-LINE
SB1 B0
ZR X6,PRMT1 JUMP IF BLANK
SB1 B1+1
SA1 KSR
BX1 X1-X6
ZR X1,PRMT1 JUMP IF *SHORT RECS*
SA1 KSRNS
BX1 X1-X6
ZR X1,PRMT1 JUMP IF *SHORTRECS*
NZ X1,ERRNAME MUST BE *SHORTRECS*
*
PRMT1 SX6 B1 PICK UP TYPE
LX6 60-12
EQ PUTCODE --- ADD COMMAND CODE AND STORE
*
KSR DATA 10LSHORT RECS
KSRNS DATA 0LSHORTRECS
*
*
TITLE -STEP-
*
* -STEP- COMMAND
*
* INITIATE/TERMINATE STEP MODE EXECUTION
*
*
STEPC CALL COMPSYM,STEPOPT,2
EQ CALCODE
*
STEPOPT VFD 42/2LON,18/1
+ VFD 42/3LOFF,18/0
* /--- BLOCK -LESSIN- 00 000 80/02/02 22.08
TITLE -LESSIN- COMMAND
*
*
*
* -LESSIN- COMMAND
* CHECKS TO SEE IF A LESSON IS IN ECS
*
*
LESSINC BSS 0
*
* CONDENSE FILE NAME AS NORMAL TUTOR EXPRESSION
*
CALL ACCFILE,VARBUF+1,1
ZR X1,ERR2FEW ERROR IF BLANK TAG
SA2 LASTKEY
NZ X2,ERR2MNY ERROR IF EXTRA ARGUMENTS
SX1 2 2 ARGUMENTS LEGAL
BX6 X1
SA6 VARBUF 2 ARGUMENTS FOUND
EQ VARFIN
*
*
*
* /--- BLOCK INDENT 00 000 77/09/15 20.17
TITLE -INDENT- COMMAND READIN
INDENTC CALL VARDO
* MAKE SURE THAT ARGUMENTS 1,3,4,5,6 ARE STOREABLE
SA1 VARBUF+1
NG X1,=XERRSTOR
SA1 VARBUF+3
NG X1,=XERRSTOR
SA1 VARBUF+4
NG X1,=XERRSTOR
SA1 VARBUF+5
NG X1,=XERRSTOR
SA1 VARBUF+6
NG X1,=XERRSTOR
SX1 6 MUST HAVE EXACTLY SIX ARGUMENTS
EQ =XVARFIN
*
* -COUNTLN- COMMAND
*
* FORMAT OF COMMAND
* COUNTLN START,LENGTH,POS,COUNT,RETURN[,MODS]
* MAKE SURE THAT ARGUMENTS 1 AND 5 ARE STORABLE
*
******* REMOVED THE CONDENSE ROUTINE FOR -COUNTLN- SINCE
******* IT SEEMS DOUBTFUL THAT ANYONE WILL EVER FINISH
******* THIS FOUR YEAR OLD PROJECT.
******* D. WOOLLEY 81/08/10
*
* CNTLNC BSS 0
* RJ SYSTEST SYSTEM LESSONS ONLY FOR NOW
* CALL VARDO
* SA1 VARBUF+1
* NG X1,=XERRSTOR
* SA1 VARBUF+5
* NG X1,=XERRSTOR
* SA1 VARBUF
* SX2 X1-5
* ZR X2,CNTLNL JUMP IF NO 6TH
* SX2 X1-6
* NZ X2,=XERRTAGS
* CNTFIN SX1 6 MUST HAVE EXACTLY SIX ARGUMENTS
* EQ =XVARFIN
**
* CNTLNL SX6 0
* SA6 VARBUF+6 FAKE UP GETVAR CODE = 0.
* SX6 6
* SA6 VARBUF
* EQ CNTFIN
*
* /--- BLOCK -TEKTRON- 00 000 81/08/10 13.03
TITLE -TEKTRON-
*
* -TEKTRON- COMMAND
*
* TEKTRON ON TOP 2 BITS OF COMMAND WORD SET
* TEKTRON OFF TOP 1 BIT OF COMMAND WORD SET
* TEKTRON VAR,LTH JUST TWO NORMAL GETVAR CODES
*
*
TEKTRON BSS 0
SA1 TEKON
CALL TAGXACT
MX6 2
NG X1,PUTCODE IF -TEKTRON ON-
SA1 TEKOFF
CALL TAGXACT
MX6 1
NG X1,PUTCODE IF -TEKTRON OFF-
EQ =XCOLLCTC GO GET TWO ARGUMENTS, 1ST MUST BE STORABLE
TEKON DATA 2LON
TEKOFF DATA 3LOFF
* /--- BLOCK -REPLACE- 00 000 78/04/14 01.19
TITLE -REPLACE- COMMAND READIN
*
* FORMAT OF COMMAND
*
* REPLACE IN,LTH,OUT,LTH,TABLE,LTH,CHARS,MODE
*
* ARGUMENTS 1,3,5,7 MUST BE STOREABLE
*
REPLACC CALL SYSTEST
CALL VARDO
* MAKE SURE THAT ARGUMENTS 1,3,5,7 ARE STOREABLE
SA1 VARBUF+1
NG X1,=XERRSTOR
SA1 VARBUF+3
NG X1,=XERRSTOR
SA1 VARBUF+5
NG X1,=XERRSTOR
SA1 VARBUF+7
NG X1,=XERRSTOR
SX1 8 MUST HAVE EXACTLY 8 ARGUMENTS
EQ =XVARFIN
* /--- BLOCK -GETCODE- 00 000 78/05/11 18.05
*
* -GETCODE-
*
* FIRST TAG IS VARIABLE TO STORE THE CODEWORD IN.
* NEXT (OPTIONAL) IS A LIST OF KEYS THAT TERMINATE
* THE ENTRY. THE LIST IS PRECEDED BY ',ENDKEYS=',
*
EXT NKLIST
EXT NKLEND
*
GETCDIN CALL COMPILE COMPILE FIRST TAG
NZ B1,ERRSTOR MUST BE STOREABLE
BX6 X1 SAVE -GETVAR- CODE
SA6 VARBUF
CALL NXTNAM SEE IF THERE IS ANYTHING ELSE
ZR X6,GETCIN3 IF NO SECOND ARGUMENT
SX1 X1-1R= TERMINATOR MUST BE ',=',
NZ X1,ERRTERM WASN'7T
SA1 GETCDA WORD MUST BE ',ENDKEYS',
BX1 X1-X6
NZ X1,ERRNAME NOT SO
MX4 0
SCAN CALL NXTNAM GET NEXT WORD
ZR X6,GETCIN2 --- IF NO MORE
SX5 1
SB1 -1
MX0 42 MASK FOR NAMES
SA6 NKLEND PLANT FOR END TEST
SCAN2 SB1 B1+1
SA1 NKLIST+B1 GET NEXT ENTRY
BX1 X1-X6
BX1 X0*X1 MASK OUT SIGNIFICANT BITS
NZ X1,SCAN2 --- IF NO MATCH
SB2 NKLEND
SB2 A1-B2
ZR B2,ERRNAME --- IF BAD KEY NAME
LX5 B1 POSITION BIT
BX4 X4+X5 MERGE IT IN
EQ SCAN DO NEXT ONE
*
GETCIN2 SA2 VARBUF GET GETVAR CODE BACK
LX2 2*XCODEL SHIFT INTO PLACE
SX0 1
LX0 NEXT-FUNKEY FORM BIT FOR -NEXT-
BX6 X4+X0 SET INTO KEYLIST
LX6 XCMNDL MAKE ROOM FOR COMMAND CODE
BX6 X6+X2 MOVE FIRST ARGUMENT IN
EQ PUTCODE STORE IT
*
GETCIN3 MX4 0
EQ GETCIN2 ONE ARGUMENT CASE
*
GETCDA DATA L*ENDKEYS*
* /--- BLOCK -SET- 00 000 80/02/15 22.08
*
TITLE -SET- COMMAND
*
* SET ARRAY_ARG1,ARG2,ARG3,...
* SET ARRAY(R,C)_ARGI,ARGJ,ARGK,...
* SET V1_ARG1,ARG2,...
*
* FILLS CONSECUTIVE VARIABLES WITH ITEMS IN LIST
* BEGINNING AT FIRST ARGUMENT AND GOING UP
* GIVES ERROR MSG AT CONDENSE TIME (IF POSSIBLE)
* OR EXEC TIME IF LIST RUNS OVER PERMISSIBLE BOUNDS
* OF ARRAY OR STUDENT VARIABLES
*
EXT EQERR
EXT VARSEP,VARLEX,VARFINM,VARDOC,VARDOCL
EXT ARAYFLG,TSTERR,CPXERR
EXT ECSPRTY
*
SETIN SA1 WORDPT
BX6 X1
MX7 59 -1
SA6 VARBUF SAVE WORDPT HERE
SA7 VSKMODE DONT EXPAND DEFINE
* DO SEARCH FOR ASSIGN ARROW, CHANGE TO COMMA
SA1 SEPASGN
BX7 X1 SET TO DETECT ASSIGN ARROW
SA7 VARSEP
RJ VARLEX SEARCH FOR FIRST ARROW
ZR X1,NOASSGN ERROR IF NOT FOUND
SX6 1R, CHANGE TO COMMA
SA6 X7 ADDR OF ARROW LEFT HERE
CALL INITLEX
CALL LEX GET FIRST LEXICAL ITEM
SA4 VARBUF
BX6 X4
SA6 WORDPT RESET FOR COMPILATION
*
SA2 OP
ZR X2,SET20 JUMP IF ADTYPE LIKE N1,V1
SX6 X2-OPDEFN CHECK FOR DEFINED WORD
NZ X6,SET20 JUMP IF SOME OTHER OP
SA1 ADTYPE
SET05 ZR X1,EQERR DEFINE MUST HAVE ADTYPE
NG X1,EQERR ERROR IF UNKNOWN NAME
MX0 -XCODEAL
BX3 -X0*X1 ADDRESS
AX1 XCODEAL GETVAR TYPE
SX6 X1-6
NZ X6,SET20 JUMP IF NOT ARRAY DEFINE
*
SET10 SA2 ATOKEN ADDR OF TOKENS
IX0 X3+X2 ECS ADDR OF LITERAL
SA0 VARBUF+1 SAVE HERE AS FLAG FOR ARRAY
+ RE 1 READ LITERAL FROM ECS
RJ ECSPRTY
SX7 1
SA7 ARAYFLG ALLOW ARRAY COMPILE
EQ SET30
*
SET20 SX6 0
SA6 VARBUF+1 FLAG NOT ARRAY
SA6 ARAYFLG DONT ALLOW ARRAY COMPILE
*
SET30 CALL COMPILE GET STARTING ADDR GETVAR
NE B1,B0,SETER2 ERROR FROM -COMPILE-
BX6 X1
SA6 VARBUF+2 2D ARG = START ADDR GETVAR
SX7 2
SA7 VARBUF 2 ARGUMENTS SO FAR
SA7 ARAYFLG ARAYS NOT ALLOWED IN LIST
SA1 SET99
BX6 X1 PUT EQ SET40 IN RETURN
SA6 VARDOC
EQ VARDOCL CONTINUE READING LIST ITEMS
*
* /--- BLOCK SET30 00 000 80/02/15 22.08
*
* CHECK IF LIST EXCEEDS MAX ADDR IF POSSIBLE
SET40 SA1 VARBUF RETURN FROM PACKING UP LIST
SX1 X1-2 NUMBER ITEMS IN LIST
SA2 VARBUF+1 =0 OR =SIZE
SA3 VARBUF+2 START GETVAR
MX0 -XCODEAL
ZR X2,SET50 JUMP IF NOT ARRAY
BX6 -X0*X2 START RELATIVE ADDR
SA4 ASVARS
PL X2,SET45 JUMP IF STUDENT BANK
SA4 ACVARS
SET45 BX5 X2
AX5 45
MX7 -9
BX5 -X7*X5 SIZE
IX7 X4+X6 ABS START ADDR
IX7 X7+X5 +SIZE = MAX+1 ADDR
SA7 VARBUF+1 PUT IN LIST
MX7 -XCODEL
BX7 -X7*X3
AX7 XCODEAL ISOLATE START GETVAR TYPE
SX7 X7-6 =0 IF WHOLE ARRAY
ZR X7,SET60 JUMP IF WHOLE ARRAY
RJ SET80
ZR X7,VARFINM MUST CHECK BOUNDS AT EXEC TIME
SET48 SA2 VARBUF+1 ABS MAX+1
IX5 X6+X4 ABS START
IX5 X5+X1 +ITEMS
IX6 X2-X5 MAX+1 - END
NG X6,SETERR ERROR IF ITEMS RUN PAST MAX
EQ VARFINM GO PACKUP COMMAND WORDS
*
SET50 RJ SET80
NZ X7,SET55
SA7 VARBUF+1 MUST FIND ENDLIMIT AT EXECTIME
EQ VARFINM GO PACKUP WORDS
*
SET55 IX7 X4+X7 GET MAX ADDR IN STUD OR COM
SA7 VARBUF+1 BANK +1
EQ SET48
*
SET60 IX5 X5-X1 SIZE-ITEMS
NG X5,SETERR JUMP IF TOO MANY ITEMS
EQ VARFINM
*
SET80 EQ * FIND STUD/COM BANK LIMITS
BX6 -X0*X3 GETVARCOD IN X3, PUT ADDR IN X6
AX3 XCODEAL
MX5 -3
BX3 -X5*X3 DISCARD I/F BIT
SA4 ASVARS
SX7 VARLIM+1
SX5 X3-2 X3=2 IF STUD BANK
ZR X5,SET80 RETURN STUD BANK LIMITS IF SO
SA4 ACVARS
SX7 NCVRLIM+1
SX5 X3-3 X3=3 IF COMMON
ZR X5,SET80 RETURN COMMON BANK LIMITS IF SO
SX7 0 CANT CHECK LIMIT AT CONDEN TIME
EQ SET80
*
SET99 EQ SET40
*
NOASSGN SB1 45 NO ASSIGN
EQ =XERR
*
SETERR SB1 58
EQ =XERR
*
SETER2 SB1 724
EQ =XERR
*
SEPASGN SX1 X1-KASSIGN USED IN VARLOC SEARCH
*
ENDOV
*
* /--- BLOCK COVL4A 00 000 79/07/06 05.18
TITLE -COV4A- VARIOUS COMMAND READINS
COV4A OVRLAY
*
SA1 OVARG1
SB1 X1
JP B1+*+1
*
+ EQ COPYC -COPY-
+ EQ EDITIN -EDIT-
+ EQ STORUIN -STOREU-
+ EQ JKEYC -JKEY-
+ EQ BUMPC -BUMP-
+ EQ MOVEC -MOVE-
+ EQ CIRCLC -CIRCLE- -RCIRCLE- ETC.
+ EQ EXTOUTC -EXTOUT-
+ EQ STOREAC -STOREA-
+ EQ LOADAC -LOADA- -EXACTV-
* /--- BLOCK COPY 00 000 79/07/06 02.56
TITLE -COPY-
* -COPY- (CODE=130)
*
* SPECIFY CHAR STRING, CHAR COUNT FOR 'C'O'P'Y KEY
*
COPYC RJ VARDO COMMA SEPARATED VARIABLES
SA2 VARBUF X2 = NUMBER OF VARIABLES
SX1 X2-2
NZ X1,ERRTAGS JUMP IF NOT TWO ARGUMENTS
SA1 VARBUF+1
NG X1,ERRSTOR ERROR IF 1ST VARIABLE CANNOT BE STORED INT
MX0 61-XCODEL+XFBIT MASK OUT I/F BIT
BX1 -X0*X1
BX6 X1 X6 = CLEANED AND POSITIONED -GETVAR- CODE
AX1 XCODEAL CHECK FOR EXPLICIT COMMON ADDRESS
SX1 X1-3
ZR X1,VCOMERR JUMP IF EXPLICIT COMMON REFERENCE
SX1 X1+1
NZ X1,COPYC1 IF NOT STUDENT VAR
MX2 -XCODEAL
BX2 -X2*X6
SX1 VARLIM+1
IX1 X2-X1
PL X1,VCOMERR IF NOT STUDENT VAR
COPYC1 LX6 60-XCODEL POSITION CODE
SA2 VARBUF+2 X2 = 2ND VARIABLE
MX0 60-XCODEL
BX2 -X0*X2
LX2 60-2*XCODEL
BX6 X6+X2 ADD 2ND CODE
EQ PUTCODE
*
*
*
* EDIT COMMAND...2 CASES...
* 1. NO ARG
* 2. ONE ARG
EDITIN SA1 TAGCNT
ZR X1,PAUSE2 SEE IF NO ARG CASE
RJ VARDO
SA2 VARBUF X2 = NUMBER OF VARIABLES
SX1 X2-1
NZ X1,ERR2MNY JUMP IF NOT ONE ARG
SA1 VARBUF+1
NG X1,ERRSTOR ERROR IF 1ST VARIABLE CANNOT BE STOREDINTO
MX0 61-XCODEL+XFBIT MASK OUT I/F BIT
BX1 -X0*X1
BX6 X1 X6 = CLEANED AND POSITIONED -GETVAR- CODE
AX1 XCODEAL CHECK FOR EXPLICIT COMMON ADDRESS
SX1 X1-3
ZR X1,VCOMERR JUMP IF EXPLICIT COMMON REFERENCE
SX1 X1+1
NZ X1,EDITIN1 IF NOT STUDENT VAR
MX2 -XCODEAL
BX2 -X2*X6
SX1 VARLIM+1
IX1 X2-X1
PL X1,VCOMERR IF NOT STUDENT VAR
EDITIN1 LX6 60-XCODEL POSITION CODE
EQ PUTCODE
*
*
VCOMERR SB1 106 COMMON VARIABLE REFERENCE
EQ ERR
* /--- BLOCK STOREU 00 000 76/07/17 06.02
TITLE STOREU
*
*
* STOREU NUMBER,UNITS
* UNITS ARE THE (FLOATING-POINT) UNIT DIMENSIONS
*
STORUIN CALL PUTCOMP COMPILE CODE TO STORE X6
SA2 LASTKEY
ZR X2,ERR2FEW ERROR IF END-OF-LINE
LX1 60-XCODEL POSITION -GETVAR- CODE
BX6 X1
SA6 VARBUF SAVE GETVAR CODE
RJ COMPILE GET SECOND ARG
NZ B1,ERRSTOR MUST BE ABLE TO STORE INTO
BX6 X1
AX6 XCODEAL+3 SAVE I/F BIT
ZR X6,ERRVTYP DIMENSIONS ARE FLOATING-PT
SA2 VARBUF
LX1 60-2*XCODEL POSITION 2ND GETVAR CODE
BX6 X1+X2
SX1 STORE= USE -STORE- COMMAND CODE
BX6 X1+X6
EQ ALTCODE
*
* /--- BLOCK JKEY-BUMP 00 000 75/10/04 11.49
*
* -JKEY-
*
* TAG IS NAMES OF KEYS WHICH CAN INITIATE JUDGING
*
JKEYC SB1 NKLIST START OF TABLE OF LEGAL NAMES
SB2 NKLEND END OF TABLE OF LEGAL NAMES
MX5 42 MASK FOR NAMES---BOTTOM 18 BITS ARE KEYCODE
* RJ SCANNER SCAN FOR KEY NAMES
RJ CSSCAN SCAN FOR CASE-SENSITIVE NAMES
ZR X0,PUTCODE
EQ ERRNAME
*
*
TITLE -BUMP-
* -BUMP- (CODE=133)
*
* 'THE TAG OF A BUMP COMMAND MUST HAVE FROM 1 TO
* 8 BCD CODES. 'THE STORAGE FORMAT OF THE COMMAND
* IS TAG CHARS LEFT-JUSTIFIED IN COMMAND WORD WITH
* ZERO FILL.
*
*
BUMPC SA1 TAGCNT
ZR X1,ERR2FEW ERROR IF NO TAG
SB2 X1-9
PL B2,ERR2MNY TOO MANY CHAR CODES
SB1 B0 CHAR NUMBER
SB2 X1 NUMBER OF CHARS
SB3 54 POST-SHIFT COUNT
SB4 6 CHAR WIDTH
MX6 0 COMMAND WORD
BUMPLP SA1 TAG+B1 NEXT CHAR
BX6 X6+X1 GET ANOTHER CODE
LX6 6 MOVE OVER
SB1 B1+1
SB3 B3-B4 POST-SHIFT DECR.
NE B1,B2,BUMPLP
LX6 X6,B3 LEFT JUSTIFY
EQ PUTCODE ALL GONE
*
* /--- BLOCK MOVE 00 000 79/07/06 04.01
TITLE MOVE
* -MOVE-
*
*
* NORMAL 4 ARG MOVE COMMAND.
* INADD,INPOS,OUTADD,OUTPOS
* /// IF 5TH ARG GIVEN, IT IS NUMBER OF CHARS ///
*
*
MOVEC RJ VARDO SET UP VARBUF
SA1 VARBUF+1 FROM ADDRESS
PL X1,MOVC1
MX0 1
LX0 XCODEL
BX6 X1+X0
SA6 A1
MOVC1 SA1 VARBUF+3 *TO* ADDRESS MUST BE STOREABLE
NG X1,ERRSTOR
SA1 VARBUF X1 = NUMBER OF VARIABLES
SX2 X1-6
PL X2,ERR2MNY --- FOUR OR FIVE ARGS ONLY
SX2 X2+2
ZR X2,MOVC4 GO TO PACK UP IF NORMAL 4 ARG MOVE COMMAND
NG X2,ERR2FEW OTHERWISE MUST BE 5
EQ VARFIN GO TO PACK UP VARIABLES
*
MOVC4 MX6 2*XCODEL+1 BIT IN 3RD FIELD ON
SA6 VARBUF+5
EQ VARFIN GO PACK IT UP
*
* /--- BLOCK CIRCLE 00 000 77/08/04 04.18
TITLE CIRCLE
*
*
* -CIRCLE R-
* -CIRCLE R,THETA1,THETA2-
*
* IF ONLY ONE TAG, THE TOP BIT IS SET ON THE
* SECOND GETVAR CODE.
*
* USED BY
* -CIRCLE-
* -RCIRCLE-
* -GCIRCLE-
* -CIRCLB-
*
CIRCLC RJ VARDO GET COMMA-SEPARATED VARS
SA1 VARBUF SHOULD BE 1 OR 3 ARGUMENTS
SX2 X1-3
ZR X2,VARFIN IF THREE ARGS
SX2 X1-1
NZ X2,ERRTAGS IF WRONG NO. ARGS
SA1 VARBUF+1 RETRIEVE FIRST TAG CODE
MX2 1 MAKE SECOND TAG CODE
LX2 XCODEL
EQ PUTTWO AND COMPLETE COMMAND WORD
* /--- BLOCK EXTOUT 00 000 79/07/06 04.30
TITLE -EXTOUT-
* -EXTOUT- (CODE=186)
*
* 'SENDS 16 BITS OF DATA (EQUIVALENT TO EITHER
* AUDIO OR EXT). 'OPTIONAL 2ND ARGUMENT SPECIFIES
* LENGTH OF BUFFER TO SEND.
*
*
EXTOUTC RJ VARDO COMMA SEPARATED VARIABLES
SX1 2 2 VARIABLES REQUIRED
SA2 VARBUF NUMBER OF VARIABLES FOUND
SX3 X2-1
ZR X3,EXTO1 JUMP IF ONLY 1 ARGUMENT
SA3 VARBUF+1
PL X3,VARFIN --- PACK UP, STORE COMMAND WORD
EQ ERRSTOR --- ERROR EXIT IF CANNOT BE STORED INTO
*
EXTO1 BX6 X1
SA6 A2 RESET VARIABLE COUNT TO 2
SX7 1 CODE FOR 1 AS LENGTH
SA7 VARBUF+2 STORE AS 2ND VARIABLE
EQ VARFIN --- PACK UP, STORE COMMAND WORD
* /--- BLOCK STOREA 00 000 76/10/01 03.42
TITLE STOREA
*
* -STOREA- (CODE=68)
*
*
STOREAC RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+1 PICK UP FIRST GETVAR CODE
NG X1,ERRSTOR MUST BE STOREABLE
STOREA1 MX0 61-XCODEL+XFBIT MASK OUT I/F BIT
BX1 -X0*X1
SA3 VARBUF X3 = NUMBER OF VARIABLES
SX3 X3-1
SX2 10 -GETVAR- CODE FOR 10 CHARACTERS
ZR X3,PUTTWO DONE IF ONLY ONE ARGUMENT
SX3 X3-1
NZ X3,ERR2MNY IF WRONG NO. ARGUMENTS
SA2 VARBUF+2 PICK UP SECOND GETVAR CODE
EQ PUTTWO NOW COMPLETE COMMAND WORD
*
*
*
* -EXACTV- (CODE=134)
* -LOADA- (CODE=226)
*
LOADAC RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF+1 PICK UP FIRST GETVAR CODE
EQ STOREA1 1ST ARG NEED NOT BE STOREABLE
* /--- BLOCK ENDOV 00 000 79/07/06 02.46
*
ENDOV
* /--- BLOCK ACCESS 00 000 79/04/28 16.25
TITLE ACCESS, SYSACC COMMAND READINS
ACCOV OVRLAY
SA1 OVARG1 GET ARGUEMENT
SB1 X1
JP B1+*+1
*
+ EQ SYSACCC 0 = -SYSACC-
+ EQ ACCESSC 1 = -ACCESS-
* /--- BLOCK ACCESS 00 000 79/04/28 16.25
**
*
* -SYSACC- COMMAND READ-IN
*
* SYSACC ACCOUNT';FILE,BLOCK,BUFFER,RETURN,MAXL,RETURNL
*
* ACCOUNT ACCOUNT OF FILE WITH ACCESS BLOCK
* FILE NAME OF FILE WITH ACCESS BLOCK
* BLOCK NAME OF ACCESS BLOCK
* BUFFER USER SUPPLIED BUFFER TO READ
* NAME (2 WORDS)
* GROUP
* ACCOUNT
* USER TYPE
* SYSTEM
* RETURN VARIABLE TO RETURN BITS IN
* RETURNL NUMBER OF BITS RETURNED
* MAXL MAXIMUM LENGTH TO RETURN
**
*
SYSACCC CALL SYSTEST SEE IF SYSTEM LESSONS
CALL FILEBLK GET ACCOUNT, FILE, AND BLOCK ARGUMENTS
CALL VARDOR GET REMAINING ARGUMENTS
*
SA1 VARBUF GET NUMBER OF ARGUMENTS
SX2 X1-7 NEEDS EXACTLY 7 ARGUMENTS
NG X2,ERR2FEW NOT ENOUGH ARGUMENTS
NZ X2,ERR2MNY TOO MANY ARGUMENTS
SA2 VARBUF+5 5TH ARGUMENT MUST BE STOREABLE
NG X2,ERRSTOR
SA2 VARBUF+7 7TH ARGUMENT MUST BE STOREABLE
NG X2,ERRSTOR
EQ VARFIN EXIT WITH X1 STILL SET TO 7
*
* /--- BLOCK + ACCESS 00 000 81/01/18 20.01
TITLE ACCESS COMMAND.
**
* -ACCESS- COMMAND READ-IN
*
* ACCESS LESSON;RETURN VARIABLE
* ACCESS FILE;RETURN VARIABLE
* ACCESS ACCOUNT';FILE,BLOCK;RETURN
ACCESSC BSS 0
* SAVE VALUE OF WORDPT TO ALLOW BACKUP
SA1 WORDPT
BX6 X1
SA6 SWORDPT
* GET FIRST TAG
ACGO CALL NXTNAM GET FIRST TAG
* IF SEMICOLON PRESENT, THIS MIGHT BE SPECIAL FORM
SX2 X1-KSEMIC
NZ X2,ACRSET NOT ; -- MUST BE LESSON,BLOCK
* SEE IF KEY WORDS -LESSON- OR -FILE-
SA2 CFILE
BX2 X6-X2 SEE IF KEYWORD OF -FILE-
NZ X2,ACCLESS
* SET TO KEY WORD FILE
SX6 1
EQ ACTWO TWO TAG FORM FOR -FILE-
ACCLESS SA2 CLESSON CHECK FOR KEYWORD -LESSON-
BX2 X6-X2
NZ X2,ACRSET DUNNO; MAYBE IT WAS ACCT';FILE
* SET TO KEY WORD LESSON
SX6 2
*
ACTWO SA6 SACTYPE SAVE KEYWORD TYPE
CALL SYSTEST TWO-ARG FORM FOR SYSTEM LESSONS
* SET UP FIRST -GETVAR- CODE TO MARK KEYWORD FORMAT
MX1 1
LX1 XCODEL
SA3 SACTYPE GET KEYWORD TYPE
BX6 X1+X3
SA6 VARBUF+1 STORE AS FIRST CODE
MX6 0
SA6 VARBUF+2 ZERO SECOND, THIRD GETVAR CODES
SA6 VARBUF+3
SX6 3
SA6 VARBUF MARK 3 ARGS COMPILED SO FAR
SA6 LASTKEY FAKE OUT -VARDOR-
EQ ACRETRN PROCESS RETURN ARGUMENT(S)
* /--- BLOCK + ACCESS 00 000 81/01/12 03.31
* LESSON,BLOCK FORMAT
ACRSET SA1 SWORDPT RESTORE CHAR POINTER
BX6 X1
SA6 WORDPT
CALL FILEBLK GET ACCOUNT, FILE, AND BLOCK NAMES
ZR X1,ERR2FEW ERROR IF BLANK TAG
SA1 LASTKEY
SX2 X1-KSEMIC NEXT CHAR SHOULD BE SEMICOLON
NZ X2,ERRTAGS NOPE; SOMEONE IS CONFUSED
* PROCESS RETURN ARGUMENT(S)
* EXPECTING ONE OR TWO; FIRST MUST BE STORABLE
ACRETRN CALL VARDOR GET REMAINING ARGUMENTS
SA1 VARBUF
SX1 X1-4 CHECK TOTAL GETVAR CODES SO FAR
NG X1,ERR2FEW MUST BE AT LEAST 4
NZ X1,ACRET2 BUT MIGHT BE 5
* ONE RETURN ARGUMENT SPECIFIED; SET UP
* DUMMY 5TH GETVAR CODE
MX6 1
LX6 XCODEL
SA6 VARBUF+5
SX6 5
SA6 VARBUF AND MARK 5 CODES TOTAL
EQ ACRETST GO TO CHECK STOREABILITY
* TWO OR MORE RETURN ARGUMENTS PRESENT
ACRET2 SX1 X1-1 SEE IF 5 ARGUMENTS TOTAL
NZ X1,ERR2MNY ERROR IF MORE THAN 5
*
CALL SYSTEST ALLOWED IN SYSTEM LESSONS ONLY
* MAKE SURE 4TH ARGUMENT IS STOREABLE
ACRETST SA1 VARBUF+4
NG X1,ERRSTOR ERROR IF NOT
*
SX1 5
EQ VARFIN FINISHED WITH THIS COMMAND
SWORDPT BSS 1 SAVE WORDPT
SACTYPE BSS 1 SAVE TYPE OF KEYWORD
CFILE DATA 0LFILE KEYWORDS
CLESSON DATA 0LLESSON
*
ENDOV
* /--- BLOCK JOINOV 00 000 77/04/24 20.47
TITLE -JOIN-, -JUMP-, -DO- COMMANDS
*
*
*
JOINOV OVRLAY
SA1 OVARG1 GET ARGUMENT
SB1 X1
JP B1+*+1
*
+ EQ JUMPIN 0 = -JUMP-
+ EQ BRANCHI 1 = BRANCHI
+ EQ BRANCHQ 2 = BRANCHQ
+ EQ GOTOIN 3 = -GOTO-
+ EQ JOININ 4 = -JOIN-
+ EQ DOIN 5 = -DO-
+ EQ FINISC 6 = -FINIS-
+ EQ PINIT 7 = FINISH UP BEFORE MTUTOR
+ EQ UNITC 8 = -UNIT-
+ EQ ENTRYIN 9 = -ENTRY-
+ EQ INITC 10 = -INITIAL-
+ EQ ROUTEC 11 = -ROUTE-
+ EQ TIMERC 12 = -TIMER-
+ EQ TIMELC 13 = -TIMEL-
+ EQ UDONE20 14 = RE-ENTRY FROM -DEFINE-
+ EQ UDONE10 15 = RE-ENTRY FROM PURGING SET
*
EXT UNITFLG,AUNUM,ENDPNT
+ EQ RETIN 16 = -NRET-
+ EQ RETIN1 17 = -RETURN-
*
*
* /--- BLOCK JOININ 00 000 77/04/24 20.22
TITLE -JUMPIN-
*
*
* -JUMPIN-
* READIN ROUTINE FOR BRANCHING COMMANDS
*
*
JUMPIN MX6 0 MARK UNIT -Q- NOT LEGAL
SA6 QOK
EQ JOININ0
*
*
JOININ0 MX6 -1 MARK UNITS WITH ARGUMENTS OK
SA6 ARGOK
*
JOININ1 SA1 TAGCNT BLANK TAG IS SAME AS UNIT -Q-
ZR X1,UNCJQ
SA1 NEXTCOM CHECK FOR CONTINUED COMMAND
SA2 COMCONT
BX2 X1-X2
ZR X2,CJO CONDITIONAL IF CONTINUED
SA1 WORDPT
MX0 0 NO SPECIAL TERMINATOR
CALL PSCAN SCAN FIRST ELEMENT
ZR X1,UNCJ JUMP IF UNCONDITIONAL
*
CJO CALL COMPILE EVALUATE EXPRESSION
BX7 X1
LX7 60-XCODEL
SA7 BRVAR SAVE -GETVAR- CODE
MX6 0
SA6 JCALL MARK NOT SPECIAL CALL (-GOTO-)
SA6 SAMEU0 NO SPECIAL SAME UNIT TREATMENT
*
JOININ2 MX6 0
SA6 UBUFF INITIALIZE NUMBER OF UNITS
*
CJLP CALL UNAMA PROCESS NEXT UNIT NAME
SA1 UARGS SEE IF ANY ARGUMENTS
ZR X1,CJLP0
SA1 ARGOK SEE IF ARGUMENTS LEGAL
ZR X1,ERRNAME
*
CJLP0 SX0 X6-UNQNUM
NZ X0,CJLP1 CHECK FOR UNIT -Q-
SA1 QOK
ZR X1,ERRXORQ ERROR IF UNIT -Q- NOT LEGAL
*
CJLP1 CALL APACK PACK UP ANY ARGUMENTS
SA1 SAMEU0
ZR X1,CJLP2 JUMP IF SAME UNIT NOT SPECIAL
SA1 UNUMON
BX1 X1-X6 CHECK FOR SAME UNIT
NZ X1,CJLP2
MX6 0 RETURN 0 FOR SAME UNIT
*
CJLP2 SA1 UBUFF
SX7 X1+1 INCREMENT UNIT COUNT
SA7 A1
SX1 X1-100 ALLOW 100 UNITS
PL X1,ERR2MNY
SA6 X7+UBUFF STORE THIS UNIT NUMBER
SA1 WORDPT
SA1 X1 LOAD NEXT CHARACTER
NZ X1,CJLP JUMP IF NOT END OF LINE
SA1 NEXTCOM
SA2 COMCONT SEE IF CONTINUED COMMAND
BX2 X1-X2
NZ X2,CJTAB
CALL GETLINE GET NEXT LINE OF TEST
EQ CJLP
* /--- BLOCK JOININ 00 000 76/07/24 16.27
*
CJTAB SA4 INX UNIT EXTRA STORAGE POINTER
SX7 X4
SA1 UBUFF NUMBER OF UNITS
ZR X1,ERR2MNY
SB1 X1
EQ CJTLP0
*
CJTLP SA6 X7+INFO STORE COMPLETED WORD
SX7 X7+1
*
CJTLP0 MX6 0 CLEAR WORD BUILDING
SB2 45 INITIALIZE SHIFT COUNT
*
CJTLP1 SB1 B1-1 DECREMENT UNIT COUNT
NG B1,CJTFIN
SA1 A1+1 LOAD NEXT UNIT NUMBER
LX1 X1,B2
BX6 X1+X6 MERGE WITH REST OF WORD
SB2 B2-15 DECREMENT SHIFT COUNT
PL B2,CJTLP1
EQ CJTLP JUMP IF WORD COMPLETE
*
CJTFIN SB1 B2-45 SEE IF LAST WORD EMPTY
PL B1,CJTFIN0
SA6 X7+INFO STORE LAST TABLE WORD
SX7 X7+1
*
CJTFIN0 SA7 INX UPDATE EXTRA STORAGE POINTER
SA1 JCALL
ZR X1,CJTFIN1 JUMP IF NOT SPECIAL CALL
SB1 X1
JP B1 RETURN TO CALLING ROUTINE
*
CJTFIN1 LX4 12+XCMNDL POSITION INDEX IN XSTOR
SA1 UBUFF NUMBER OF TABLE ENTRIES
LX1 XCMNDL
BX6 X1+X4
SA1 BRVAR -GETVAR- CODE FOR EXPRESSION
BX6 X1+X6
SA1 COMNUM ADD 1 TO COMMAND NUMBER
SX1 X1+1
BX6 X1+X6
EQ ALTCODE EXIT TO STORE COMMAND WORD
*
JCALL BSS 1
UBUFF EQU SHOWOUT MUST BE AT LEAST 100 LONG
*
*
* /--- BLOCK JOININ 00 000 81/01/28 15.15
*
*
* READIN FOR UNCONDITIONAL BRANCHING COMMAND
*
UNCJ CALL UNAMA GET UNIT NUMBER TO X6
SX0 X6-UNXNUM CHECK FOR UNIT -X-
ZR X0,ERRXORQ
SX0 X6-UNQNUM CHECK FOR UNIT -Q-
ZR X0,UNCJQ
SA1 UARGS SEE IF ANY ARGUMENTS
ZR X1,UNCJ1
SA1 ARGOK SEE IF ARGUMENTS LEGAL
ZR X1,ERRUARG
*
UNCJ1 CALL APACK
LX6 48 POSITION UNIT NUMBER
EQ PUTCODE
*
UNCJQ SA1 QOK SEE IF UNIT -Q- LEGAL
ZR X1,ERRXORQ
MX6 0 UNIT NUMBER 0 = UNIT -Q-
EQ PUTCODE
*
QOK BSS 1
ARGOK BSS 1
SAMEU0 BSS 1
*
*
BRANCHI SA1 COMNUM SEE IF -IFERROR- COMMAND
SB1 X1
SB2 =XIFERR=
NE B1,B2,BI09 IF NOT -IFERROR- COMMAND
SB1 FSIFERR -IFERROR- IS PUBLISH ERROR
RJ =XPUBERRS
EQ BI10
*
BI09 SB2 =XSTOP1= CHECK FOR STOP1 COMMAND
NE B1,B2,BI10 BRANCH IF NOT
SA1 SYSFLG CHECK FOR SYSTEM LESSON
LX1 ZSLDSHF
NG X1,BI10 BRANCH IF YES (STOP1 OK)
SB1 150 ISSUE NON-FATAL WARNING
RJ =XRJERNOZ
BI10 MX6 -1 MARK UNIT -Q- LEGAL
SA6 QOK
MX6 0 MARK ARGUMENTS NOT LEGAL
SA6 ARGOK
EQ JOININ1
*
BRANCHQ MX6 0
SA6 QOK MARK UNIT -Q- NOT LEGAL
SA6 ARGOK MARK ARGUMENTS NOT LEGAL
EQ JOININ1
*
*
* /--- BLOCK GOTOIN 00 000 77/04/24 20.24
TITLE -GOTO- COMMAND
*
*
* -GOTO- AND -GOTO*- COMMANDS
*
*
GOTOIN SA1 TAGCNT BLANK TAG IS SAME AS UNIT -Q-
ZR X1,UNCGQ
SA1 NEXTCOM CHECK FOR CONTINUED COMMAND
SA2 COMCONT
BX2 X1-X2
ZR X2,CGO CONDITIONAL IF CONTINUED
SA1 WORDPT
MX0 0
CALL PSCAN SCAN FIRST ELEMENT
ZR X1,UNCG JUMP IF UNCONDITIONAL
*
* CONDITIONAL -GOTO- COMMAND
*
CGO CALL GCOMP COMPILE
LX1 60-XCODEL+XFBIT
PL X1,CGO1 JUMP IF INTEGER
SX7 0100B
LX7 18 FORM AN RJ TO FTOI CONVERTER
SA1 LLFTOI ADDRESS OF FTOI ROUTINE
BX7 X1+X7
CALL LONGI ADD TO INSTRUCTION STREAM
CALL PAD FILL OUT REST OF WORD
*
CGO1 SA1 NINST POINTER TO CURRENT WORD
SA2 X1
MX0 30 SEE IF 30 BITS LEFT
BX7 X0*X2
ZR X7,CGO2 JUMP IF ROOM LEFT
CALL PAD
SA1 NINST POINTER TO NEXT FREE WORD
*
CGO2 SX7 X1+1 RESERVE ANOTHER WORD
MX6 0
SA6 X7 CLEAR OUT LAST WORD
SX7 X7+1
SA7 A1 UPDATE *NINST*
CALL MOVCODE MOVE COMPILED CODE TO XSTOR
BX7 X0 RELATIVE ADDR OF COMPILED CODE
LX7 42 MOVE TO TOP 18 BITS
SA7 BRVAR
SA2 INX
BX6 X2
SA6 GCODADD SAVE ENDING ADDRESS OF CODE
MX6 -1
SA6 QOK MARK UNIT -Q- LEGAL
SA6 SAMEU0 GOTO SAME UNIT SPECIAL
SA6 ARGOK ARGUMENTS LEGAL
SX6 GOTOFIN
SA6 JCALL SET RETURN ADDRESS
EQ JOININ2
*
* /--- BLOCK GOTOIN 00 000 76/07/24 16.30
*
* DONE -- ADD SETUP INSTRUCTIONS AND PACK UP
* COMMAND WORD (X4 = ADDRESS OF TABLE)
*
GOTOFIN SA1 GCODADD SET UP INSTRUCTION POINTER
SB1 X1+INFO-2
SX2 6125B COMPILE A SB2 B5+K
LX2 18
BX7 X2+X4 ATTACH INDEX TO TABLE
RJ IPACK
SA2 UBUFF NUMBER OF ENTRIES IN TABLE
ZR X2,ERR2FEW
SX7 7120B COMPILE A SX2 B0+K
LX7 18
BX7 X2+X7 ATTACH NUMBER OF ENTRIES
RJ IPACK
SX7 0400B SET UP BRANCH TO -GOTO- ROUTINE
LX7 18
SA1 LLGOTO
BX7 X1+X7 ATTACH ADDRESS OF ROUTINE
RJ IPACK
RJ ILJUST LEFT-ADJUST LAST WORD
SA4 COMNUM
SX6 X4+1 X6 = COMMAND NUMBER
SA1 BRVAR ADDRESS OF CODE
BX6 X6+X1
EQ ALTCODE STORE COMPLETED COMMAND WORD
*
*
*
* UNCONDITIONAL -GOTO-
*
UNCGQ SX6 UNQNUM SET FOR UNIT -Q-
EQ UG1
*
UNCG CALL UNAMA GET UNIT NUMBER
CALL APACK
SX0 X6-UNXNUM
ZR X0,ERRXORQ ERROR IF UNIT -X-
SA1 UNUMON
BX1 X1-X6 SEE IF GOTO UNIT ALREADY IN
NZ X1,UG1
MX6 0 SET FOR SAME UNIT
UG1 LX6 48 PUT INTO TOP 12 BITS
EQ PUTCODE
*
GCODADD BSS 1
*
*
* /--- BLOCK GOTOIN 00 000 73/11/11 00.33
*
*
* -IPACK-
* ADD 30 BIT INSTRUCTION TO STREAM
*
IPACK EQ *
MX0 30
SA1 B1 LOAD NEXT INSTRUCTION WORD
BX2 X0*X1
ZR X2,IP1 JUMP IF ENOUGH ROOM
MX0 15
BX2 X0*X1 SEE IF ROOM FOR 15 BIT INST
NZ X2,IP0
SX6 46000B
LX1 15 ADD A PASS INSTRUCTION
BX6 X1+X6
SA6 B1 STORE COMPLETED WORD
*
IP0 SB1 B1+1
MX1 0 SET UP FOR NEW WORD
*
IP1 LX1 30
BX7 X1+X7 MERGE NEW INSTRUCTION
SA7 B1
EQ IPACK
*
*
* -ILJUST-
* LEFT JUSTIFY LAST WORD OF INSTRUCTIONS
*
ILJUST EQ *
MX0 15
SA1 B1 LOAD LAST INSTRUCTION WORD
ILJ1 BX2 X0*X1
NZ X2,ILJ2 JUMP IF WORD LEFT-JUSTIFIED
LX1 15
EQ ILJ1
ILJ2 BX6 X1 STORE LEFT-JUSTIFIED WORD
SA6 B1
EQ ILJUST
*
* /--- BLOCK -DO- 00 000 77/04/24 20.24
TITLE -DO- COMMAND
*
*
* -DO- COMMAND (REGULAR JOIN)
*
* THIS COMMAND MAY TAKE THE FOLLOWING FORMS -
* DO UNIT
* DO EXPR,UNIT,UNIT.....UNIT
* DO UNIT,EXPR_EXPR,EXPR,(EXPR)
* DO EXPR,UNIT,UNIT.....UNIT,EXPR_EXPR,EXPR,(EXPR)
* DO EXPR,EXPR_EXPR,EXPR,(EXPR)
*
*
JOININ MX6 -1 MARK -JOIN- COMMAND
SA6 JOINFLG
EQ DOIN1
*
DOIN MX6 0 MARK NOT A -JOIN- COMMAND
SA6 JOINFLG
*
DOIN1 BSS 0
SA1 WORDPT POINTER TO FIRST CHARACTER
MX0 0
CALL PSCAN SCAN PAST FIRST ENTRY
ZR X1,UNCDO
SX1 B1+1 ADVANCE CHARACTER POINTER
SX0 KASSIGN ACCEPT ASSIGNMENT AS TERMINATOR
CALL PSCAN
BX0 X0-X1 CHECK IF ENDED WITH ASSIGNMENT
NZ X0,DOC
SX6 1R, REPLACE ASSIGNMENT WITH COMMA
SA6 B1
EQ DOIT UNCONDITIONAL ITERATED -DO-
*
*
* UNCONDITIONAL -DO- COMMAND
*
UNCDO MX6 0 PRESET TO NO RETURN ARGS
SA6 =XRARGFLG
CALL UNAMA1 PROCESS UNIT NAME
SX0 X6-UNXNUM
ZR X0,ERRXORQ ERROR IF UNIT -X-
SX0 X6-UNQNUM
ZR X0,UNCDOQ SPECIAL FOR UNIT -Q-
LX6 60-12
SX1 DOJ= PRE-SET FOR -DO- COMMAND
SA2 JOINFLG SEE IF -JOIN- COMMAND
+ ZR X2,*+1
SX1 JOIN= SET COMMAND CODE = JOIN
+ BX6 X1+X6
EQ UALTC
*
UNCDOQ SX6 DOJ= GET COMMAND NUMBER
UALTC SA1 =XRARGFLG SEE IF ANY RETURN ARGUMENTS
ZR X1,ALTCODE IF NO RETURN ARGUMENTS
*
SA1 ICX ADD -DO-/-JOIN- COMMAND
SX7 X1-1
SA7 A1
SA6 INFO+X7 STORE COMMAND WORD
SX6 =XDOR= SET CODE FOR RETURN ARGS COMMAND
SA1 JOINFLG
+ ZR X1,*+1 IF -JOIN- COMMAND
*
SX6 =XJOINR=
EQ ALTCODE
*
*
*
* /--- BLOCK -DO- 00 000 76/07/25 06.35
*
*
* CONDITIONAL -DO- COMMAND READIN
*
DOC CALL COMPILE EVALUATE EXPRESSION
BX6 X1
SA6 BRVAR SAVE -GETVAR- CODE
MX6 0
SA6 UBUFF INITIALIZE UNIT COUNT
SA6 ISITER PRE-SET NOT ITERATED CASE
SA6 =XRARGFLG PRESET TO NO RETURN ARGUMENTS
*
DOULP SA1 WORDPT POINTER TO NEXT CHARACTER
SA2 X1
ZR X2,DOEOL JUMP IF END-OF-LINE
SX0 KASSIGN ACCEPT ASSIGNMENT AS TERMINATOR
CALL PSCAN
BX0 X0-X1 SEE IF ENDED WITH ASSIGNMENT
ZR X0,DOCIT
CALL UNAMA1
SA1 UBUFF
SX7 X1+1 INCREMENT UNIT COUNT
SA7 A1
SX1 X1-100 ALLOW 100 UNITS
PL X1,ERR2MNY
SA6 X7+UBUFF STORE THIS UNIT NUMBER
SA1 WORDPT
SA1 X1
NZ X1,DOULP JUMP IF NOT END OF LINE
*
DOEOL SA1 NEXTCOM
SA2 COMCONT CHECK IF CONTINUED
BX2 X1-X2
NZ X2,DOUPACK JUMP IF NOT CONTINUED
CALL GETLINE
EQ DOULP
*
DOCIT MX6 -1 MARK ITERATED -DO-
SA6 ISITER
SX6 1R, REPLACE ASSIGNMENT WITH COMMA
SA6 B1
*
* /--- BLOCK -DO- 00 000 76/07/25 06.36
*
DOUPACK SA1 UBUFF GET NUMBER OF UNITS
ZR X1,ERR2FEW
SB1 X1
SA2 INX INITIALIZE XSTOR POINTER
BX7 X2
SA7 DTABLOC SAVE ADDRESS OF UNIT TABLE
*
DOPACK MX6 0 CLEAR WORD BUILDING
SB2 45 INITIALIZE SHIFT COUNT
*
DOPK1 SB1 B1-1 DECREMENT UNIT COUNT
NG B1,DOPFIN
SA1 A1+1 LOAD NEXT UNIT NUMBER
LX1 X1,B2
BX6 X1+X6 MERGE WITH REST OF WORD
SB2 B2-15
PL B2,DOPK1 JUMP IF WORD NOT FULL
SA6 X7+INFO
SX7 X7+1 INCREMENT XSTOR POINTER
EQ DOPACK
*
DOPFIN SB1 B2-45 SEE IF LAST WORD EMPTY
PL B1,DOPF1
SA6 X7+INFO STORE LAST WORD OF UNIT TABLE
SX7 X7+1
*
DOPF1 SA7 INX UPDATE EXTRA STORAGE POINTER
SA1 DTABLOC
LX1 12+XCMNDL POSITION ADDRESS OF TABLE
SA2 UBUFF
LX2 XCMNDL POSITION NUMBER OF UNITS
BX6 X1+X2
SA1 BRVAR
LX1 60-XCODEL POSITION -GETVAR- CODE
BX6 X1+X6
SA1 ISITER
NZ X1,DOPF2 JUMP IF ITERATED
SX1 DOC= PRE-SET FOR -DO- COMMAND
SA2 JOINFLG
+ ZR X2,*+1 CHECK FOR -JOIN- COMMAND
SX1 JOINC=
+ BX6 X1+X6 ATTACH COMMAND NUMBER
EQ UALTC UPDATE BINARY
*
DOPF2 SA6 X7+INFO SAVE UNIT TABLE INFO IN XSTOR
SX6 7000B
BX6 X6+X7 SET UP SPECIAL FAKE UNIT NUMBER
LX6 48
SA6 VARBUF
SX7 X7+1
SA7 INX UPDATE EXTRA STORAGE INDEX
EQ DOITC PROCESS INDEX EXPRESSIONS
*
* /--- BLOCK -DO- 00 000 76/07/25 06.36
*
*
* UNCONDITIONAL ITERATED -DO- COMMAND READIN
*
DOIT CALL UNAMA1 GET UNIT NUMBER AND ARGS
SX0 X6-UNXNUM
ZR X0,ERRXORQ ERROR IF UNIT -X-
SX0 X6-UNQNUM
ZR X0,ERRXORQ ERROR IF UNIT -Q-
LX6 48 PUT INTO TOP 12 BITS
SA6 VARBUF
*
* CONDITIONAL ITERATED -DO- COMMAND READIN
*
DOITC SX6 DO= PRE-SET FOR -DO- COMMAND
SA1 JOINFLG
+ ZR X1,*+1 CHECK FOR -JOIN- COMMAND
SX6 JDO=
+ SA6 COMNUM SET COMMAND NUMBER
SA1 WORDPT POINTER TO NEXT CHARACTER
BX6 X1
SA6 WPTSAV1 SAVE ADDR OF INDEX EXPRESSION
CALL TAGSAVE SAVE TAG IN ECS
CALL GCOMP DECODE INDEX EXPRESSION
AX1 XCODEAL+2
SX0 2
BX6 X0*X1 MASK OFF I/F BIT
SA6 DOVTYPE
ZR X6,DOIT0 JUMP IF INTEGER INDEX
SA1 COMNUM
SX6 X1+2 INCREMENT COMMAND NUMBER
SA6 A1
*
DOIT0 SX7 10610B
CALL SHORT ADD A BX6 X1
SX7 5160B
LX7 18 ADD A SA6 B0+COMPUSE
SA1 LLCOUSE
BX7 X1+X7 ATTACH ADDRESS OF *COMPUSE*
CALL LONGI
* /--- BLOCK -DO- 00 000 76/07/25 06.38
*
SA1 WORDPT
BX6 X1 SAVE *WORDPT*
SA6 WPTSAV2
MX0 0 NO SPECIAL TERMINATOR
CALL PSCAN
ZR X1,ERRTERM
SX6 B1+1 ADVANCE CHARACTER POINTER
SA6 WORDPT
CALL GCOMP1 EVALUATE END-TEST EXPRESSION
RJ ITFFTI GENERATE I-F F-I INSTRUCTIONS
SX7 10610B
CALL SHORT ADD A BX6 X1
SX7 5160B
LX7 18 ADD A SA6 B0+COMPUSE+1
SA1 LLCOUSE
SX1 X1+1 *COMPUSE* +1
BX7 X1+X7
CALL LONGI
SA1 LASTKEY SEE IF END OF LINE
NZ X1,DOIT1
SX7 7110B FORM A SX1 B0+1
LX7 18
SX6 1
BX7 X6+X7 ASSUMED INCREMENT IS +1
CALL LONGI
MX1 0 SET FOR INTEGER
EQ DOIT2
*
DOIT1 CALL GCOMP1 EVALUATE INCREMENT EXPRESSION
*
DOIT2 RJ ITFFTI GENERATE I-F F-I INSTRUCTIONS
SX7 0100B FORM A RJ DOLOC
LX7 18
SA1 LLDOLOC
BX7 X1+X7 ATTACH ADDRESS OF *DOLOC*
CALL LONGI
CALL PAD FILL OUT REST OF WORD
SA1 WPTSAV1
BX6 X1 SET POINTER TO INDEX EXPRESSION
SA6 WORDPT
CALL TAGREST RESTORE *TAG* BUFFER
CALL PCOMP1 PRODUCE CODE TO STORE X6
SX7 0230B
LX7 18 ADD A JP B3+B0
CALL LONGI
CALL PAD
CALL MOVCODE MOVE COMPILED CODE TO XSTOR
BX6 X0
SA6 VARBUF+1 SAVE ADDRESS OF COMPILED CODE
*
* /--- BLOCK -DO- 00 000 77/04/24 20.25
*
SA1 WPTSAV2 SET POINTER TO INITIAL VALUE
BX6 X1 EXPRESSION
SA6 WORDPT
CALL COMPILE DECODE INITIAL EXPRESSION
BX6 X1
LX6 60-12-18-XCODEL
SA1 VARBUF
BX6 X1+X6 ATTACH UNIT NUMBER
SA1 VARBUF+1
LX1 60-12-18 POSITION ADDRESS OF CODE
BX5 X1+X6
SA4 COMNUM
BX6 X4+X5 ATTACH COMMAND NUMBER
SA1 ICX
SX7 X1-2 UPDATE COMMAND POINTER
SA7 ICX
SA6 X7+INFO+1 STORE 2 COMMAND WORDS
SX4 X4+1
BX6 X4+X5 ATTACH INCREMENTED COMMAND NUM
SA6 X7+INFO
EQ NXTLINE
*
EXT ERRORC,PUTCODE,DATAON=,CALCODE
EXT COMCONT,VARFIN,NXTLINE,ALTCODE
EXT ECSPRTY,KEYTYPE,NKLIST,NKLEND
EXT LNGUNIT,COMPNAM
EXT UNIT=,ARGS=,DO=,DOJ=,DOC=,UNITOP=
EXT JOIN=,JOINC=,JDO=,IEUEND=
EXT ITFFTI,DOVTYPE,ERRCALL
EXT PSCAN,PAUSE2
EXT ERRTAGS,ERRNAME,ERRSTOR
EXT ERRXYTG,ERR2MNY,ERR2FEW
EXT ERRTERM,ERRUARG,ERRVTYP
EXT ERROUTR,ERRCNTD,ERRXORQ
EXT ERRBAL
*
* /--- BLOCK UNIT 00 000 76/11/25 03.26
TITLE UNIT
*
* UNIT COMMAND FORMAT--
* FIRST 12 BITS = NEXT PHYSICAL UNIT
* NEXT 12 = NEXT PHYSICAL UNIT
* NEXT 36 = COMMAND NUMBER
*
*
*
UNITC SB1 FSUNIT -UNIT- FOR PUBLISH TEXT
RJ =XPUBTEXT
SA1 INDENT
NZ X1,=XNOINDT INDENTING IS NOT PERMITTED
CALL GLOBSYM FINISH UP GLOBAL CALC BRANCHES
CALL ULONG CHECK FOR UNIT TOO LONG
CALL SETARO,B0 PSEUDO -ENDARROW-
CALL UNAM1 PROCESS UNIT NAME
SX2 X6-UNXNUM CHECK FOR ILLEGAL UNIT -X-
ZR X2,UNITCF JUMP IF UNIT X
SX2 X6-UNQNUM CHECK FOR ILLEGAL UNIT -Q-
ZR X2,UNITCF JUMP IF UNIT Q
SA1 X6+ULOC
PL X1,UNITCE ERROR IF DUPLICATE UNIT
*
RJ =XUNITLOC LOG UNIT NAME/LOCATION
SA1 UNUMON
SX2 X1-IEUNUM SEE IF INITIAL ENTRY UNIT
NZ X2,UNI10
SA2 ICX GET COMMAND POINTER
SX2 X2-1
SA3 INX
IX3 X3-X2 CHECK FOR UNIT TOO LONG
PL X3,LNGUNIT
BX7 X2
SA7 A2 UPDATE FOR -IEUEND- COMMAND
SX7 IEUEND=
SA7 X2+INFO ADD AN -IEUEND- COMMAND
*
UNI10 IX7 X6-X1 UNIT A CONTAINING UNIT A
ZR X7,UNITCE DUPLICATE UNIT NAME
SA6 A1 SET UNIT WORKING ON POINTER
*
MX7 1 SET THAT A UNIT FOUND
SA7 NOUNIT
*
* /--- BLOCK UNIT 00 000 81/07/16 04.19
*
MX6 0 FLAG AS UNIT
*
SA1 COMNUM GET COMMAND NUMBER
SX3 UNITOP= GET NUMBER OF UNITOP
BX3 X1-X3
NZ X3,UDONE
MX6 1 IF UNITOP, SET UNITOP BIT
LX6 58
*
*
* FINISH UP CURRENT UNIT
*
UDONE SA6 NUEFLAG SAVE NEW UEFLAG
NG X6,UDONE10 IF -ENTRY-
*
SA1 LOCAL
ZR X1,UDONE10 IF NO LOCAL DEFINE SET TO PURGE
*
SX6 1 PURGE LOCAL SET/REACTIVATE GSET
SA6 OVARG1
EXEC DEFOV RETURN TO *UDONE10*
*
UDONE10 SA1 NUEFLAG
BX6 X1 X6 = UEFLAG FOR UWRITE
CALL UWRITE WRITE UNIT TO ECS
*
SA1 CUNITS INCREMENT NUMBER OF UNITS/ENTRIES
SX6 X1+1
SA6 A1
*
* INITIALIZE FOR NEW UNIT
*
SA1 LINENUM SAVE LINE AND BLOCK NUMBERS
SA2 BLKNUM IN CASE OF ERRORS
BX6 X1
BX7 X2
SA6 =XULINENM
SA7 =XUBLKNM
*
SX7 INFOLTH
SA7 ICX INITIALIZE COMMAND POINTER
SX7 -1
SA7 ANSABUF INITIALIZE ANSWERA BUFFER BIAS
SX7 0
SA7 INX INITIALIZE XSTOR POINTER
SA7 NGLOBAL NUMBER OF GLOBAL SYMBOLS
SA7 NDOOFF NUMBER OF DEFERRED -DOTO-
SA7 DOBFPNT -DOTO- ECS POINTER
SA7 NDEFERR NUMBER OF DEFERRED REFERENCES
SA7 =XNLABELS NUMBER OF LABELS
SA7 GSYMERR1 GLOBAL SYMBOL ERROR FLAGS
SA7 GSYMERR2
SA1 NUEFLAG X1 = -UNIT-/-ENTRY- FLAG
NG X1,UDONE20 IF -ENTRY-
*
SA7 LOCAL FLAG END OF LOCAL SET ACTIVITY
SA7 LVARN NUMBER OF LOCAL VARIABLES
SA1 CONTFLG X1 = CONTINUATION FLAG
PL X1,UDONE20 IF NO LOCAL SET
*
SX6 1 FLAG LOCAL SET PROCESSING
SA6 LOCAL
MX6 0
SA6 OVARG1
EXEC DEFOV PROCESS LOCAL SET
*
* RETURN TO UDONE20
* /--- BLOCK UNIT 00 000 80/03/28 00.28
*
UDONE20 SA1 COMMAND SAVE COMMAND NAME
BX6 X1
SA6 =XCMNDTMP
SA1 UNITCMD SET COMMAND = UNIT
SA2 NUEFLAG X2 = -1 IF -ENTRY
PL X2,UDONE25 IF -UNIT- COMMAND
*
SA1 NTRYCMD SET COMMAND = ENTRY
UDONE25 BX6 X1
SA6 COMMAND
MX6 -1
SA6 UNITFLG FLAG -UNIT- COMMAND
CALL UNAM2 PROCESS ANY ARGUMENTS
SA1 =XCMNDTMP X1 = SAVED COMMAND NAME
BX6 X1
SA6 COMMAND RESTORE COMMAND NAME
MX6 0
SA6 A1 ZERO CMNDTMP
SA1 LOCAL
ZR X1,UDONE30
*
SA1 NUEFLAG
NG X1,UDONE30 IF -ENTRY- IN LOCALS UNIT
*
RJ =XRSTRTAG RESTORE TAG AFTER LOCAL SET
SA1 VARBUF
ZR X1,=XNXTC EXIT IF NO ARGUMENTS
EQ UDONE40
*
UDONE30 BSS 0
SA1 VARBUF
ZR X1,NXTLINE EXIT IF NO ARGUMENTS
*
* /--- BLOCK UNIT 00 000 80/03/28 00.24
UDONE40 SA2 UEFLAG SET ARGS BIT IN UNAM TABLE WORD
MX7 1
LX7 59
BX7 X2+X7 COMBINE WITH UNIT/ENTRY FLAG
SA7 A2
*
CALL APACK PACK UP -GETVAR- CODES
MX0 -10
BX6 -X0*X6 MASK OFF EXTRA STORAGE POINTER
LX6 48
SX1 ARGS= SET CODE FOR -ARG- COMMAND
BX6 X1+X6
SA2 NUEFLAG
NG X2,ALTCODE IF -ENTRY- COMMAND
*
SA2 LOCAL
NZ X2,=XALTCOD1 SPECIAL ALTCODE FOR LOCAL VARS
*
EQ ALTCODE
*
UNITCE SB1 71 DUPLICATE UNIT NAME
EQ =XERR
UNITCF SB1 72 UNIT NAME MAY NOT BE -X- OR -Q-
EQ =XERR
*
UNITCMD DATA 8LUNIT
NTRYCMD DATA 8LENTRY
* /--- BLOCK UWRITE 00 000 77/04/21 21.25
TITLE -UWRITE-
*
* -UWRITE- WRITE LAST UNIT TO ECS
*
UWRITE EQ *
SA3 UEFLAG GET FLAG FOR PREVIOUS UNIT
SA6 A3 SAVE FLAG FOR NEXT UNIT
SA1 UNIT GET CURRENT UNIT NUMBER
SA0 ABEND WORK BUFFER
SA2 AUNAME GET UNORDERED UNIT NAME TABLE
IX0 X1+X2 GET ENTRY OF CURRENT UNIT
+ RE 1
RJ ECSPRTY
SA2 A0 READ UP UNIT NAME
BX6 X2+X3 ADD IN BITS FOR'; ENTRY, ARGS
SA1 UNUMON GET NEXT UNIT NUMBER
LX1 48
BX6 X1+X6 PUT TOGETHER
SA6 A0
+ WE 1 AND OUT TO TABLE
RJ ECSPRTY
*
* FOR FOLLOWING...
* X0 HOLDS BINARY INSERT POINTER
* X3 HOLDS FORMING TOTAL LENGTH OF UNIT
* X6 HOLDS THE DEVELOPING UNIT-LOC WORD
*
* THE FORMAT OF THE UNIT LOCATION INFO WORD IS...
* ULOC1 BITS RELATIVE BIAS TO UNIT IN BINARY
* ULOC2 BITS LENGTH OF CENTRAL MEMORY PART OF UNIT
* ULOC3 BITS NUMBER OF COMMANDS IN UNIT
* ULOC4 BITS TOTAL LENGTH OF UNIT (CM PART PLUS ECS RES PART)
* ULOC5 BITS NUMBER OF LOCAL VARS IN UNIT
*
*
SA1 CONBUFF GET ADDRESS OF CONDENSE BUFFER
SA2 CONDPNT CURRENT PLACE IN THIS BUFFER
IX6 X2-X1 GET RELATIVE ADDRESS OF START OF UNIT
LX6 60-ULOC1 AND PUT INTO ULOC WORD-A-MAKING
BX0 X2 POINT AT WHICH TO INSERT IN BINARY
*
SA1 ICX
SA0 X1+INFO CM ADDRESS OF COMMANDS
SX4 INFOLTH
IX2 X4-X1 GET NUMBER OF COMMANDS
BX3 X2
BX5 X2
LX5 60-ULOC1-ULOC2-ULOC3 POSITION FOR ULOC WORD
BX6 X6+X5 ADD NUMBER OF COMMANDS TO ULOC WORD
NG X2,LNGUNIT TEST FOR UNIT TOO LONG
CALL WRITECS WRITE COMMANDS TO BINARY-A-FORMING
*
SA2 INX GET LENGTH OF EXTRA STORAGE
SA0 INFO CM ADDRESS OF EXTRA STORAGE
IX3 X3+X2 ADD CM ARGS LENGTH TO FORMING TOTAL LENGTH
BX4 X3
* /--- BLOCK UWRITE 00 000 77/04/21 21.25
LX4 60-ULOC1-ULOC2 PUT CM RES TOTAL LENGTH IN PLACE FOR
BX6 X6+X4 ADDING TO FORMING UNIT LOC WORD
CALL WRITECS PUT CM RES ARGS TO BINARY-A-FORMING
* /--- BLOCK UWRITE 00 000 77/03/31 17.49
*
SA4 ECSARGS GET NUMBER OF ECS RESIDENT ARGS
*
IX3 X3+X4 ADD AMOUNT TO TOTAL LENGTH OF UNIT
*
LX3 60-ULOC1-ULOC2-ULOC3-ULOC4 POSITION
BX6 X6+X3 ADD TOTAL LENGTH TO UNIT-LOC WORD
*
SA1 LVARN X1 = NUMBER OF LOCALS IN UNIT
LX1 60-ULOC1-ULOC2-ULOC3-ULOC4-ULOC5
BX6 X6+X1 X6 = ULOC ENTRY + LVARN
*
SA1 ECSRESB GET START OF ECS ARGS BUFFER
SA0 INFO USE CM WORK BUF
* COULD USE -WORK- AND -WORKLTH- FOR BIGGER TRANSFER BUFFERS
*
UWTOP ZR X4,UWDONE START OF LOOP TO RELOCATE ECS RES PART
BX7 X0 SAVE CURRENT INSERT POINTER IN BINARY
BX2 X4 LENGTH OF ECS RES PART OF UNIT
SX4 X4-INFOLTH SEE IF WILL FIT INTO CM BUFFER
BX0 X1 GET CONDENSOR ADDRESS OF ECS RES PART OF U
NG X4,UWMID SEE IF CAN DO IN ONE PASS
SX2 INFOLTH ELSE JUST DO CM BUFFER LENGTH
UWMID SB1 X2 NOW TRANSFER TO CM
+ RE B1
RJ ECSPRTY
IX1 X0+X2 AUGMENT ECS RES ADDRESS FOR NEXT MOVE
BX0 X7 GET CURRENT INSERT PLACE IN BINARY
CALL WRITECS MOVE INTO BINARY
PL X4,UWTOP SEE IF EVERYTHING TRANSFERRED
*
*
UWDONE BX7 X0 UPDATE POINTER OF CURRENT PLACE
SA7 CONDPNT MATERIAL IS BEING ADDED TO BINARY
SA1 UNIT
SA6 X1+ULOC PUT OUT THIS UNIT-LOC INFORMATION
SA2 UNUMON
BX6 X2
SA6 A1 SET NEXT UNIT NUMBER
MX6 0
SA6 ECSARGS INITIALIZE ECS ARGS TO ZERO
EQ UWRITE
*
*
* /--- BLOCK UNAMA 00 000 73/00/00 00.00
TITLE -UNAMA-
*
*
* -UNAMA-
* UNIT NAME AND ARGUMENT PROCESSOR
*
* RETURNS WITH X6 = UNIT NUMBER
* VARBUF(0) = NUMBER OF ARGUMENTS
* VARBUF(N) = -GETVAR- CODES FOR ARGUMENTS
*
*
UNAMA EQ *
CALL UNAM1 PROCESS UNIT NAME
CALL UNAM2 PROCESS ARGUMENTS
EQ UNAMA
*
*
* /--- BLOCK UNAM1 00 000 76/07/25 06.40
TITLE -UNAM1-
*
*
* -UNAM1-
* COLLECT UNIT NAME AND CHECK FOR ARGUMENTS
*
* RETURNS X6 = UNIT NUMBER
* *UARGS* = -1 IF ARGUMENTS
* 0 IF NO ARGUMENTS
*
*
UNAM1 EQ *
SA1 WORDPT POINTER TO FIRST CHARACTER
SB1 X1-1
SB2 60-6 INITIALIZE SHIFT COUNT
MX6 0 INITIALIZE NAME BUILDING
SA6 UNITFLG CLEAR -UNIT- FLAG
*
UNLP SB1 B1+1 ADVANCE CHARACTER POINTER
SA1 B1 LOAD NEXT CHARACTER
SX2 X1-1R
NZ X2,UNLP0 JUMP IF NOT SPACE
ZR X6,UNLP JUMP IF LEADING SPACE(S)
SB3 B2-7
NG B3,UNLP POSSIBLE TRAILING SPACES
*
UNLP0 ZR X1,UNAGOT
SA2 X1+KEYTYPE
NG X2,UNLP1 JUMP IF ALPHANUMERIC
ZR X2,UNLP1
SX3 X2-OPCOMMA CHECK FOR COMMA
ZR X3,UNAGOT1
SX3 X2-OP( CHECK FOR RIGHT PAREN
ZR X3,UNAGOT2
SX3 X2-OP) CHECK FOR LEFT PAREN
ZR X3,ERRTERM
*
UNLP1 LX1 X1,B2 POSITION THIS CHARACTER
BX6 X1+X6 MERGE WITH REST OF WORD
SB2 B2-6
PL B2,UNLP
EQ ERRNAME
* /--- BLOCK UNAM1 00 000 76/07/25 06.41
*
UNAGOT SX7 B1 UPDATE *WORDPT*
SA7 WORDPT
MX7 0 MARK NO ARGUMENTS
EQ UAGOT
*
UNAGOT1 SX7 B1+1 UPDATE *WORDPT*
SA7 WORDPT
MX7 0 MARK NO ARGUMENTS
EQ UAGOT
*
UNAGOT2 SX7 B1+1 UPDATE *WORDPT*
SA7 WORDPT
MX7 -1 MARK ARGUMENTS TO UNIT
*
UAGOT ZR X6,ERRNAME ERROR IF ZERO NAME
SA7 UARGS
BX7 X1 SAVE TERMINATOR IN *LASTKEY*
SA7 LASTKEY
BX1 X6 SET UP FOR -LJUST-
CALL LJUST,(1R ),0
MX0 -12
BX0 -X0*X1 CHECK IF NAME TOO LONG
NZ X0,ERRNAME
BX6 X1 ZERO FILLED NAME
SA2 UNX X2 = L.J. X
BX2 X6-X2
ZR X2,UAX
SA2 UNQ X2 = L.J. Q
BX2 X6-X2
ZR X2,UAQ
LX6 48 POSITION UNIT NAME
CALL UNAMX FIND OR ADD TO UNIT TABLE
SA6 AUNUM SAVE UNIT NUMBER
EQ UNAM1
*
UAX SX6 UNXNUM SET FOR UNIT -X-
EQ UAXQ
*
UAQ SX6 UNQNUM SET FOR UNIT -Q-
UAXQ SA6 AUNUM
SA2 UARGS
ZR X2,UNAM1 JUMP IF NO ARGUMENTS
EQ ERRUARG
*
* /--- BLOCK UNAM2 00 000 81/01/08 01.10
TITLE -UNAM2-
*
* -UNAM2-
* PROCESS ARGUMENTS OF UNIT
*
* RETURNS X6 = UNIT NUMBER
* *VARBUF(0)* = NUMBER OF ARGUMENTS
* *VARBUF(N)* = -GETVAR- CODES
*
UNAM2 EQ *
MX0 0 FOR ARGS ENDING AT EOL
RJ UNAM2A
EQ UNAM2
*
UNAM2A EQ *
MX6 0 INITIALIZE ARGUMENT COUNT
SA6 VARBUF
SA1 UARGS SEE IF ANY ARGUMENTS
ZR X1,UN290
SA1 WORDPT
NG X0,UNA0 IF PROCESSING (PBV;RBV)
*
SX1 X1-1 BACK UP ONE CHARACTER
CALL PSCAN FIND END OF ARGUMENT(S)
NZ B2,ERRBAL ERROR IF UNBALANCED PARENS
NZ B3,ERRBAL ERROR IF UNBALANCED QUOTES
EQ UNA1
*
UNA00 SX1 B1+1 SKIP COMMA
UNA0 CALL PSCAN
SB2 B2+1
ZR B2,UNA01 IF TERMINATED WITH )
*
SX3 X1-1R,
ZR X3,UNA00 IF , DELIMITER
*
SX3 X1-1R;
NZ X3,ERRTERM IF BAD TERMINATOR
*
BX6 X1 SAVE TERMINATOR KEY
SA6 ARGKEY
EQ UN100
*
UNA01 SB1 B1+1
EQ UNA1
*
*
* REMOVE TRAILING SPACES
*
UNA1 SA3 B1-1
SX6 X3-1R
NZ X6,UNA2 NOT A SPACE
SB1 B1-1
EQ UNA1 CONTINUE BACKSPACING
UNA2 BX6 X3 SAVE TERMINATOR KEY
SA6 ARGKEY
SA3 X3+KEYTYPE CHECK ENDED WITH RIGHT PAREN
SX3 X3-OP)
NZ X3,ERRTERM
SX6 1R REPLACE RIGHT PAREN WITH SPACE
SA6 B1-1
UN100 SX6 B1
SA6 ENDPNT
*
CALL GETARGS PROCESS ARGUMENTS
*
UN290 SA1 AUNUM RETURN UNIT NUMBER IN X6
BX6 X1
EQ UNAM2A
*
*
ABEND BSS 1
KCOMM DATA 0LCOMMON
KLESS DATA 0LLESSON
UNX DATA 1LX
UNQ DATA 1LQ
* /--- BLOCK FINIS 00 000 81/07/20 21.33
TITLE FINIS
*
* FINIS (CODE=50)
*
* END OF LESSON PROCESSING
*
*
FINISC CALL GLOBSYM FINISH UP GLOBAL CALC BRANCHES
CALL ULONG CHECK FOR UNIT TOO LONG
CALL SETARO,B0 PSEUDO -ENDARROW-
*
SA1 NOUNIT SEE IF ANY UNIT FOUND
NZ X1,FINON8 NON-ZERO MEANS UNIT FOUND ELSE MUST
SA1 UNUMON CREATE A DUMMY UNIT AFTER THE IEU
* THIS FIX ALLOWS A LESSON WITHOUT ANY
* UNITS TO APPEAR AS A ONE UNIT LESSON
* AND EXECUTE.
SX2 X1-IEUNUM SEE IF DOING INITIAL ENTRY UNIT
NZ X2,FINON5 ELSE MUST HAVE PASSED AN ENTRY COMMAND
SA2 ICX GET COMMAND POINTER
SX2 X2-1
SA3 INX
IX3 X3-X2 CHECK FOR UNIT TOO LONG
PL X3,LNGUNIT GIVE FATAL CONDENSE ERROR
BX7 X2
SA7 A2 UPDATE FOR -IEUEND- COMMAND
SX7 IEUEND=
SA7 X2+INFO ADD AN -IEUEND- COMMAND
*
FINON5 SA1 UNUMIN GET LAST UNIT REFERENCED
SX7 X1+1 INCREMENT BY 1
SX2 X7-UTABLTH ERROR TEST IF TOO MANY UNITS
PL X2,=XBADIEU --- FATAL CONDENSE ERROR
*
SA7 A1 UPDATE NUMBER OF UNITS
MX7 0 AND ZERO UNIT-LOCATION TABLE
SA7 ULOC+X1
SX7 3RNOU SET TO NO UNIT
LX7 30 LEFT-ADJUST UNIT NAME
SA7 UNAME+X1 STORE IN UNIT NAME TABLE
SA0 A7 AND PUT INTO NON-ALPHABETIZED TABLE
SA2 AUNAME GET ADDRESS OF TABLE IN ECS
IX0 X2+X1 NOW HAVE UNIT ENTRY
+ WE 1 WRITE OUT UNIT NAME
RJ ECSPRTY
BX6 X1
SA6 UNUMON AND SET THIS TO CURRENT UNIT
EQ FINON9 FOR -UWRITE- TO PLUCK INTO UNAME TABLE
*
* PUT LAST UNIT INTO ECS
*
FINON8 MX6 0 CLEAR TO END CHAIN IN UNIT NAME TABLE
SA6 UNUMON
*
FINON9 CALL UWRITE
RETURN
TITLE COMPLETE PREVIOUS CPU UNIT
* /--- BLOCK PINIT 00 000 81/07/21 03.05
* COMPLETE PREVIOUS CPU UNIT
*
* FOLLOWING ENTERED DIRECTLY FROM OVERLAY CALL
* JUMP TABLE AT BEGINNING OF FILE. COMPLETES
* PREVIOUS CPU UNIT BEFORE BEGINNING CONDENSE OF
* ^MTUTOR UNITS. CALLED ON FINDING ^MTUTOR COMMAND.
*
PINIT SA1 NOUNIT CHECK IF PREVIOUS CPU UNIT
NZ X1,PINIT1 IF PREVIOUS CPU UNIT PRESENT
SB1 152
EQ =XERR
PINIT1 BSS 0
CALL GLOBSYM SATISFY GLOBAL CALC BRANCHES
CALL ULONG CHECK FOR UNIT TOO LONG
CALL SETARO,B0 PSEUDO -ENDARROW-
MX6 0
SA6 UNUMON MARK LAST CPU UNIT
CALL UWRITE WRITE UNIT TO ECS
*
* SETUP PPTVERS FOR LEVEL 1 MICROTUTOR - CHECK
* CAN BE TAKEN OUT WHEN LEVEL 1 IS GONE.
*
*
* SET UP PPTVERS INFO - USED TO BE IN MTUTC
* PPTVERS = 0 FOR PRIMITIVE
* 2 FOR -PPTVERS CUT22
*
SA1 COMMAND
SA2 =XMTUTNAM
BX0 X1-X2 CHECK COMMAND NAME = ^MTUTOR
ZR X0,MTUTORC
SA1 MTREL
SX0 X1-1 PRIMITIVE ONLY ALLOWED IN LEV 1
NZ X0,MTERR IF NOT LEVEL 1
MX6 0
SA6 PPTVERS SET FOR PRIMITIVE VERSION
EQ =XMTLOAD
*
* PRIMITIVE LEVEL IS NOT ALLOWED IN RELEASE > 1
*
MTERR SB1 123 PRIMITIVE LEVEL NOT ALLOWED
RJ =XRJERR
EQ =XMTFIN
*
MTUTORC SX6 2 FORCE NON-PRIMITIVE VERSION
SA6 PPTVERS
EQ =XMTLOAD
* /--- BLOCK ENTRY 00 000 80/02/15 22.08
TITLE ENTRY
* -ENTRY- (CODE=67)
*
* USED FOR WITHIN AND BETWEEN UNIT BRANCHING.
* THIS COMMAND FINISHES UP THE CURRENT UNIT AND STARTS A NEW
* ONE WITH THE NAME SPECIFIED IN THE TAG. THE -ENTRY-
* COMMAND ITSELF FUNCTIONS LIKE A -GOTO- THAT IS LEGAL IN
* ALL CONTINGENCIES--THUS THE TWO UNITS BEHAVE AS ONE.
*
* -ENTRY- COMMAND FORMAT
* FIRST 12 BITS = ENTRY UNIT
* NEXT 12 = NEXT PHYSICAL UNIT
* NEXT 36 = COMMAND NUMBER
*
*
ENTRYIN SA1 INDENT
NZ X1,NOINDT INDENTING IS NOT PERMITTED
CALL GLOBSYM FINISH UP GLOBAL CALC BRANCHES
CALL ULONG CHECK FOR UNIT TOO LONG
CALL SETARO,B0 PSEUDO -ENDARROW-
CALL UNAM1 GET UNIT NUMBER
SX2 X6-UNXNUM CHECK FOR ILLEGAL UNIT -X-
ZR X2,UNITCF JUMP IF ENTRY -X-
SX2 X6-UNQNUM CHECK FOR ILLEGAL UNIT -Q-
ZR X2,UNITCF JUMP IF ENTRY -Q-
SA1 X6+ULOC
PL X1,UNITCE ERROR IF DUPLICATE ENTRY
*
RJ =XUNITLOC LOG ENTRY COMMAND LOCATION
SA1 UNUMON
SX2 X1-IEUNUM SEE IF INITIAL ENTRY UNIT
NZ X2,ENTRY10
SA2 ICX GET COMMAND POINTER
SX2 X2-1
BX7 X2
SA7 A2 UPDATE FOR -IEUEND- COMMAND
SX7 IEUEND=
SA7 X2+INFO ADD AN -IEUEND- COMMAND
*
ENTRY10 IX7 X6-X1 CHECK FOR UNIT ZONK CONTAINING UNIT ZONK
ZR X7,UNITCE DUPLICATE ENTRY NAME
SA6 A1 SET UNIT WORKING ON POINTER
SA2 ICX GET CURRENT COMMAND STORAGE LOC
SX7 X2-1
SA7 A2 RETURN CURRENT COMMAND COUNTER
LX6 48 SHIFT UNIT NUMBER TO TOP 12 BITS
SA1 COMNUM X1 = COMMAND NUMBER
BX6 X6+X1
SA6 INFO+X7 STORE -ENTRY- COMMAND
*
MX6 1 FLAG AS ENTRY UNIT
EQ UDONE AND GO TO FINISH UNIT
* /--- BLOCK -INITIAL- 00 000 79/01/23 02.44
TITLE -INITIAL- COMMAND
*
*
*
* INITIAL LESSON,UNIT
* INITIAL COMMON,UNIT
*
* EXECUTES SPECIFIED UNIT IF LESSON OR COMMON HAS
* NOT BEEN INITIALIZED
*
*
INITC CALL NXTNAM GET FIRST ENTRY
ZR X6,ERRNAME
MX7 0 INITIALIZE TYPE
SA1 KLESS
BX1 X1-X6 CHECK IF *LESSON*
ZR X1,INITC1
SX7 X7+1 INCREMENT TYPE
SA1 KCOMM
BX1 X1-X6 CHECK IF *COMMON*
NZ X1,ERRNAME
*
INITC1 LX7 60-12-18 POSITION TYPE CODE
SA7 SHOWOUT
CALL UNAMA GET UNIT NUMBER TO X6
SX0 X6-UNXNUM CHECK FOR UNIT -X-
ZR X0,ERRXORQ
SX0 X6-UNQNUM CHECK FOR UNIT -Q-
ZR X0,ERRXORQ
CALL APACK
LX6 48 POSITION UNIT NUMBER
SA1 SHOWOUT
BX4 X1+X6 ATTACH TYPE CODE
SA1 COMNUM
BX6 X1+X4 ATTACH COMMAND NUMBER
SA2 ICX
SX7 X2-1 DECREMENT COMMAND INDEX
SA7 A2
SA6 X7+INFO STORE COMPLETED COMMAND WORD
SX1 X1+1 INCREMENT COMMAND NUMBER
BX6 X1+X4
EQ ALTCODE STORE SECOND COMMAND
*
* /--- BLOCK ROUTEC 00 000 84/01/25 12.32
TITLE -ROUTE-
*
* -ROUTE- COMMAND
*
* SPECIFIES ROUTER EXITS FOR VARIOUS EXIT CONDITIONS
*
* POSSIBLE EXIT TYPES -- 0 (FINISH)
* 1 (END LESSON)
* 2 (ERROR)
* 3 (RESIGNON)
* 4 (CLEAR)
*
* RESIGNON HAS OPTIONAL SECOND ARGUMENT (UNIT), ALL
* OTHER TYPES REQUIRE UNIT SPECIFICATION.
*
ROUTEC BSS 0
SA1 LESSON NAME OF LESSON BEING CONDENSED
SA2 KPLATO LESSON *PLATO*
SA3 KNPLATO LESSON *NPLATO*
BX2 X1-X2 COMPARE CURRENT WITH *PLATO*
BX3 X1-X3 COMPARE CURRENT WITH *NPLATO*
ZR X2,ROUTEC0 -- OK IF LESSON *PLATO*
ZR X3,ROUTEC0 -- OK IF LESSON *NPLATO*
SA1 ROUTER CHECK FOR ROUTER LESSON STATUS
ZR X1,ERRORC -- NOT A ROUTER, FLAG AS ERROR
ROUTEC0 BSS 0
*
* GET FIRST ARGUMENT AND CHECK IT FOR VALIDITY
*
CALL NXTNAME LIT STRING IN X6, DELIM IN X2
SA1 RLIST-1 THEN SEARCH *RLIST* FOR STRING
RLOOK SA1 A1+1 READ NEXT ENTRY IN ROUTE TYPES
ZR X1,ERRNAME -- END OF TABLE, NOT FOUND
BX1 X1-X6 COMPARE WITH LITERAL STRING
NZ X1,RLOOK -- NO MATCH, KEEP SEARCHING
SX1 A1-RLIST ELSE COMPUTE INDEX INTO RLIST
BX6 X1 LEAVE -ROUTE- TYPE IN X1
LX6 60-6 THEN MOVE IT TO HIGH ORDER 6
SA6 ILOC SAVE IT FOR MERGE INTO COMMAND
*
* CHECK DELIMITER FOR SECOND ARGUMENT
*
SX0 X2-EOL CHECK FOR SINGLE ARGUMENT
ZR X0,ROUTEC2
SX0 X2-OPCOMMA MUST END WITH COMMA OR EQUIV
NZ X0,ERRTERM
*
* GET UNIT ARGUMENT AND CHECK FOR SPECIAL UNITS
*
MX3 0
CALL UNAM1 GET UNIT NUMBER
SA2 UARGS MAKE SURE NO ARGUMENTS
NZ X2,ERRUARG
SX0 X6-UNXNUM CHECK FOR UNIT -X-
ZR X0,ERRXORQ -- ERROR, -X- NOT LEGAL
SX0 X6-UNQNUM CHECK FOR UNIT -Q-
NZ X0,ROUTEC1 -- GO AHEAD, NOT -Q-
MX6 0 UNIT -Q- = UNIT NUMBER 0
*
* ASSEMBLE COMMAND WORD WITH TAGS
*
ROUTEC1 LX6 60-6-12
SA1 ILOC GET TYPE CODE
BX6 X1+X6 AND ATTACH IT
EQ PUTCODE ADD COMMAND CODE AND STORE
* /--- BLOCK ROUTEC 00 000 84/01/25 12.30
*
* PROCESS SINGLE ARGUMENT -ROUTE-
*
ROUTEC2 BSS 0
SX6 0 UNIT '7Q'7 FOR SINGLE TAG
SX0 X1-3 CHECK FOR '7RESIGNON'7
ZR X0,ROUTEC1 --- FINISH TAG IF RESIGNON
*
SX0 X1-4 CHECK FOR '7CLEAR'7
NZ X0,ERRORC --- MUST BE A 2-ARG WITH ONLY 1
SA1 ROUTER CHECK ROUTER STATUS
NZ X1,ERRORC -- ERROR, (N)PLATO ONLY
EQ ROUTEC1 --- WRAP-UP COMMAND WORD
*
* TABLE OF POSSIBLE -ROUTE- TYPES
*
RLIST DATA 6LFINISH
DATA 10LEND LESSON
DATA 5LERROR
DATA 8LRESIGNON
DATA 5LCLEAR
DATA 0
*
KPLATO DATA 5LPLATO
KNPLATO DATA 6LNPLATO
*
ILOC BSS 1 FOR SAVING ROUTE TYPE
*
* /--- BLOCK TIMERC 00 000 81/01/08 01.06
TITLE TIMER, TIMEL
*
*
* -TIMER-
* SPECIFIES SECONDS AND UNIT TO RETURN TO AFTER
* THOSE SECONDS ARE UP.
*
* -TIMEL-
* SPECIFIES SECONDS AND UNIT TO GOTO AFTER
* THOSE SECONDS ARE UP.
*
*
TIMERC SA1 ROUTER MUST BE -ROUTER- LESSON
ZR X1,ERROUTR
TIMELC SA1 TAGCNT SEE IF BLANK TAG
ZR X1,PAUSE2 IF BLANK, TURN OFF TIMING
RJ COMPILE OTHERWISE GET CODE FOR TIME
BX6 X1 SAVE -GETVAR- CODE
SA6 BRVAR
MX3 0
CALL UNAM1 GET UNIT NUMBER
SA2 UARGS MAKE SURE NO ARGS
NZ X2,ERRUARG
SX0 X6-UNXNUM
ZR X0,ERRXORQ ERROR IF UNIT -X-
SX0 X6-UNQNUM
ZR X0,ERRXORQ ERROR IF UNIT -Q-
SA1 BRVAR RETREIVE -GETVAR- CODE
LX6 60-XCODEL PLACE UNIT NO IN TOP
LX1 60-2*XCODEL AND GETVAR IN SECOND
BX6 X6+X1
EQ PUTCODE
*
BRVAR BSS 1
*
* /--- BLOCK RETURN 00 000 81/01/08 01.08
*
* -RETURN- COMMAND
*
*
RETIN1 SA1 FLEVEL X1 = FILE UPDATE LEVEL
SX1 X1-5
PL X1,RETIN2 -- BRANCH IF NEW -RETURN-
*
SA1 =XBRKCMD FAKE -BREAK- COMMAND
BX6 X1
SA6 COMMAND
EQ NXTC
*
RETIN SA1 FLEVEL X1 = UPDATE LEVEL
SX1 X1-4
NZ X1,ERRORC IF -NRET- NO LONGER LEGAL
*
RETIN2 SA2 WORDPT X2 = ADDR OF FIRST WORD OF TAG
SA1 TAGCNT NUMBER OF CHARACTERS IN TAG
IX6 X1+X2 ADDR OF EOL
SA6 =XENDPNT
MX6 0
SA6 VARBUF
SA6 =XUNITFLG FLAG NOT A UNIT TYPE ARG LIST
ZR X1,RETIN10 IF BLANK TAG
*
CALL GETARGS PROCESS ARGUMENT LIST
MX6 0 INITIALIZE X6 FOR APACK
CALL APACK PACK UP THE ARGUMENTS
LX6 61-12
AX6 1 CLEAR TOP BIT
EQ PUTCODE
RETIN10 MX6 1 NO ARGS; SET TOP BIT
EQ PUTCODE
*
* -UNAMA1-
*
* GET UNIT AND ARGUMENTS FOR -DO-
*
* ON EXIT RARGFLG = -1 IF RARGS ENCOUNTERED
* UNCHANGED IF NOT
* X6 = COMMAND WORD WITHOUT COMMAND NUMBER
*
UNAMAZZ SA1 DOCWORD RESTORE THE COMMAND WORD
BX6 X1
UNAMA1 EQ *
CALL UNAM1 PROCESS UNIT NAME
MX0 -1 SET TO LOOK FOR (;;) SYNTAX
CALL UNAM2A
CALL APACK PACK UP ANY ARGUMENTS
SA6 DOCWORD SAVE THE COMMAND WORD FOR -DO-
SA1 =XUARGS
ZR X1,UNAMAZZ IF NO ARGUMENTS
* /--- BLOCK RETURN 00 000 81/01/08 01.07
*
SA1 =XARGKEY CHECK FOR RETURN ARGUMENTS
SX2 X1-1R;
NZ X2,UNAMAZZ IF NO RETURN ARGUMENTS
*
SA1 ENDPNT CHECK FOR EOL
SA1 X1+1
NZ X1,UNAMA10 IF NOT EOL
*
SA2 CONTFLG
PL X2,UNAMAZZ IF NOT CONTINUED
*
CALL GETLINE RARGS MIGHT BE ON NEXT LINE
UNAMA10 BSS 0
SX6 1R( FAKE NORMAL CBV ARG LIST
SA6 A1-1
SX6 -1 INDICATE RARGS ENCOUNTERED
SA6 =XRARGFLG
* SA1 WORDPT INCREMENT WORDPT
* IX6 X1-X6
* SA6 A1
SX6 2000B CODE FOR RETURN ARGUMENTS
SA1 DOCWORD
BX6 X6+X1
SA6 A1
SA6 =XUNITFLG
SA1 INX SAVE CURRENT INX POINTER
SX6 X1+1 RESERVE POINTER TO RARGS
SA6 A1
BX6 X1
SA6 SAVINX
CALL UNAM2 PROCESS REST OF ARGUMENTS
SA1 INX X1 = PTR TO RARGS
SX7 X1
SA2 SAVINX X2 = ADDR OF PTR TO RARGS
SA7 X2+INFO
CALL APACK PACK THE ARGS UP
EQ UNAMAZZ
*
RARGFLG BSS 1 FLAG RETURN ARGUMENTS FOUND
DOCWORD BSS 1 TEMP STO FOR DO COMMAND WORD
SAVINX BSS 1 TEMP STO FOR INX BEORE RETARGS
*
ISITER BSS 1
DTABLOC BSS 1
WPTSAV1 BSS 1
WPTSAV2 BSS 1
JOINFLG BSS 1
*
ENDOV
* /--- BLOCK COVL4B 00 000 79/07/20 03.21
COV4B OVRLAY
SA1 OVARG1 GET ARGUMENT
SB1 X1
JP B1+*+1
*
+ EQ ARROWC 0 = -ARROW-
+ EQ ENDAROC 1 = -ENDARROW-
+ EQ JARROWC 2 = -JARROW-
+ EQ WRITEIN 3 = -EXACT-
+ EQ FINDC 4 = -FIND-
+ EQ FINDAC 5 = -FINDALL-
*
*
* /--- BLOCK ARROW 00 000 79/07/20 03.12
TITLE ARROW
*
* ARROW (CODE=11 OR 12)
*
* 'HOLDS (WHEN COMPLETE) ONE ARGUMENT IF COARSE
* GRID OR TWO ARGUMENTS IF FINE GRID PLUS A
* POINTER TO THE NEXT ARROW OR ENDARROW COMMAND,
* OR TO THE END OF THE UNIT IF THERE IS NEITHER.
*
*
ARROWC SA1 INDENT
NZ X1,NOINDT INDENTING IS NOT PERMITTED
RJ VARDO COMMA SEPARATED VARIABLES
SA1 VARBUF X1 = NUMBER OF VARIABLES
SX1 X1-3
PL X1,ERR2MNY --- ERROR IF MORE THAN 2 TAGS
CALL SETARO,B0 PSEUDO -ENDARROW-
SA1 ICX CURRENT COMMAND POINTER
SX7 X1-1 VALUE WHEN THIS COMMAND STORED
SA7 LOCARO SAVE LOCATION OF THIS ARROW
EQ ONETWO1 --- EXIT TO STORE COMMAND
*
*
*
*
* ENDARROW (CODE=40)
*
* 'PUT PROPER POINTER VALUE IN PRECEDING ARROW
* COMMAND IN THIS UNIT (IF THERE IS ONE).
*
*
ENDAROC SA1 INDENT
NZ X1,NOINDT INDENTING IS NOT PERMITTED
RJ NOTAG BE SURE THERE IS NO TAG
CALL SETARO,-1 REAL -ENDARROW-
SX6 0 COMMAND NUMBER ONLY
EQ PUTCODE --- EXIT TO STORE COMMAND
*
*
*
* JARROW
*
* 'INITIATE JUDGING WITHOUT AN ARROW.
*
*
JARROWC SA1 INDENT
NZ X1,NOINDT INDENTING IS NOT PERMITTED
RJ NOTAG BE SURE THERE IS NO TAG
CALL SETARO,B0 PSEUDO -ENDARROW-
SA1 ICX CURRENT COMMAND POINTER
SX7 X1-1 VALUE WHEN THIS COMMAND STORED
SA7 LOCARO SAVE LOCATION OF THIS ARROW
SX6 0 COMMAND NUMBER ONLY
EQ PUTCODE --- EXIT TO STORE COMMAND
* /--- BLOCK EXACT 00 000 76/07/24 20.01
TITLE EXACT
* -EXACT-
*
*
* FORMAT OF COMMAND WORD --
*
* UPPER 18 BITS = RELATIVE ADDRESS OF START OF INFO
* NEXT 18 BITS = NUMBER OF 6 BIT CODES
*
*
WRITEIN SA1 INX XTRA STORAGE POINTER
SB5 X1
SB1 B0 NUMBER 6 BIT CODES
SA2 TAG CHECK FOR LEFT WRITING
SA1 A2+1 RESET FOR LOOP
LX2 6
BX6 X1+X2
SX1 X6-KUP*100B-1R0 CHECK FOR LEFT WRITING
NZ X1,WRT100 IF NOT LEFT
SX6 KUP*100B+1R1 SET TO NORMAL LEFT
LX6 -12 POSITION TO UPPER BITS
SB4 60-12
SB1 2 AND 6 6 BIT CODES
EQ WRTLOOP
*
WRT100 SA1 TAG-1 PRESET FOR LOOP
*
WRT150 SB4 60 SHIFT COUNT
SX6 B0
*
WRTLOOP SA1 A1+1 GET NEXT CHARACTER
ZR X1,WRTDONE JUMP IF END OF LINE
*
SB1 B1+1 NUMBER 6 BIT CODES
SB4 B4-6 SHIFT COUNT
LX1 X1,B4
BX6 X6-X1 ADD TO CURRENT WORD
NZ B4,WRTLOOP JUMP WORD NOT DONE
SA6 INFO+B5 PUT IN XTRA STORAGE
SB5 B5+1
JP WRT150
*
WRTDONE SA6 INFO+B5
SB5 B5+1
SA1 INX POINTER TO XTRA
LX1 42
SX2 B1 NUM 6 BIT CODES
LX2 24
BX6 X1+X2
SX7 B5 CURRENT XTRA POINTER
SA7 INX
EQ PUTCODE GO ATTACH CODE
* /--- BLOCK FIND 00 000 79/07/20 04.24
TITLE -FIND-
FINDC RJ VARDO
SA1 VARBUF+2
NG X1,FINDCE1 IF START NOT STOREABLE
SA1 VARBUF+4
NG X1,FINDCE -- ERROR IF RETURN IS NOT STOREABLE
SA3 VARBUF X3 = NUMBER OF VARIABLES
SX1 4 4 ARGS REQUIRED WITHOUT INCREMENT OR MASK
IX2 X3-X1
ZR X2,VARFIN EXIT IF EXACTLY 4
MX2 1
LX2 XCODEL PREPARE SPECIAL FLAG
SA1 VARBUF+3
BX6 X1+X2
SA6 A1
SX1 5 5 ARGS REQUIRED IF INCREMENT
IX4 X3-X1
ZR X4,VARFIN EXIT IF EXACTLY 5
SA1 VARBUF+5
BX6 X1+X2
SA6 A1
SX1 6 7 ARGS REQUIRED IF MASK
EQ VARFIN
* -SEARCH- AND -FINDALL- ALSO COME HERE
FINDCE SB1 70 NON-STOREABLE VARIABLE
EQ ERR
*
FINDCE1 SB1 768 ILLEGAL USE OF SEGMENTS
EQ ERR
*
TITLE -FINDALL-
FINDAC RJ VARDO
SA1 VARBUF+2
NG X1,FINDCE1 IF START NOT STOREABLE
SA1 VARBUF+4
NG X1,FINDCE -- ERROR IF RETURN IS NOT STOREABLE
SA3 VARBUF X3 = NUMBER OF VARIABLES
SX1 5 5 ARGS REQUIRED WITHOUT INCREMENT OR MASK
IX2 X3-X1
ZR X2,VARFIN EXIT IF EXACTLY 5
MX2 1
LX2 XCODEL PREPARE SPECIAL FLAG
SA1 VARBUF+3
BX6 X1+X2
SA6 A1
SX1 6 6 ARGS REQUIRED IF INCREMENT
IX4 X3-X1
ZR X4,VARFIN EXIT IF EXACTLY SIX
SA1 VARBUF+6
BX6 X1+X2
SA6 A1
SX1 7 SEVEN ARGS REQUIRED IF MASK
EQ VARFIN
* /--- BLOCK ENDOV 00 000 79/07/20 03.13
ENDOV
* /--- BLOCK END 00 000 77/04/24 20.01
*
*
OVTABLE
*
*
END COVLY4$