&&&&&&&&&&&& IMPLIB.SUB IMPLIB.SUB SETIO.IMP CUSPFS.IMP INIT.IMP ISFILE.IMP RENAME.IMP DDT.IMP GETSEG.IMP RUN.IMP READFS.IMP READ.IMP WRITE.IMP PRINT.IMP RAD50.IMP READST.IMP READTE.IMP READLI.IMP DA.IMP SQ.IMP DASQ.IMP DEFINE.IMP DEFAUL.IMP CHECKP.IMP CLOSE.IMP REWIND.IMP RESETI.IMP RESETO.IMP USET.IMP PROMPT.IMP IOLIB.IMP VECLIB.IMP HEX.IMP PPN.IMP OCTAL.IMP SWITCH.IMP SWARG.IMP SDEF.IMP STRTON.IMP TIME.IMP DECODE.IMP SIGNAL.IMP COPY.IMP IMPPRM.MAC INOUT.MAC IMPRUN.MAC PRMLIB.MAC MACLIB.MAC IMPFOR.MAC JSYS.MAC $$$$$$$$$$$$ &&&&&&&&&&&& SETIO.IMP !SETIO.IMP ! SET STREAMS PROMPTS THE USER WITH 'FILES' AND CAN ! TAKE UP TO 'N' OUTPUT AND 'N' INPUT FILES. ! THESE ARE SPECIFIED BY:- ! OUTFILE1,OUTFILE2,....OUTFILE'N'=INFILE1,INFILE2,....INFILE'N' ! CORRESPONDING TO STREAMS 1, 2 .... N. ANY OF THE FILESPECS MAY BE MISSING ! OR LEFT BLANK, IN WHICH CASE THEY DEFAULT TO NUL:. %CONSTINTEGER MAX STREAMS=3 %EXTERNALROUTINESPEC PROMPT(%STRING(255) STR) %EXTERNALROUTINESPEC REPORT(%STRING(255) STR) %EXTERNALROUTINESPEC XDEFINPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %EXTERNALROUTINESPEC XDEFOUTPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %EXTERNALROUTINESPEC READFS(%RECORD(FILESPEC)%NAME FC) %EXTERNALINTEGERFNSPEC SUBEVENT %EXTERNALINTEGERFNSPEC EVENTINFO %EXTERNALROUTINE SET STREAMS %RECORD(FILESPEC)%ARRAY INFS(1:MAX STREAMS), OUTFS(1:MAX STREAMS) %INTEGER NXTCHAR,N %ON %EVENT 10 %START %UNLESS SUBEVENT=9 %THEN %SIGNAL 10,SUBEVENT,EVENTINFO REPORT("Command error: ") READSYMBOL(N) %AND PRINTSYMBOL(N) %UNTIL N<' ' ->RESTART %FINISH %ROUTINE RDFILE(%RECORD(FILESPEC)%NAME FS) READFS(FS) READSYMBOL(NXTCHAR) %END RESTART: %CYCLE %CYCLE N=1,1,MAX STREAMS INFS(N)=0; OUTFS(N)=0 %REPEAT %CYCLE PROMPT("Files:-") %IF NEXTSYMBOL>' ' %THEN %EXIT SKIPSYMBOL %REPEAT RDFILE(OUTFS(1)) %FOR N=2,1,MAX STREAMS %CYCLE %EXIT %UNLESS NXTCHAR=',' RDFILE(OUTFS(N)) %REPEAT %IF NXTCHAR='=' %START RDFILE(INFS(1)) %FOR N=2,1,MAX STREAMS %CYCLE %EXIT %UNLESS NXTCHAR=',' RDFILE(INFS(N)) %REPEAT %FINISH %IF NXTCHAR>' ' %THEN %SIGNAL 10,9 %CYCLE N=1,1,MAX STREAMS %IF OUTFS(N)_FILE="" %AND OUTFS(N)_DEV="" %THEN OUTFS(N)_DEV="NUL" XDEFOUTPUT(N,OUTFS(N)) %IF INFS(N)_FILE="" %AND INFS(N)_DEV="" %THEN INFS(N)_DEV="NUL" XDEFINPUT(N,INFS(N)) %REPEAT %EXIT %REPEAT %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& CUSPFS.IMP !+ !.AP ! ^THE CUSP COMMAND-SCAN ROUTINE PROVIDES THE FACILITY !OF READING CUSP-TYPE COMMAND STRINGS OF THE FOLLOWING FORMS FROM THE !CURRENT INPUT STREAM (WHICH MAY BE SET TO BE A TMPCOR AFTER A CCL ENTRY):- !.NF !OUT, AUX = IN (,IN ... ) !OUT = IN (,IN ... ) !IN !@CMDFILE !CMDFILE@ !RUNFILE! !.S 1 !WHERE OUT, AUX, IN, CMDFILE, RUNFILE, ARE ALL DEC-SYSTEM 10 FILE SPECIFICATIONS. !.NF !%EXTERNALROUTINE CUSPFILES(%RECORD(FILESPEC)%NAME OUT,AUX,IN,RUN, %INTEGER CMDSTR, %INTEGERNAME GOT) !.F ! ^THE COMMAND STRUCTURES ILLUSTRATED ABOVE ARE PARSED INTO THE GIVEN !'FILESPEC' RECORDS, THE CMDSTR NUMBER IS USED IF A COMMAND-FILE IS !SPECIFIED. ^A NON-ZERO VALUE IS RETURNED IN THE 'GOT' PARAMETER IF !A NON-EMPTY LEGAL LINE HAS BEEN FOUND. ^ERROR REPORTS ARE OUTPUT ON THE !TELETYPE. ^IT IS THE RESPONSIBILITY OF THE USER TO APPLY ALL THE !NECCESSARY DEFAULTS. ! ^THE EXTERNAL INTEGER 'FSCHAR' CONTAINS THE VALUE OF THE LAST CHAR READ !ON THE INPUT STREAM AND SO THE EXISTENCE OF FURTHER INPUT FILES !FOLLOWING THE SUCCESSFUL RETURN FROM CUSPFILES IS ACHIEVED AS FOLLOWS:- !.NF !%IF FSCHAR=',' %THEN READFS(FSRECORD,GOT) ! (SEE 'GETLIB' FOR A DESCRIPTION OF READFS) !- %INCLUDE "IMP:IOLIB.INC" %EXTERNALROUTINE CUSPFILES(%RECORD(FILESPEC)%NAME OUT,AUX,IN,RUN, %INTEGER CMDCHAN, %INTEGERNAME GOT) %EXTERNALROUTINESPEC PROMPT(%STRING(255) PR) %EXTERNALINTEGERFNSPEC INDEV %EXTERNALROUTINESPEC XDEFINPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %EXTERNALROUTINESPEC READFS(%RECORD(FILESPEC)%NAME FS) %EXTERNALINTEGERFNSPEC SUBEVENT %EXTERNALINTEGERFNSPEC EVENTINFO %RECORD(FILESPEC) F %INTEGER GETS, AUXS, S, N, LASTINPUT,NXTCHAR %ON %EVENT 10 %START %UNLESS SUBEVENT=9 %THEN %SIGNAL 10,SUBEVENT,EVENTINFO N=OUTSTREAM SELECT OUTPUT(0) NEWLINE PRINTSTRING("Command error: ") %WHILE NEXTSYMBOL>=' ' %THEN READSYMBOL(S) %AND PRINTSYMBOL(S) NEWLINE SELECT OUTPUT(N) %IF INDEV#TTYDEV %START %IF LASTINPUT#0 %START CLOSE INPUT SELECTINPUT(LASTINPUT) %FINISH %SIGNAL 10,9,EVENT INFO %FINISH %FINISH %ROUTINE RDFILE(%RECORD(FILESPEC)%NAME FS) READFS(FS) NXTCHAR=NEXTSYMBOL SKIPSYMBOL %UNLESS NL<=NXTCHAR<=FF %OR NXTCHAR=',' %END LASTINPUT=0 GETS=0; AUXS=0; GOT=0 OUT=0; AUX=0; IN=0; RUN=0 %CYCLE PROMPT("*") %IF NEXTSYMBOL>=' ' %THEN %EXIT SKIPSYMBOL %REPEAT %CYCLE RDFILE(F) %IF NXTCHAR='@' %START %IF F_FILE="" %AND F_DEV="" %THEN RDFILE(F) F_EXT="CMD" %IF F_EXT="" XDEFINPUT(CMDCHAN,F) LASTINPUT=INSTREAM SELECTINPUT(CMDCHAN) %CONTINUE %FINISH %IF NXTCHAR='!' %START RUN=F GOT=-1 %EXIT %FINISH %IF NXTCHAR=',' %START %IF GETS#0 %START IN=F GOT=1 %EXIT %FINISH %IF AUXS#0 %THEN %SIGNAL 10,9 OUT=F AUXS=1 SKIPSYMBOL; !COMMA LEFT PENDING FROM RDFILE %CONTINUE %FINISH %IF NXTCHAR='_' %OR NXTCHAR='=' %START %IF AUXS=0 %THEN OUT=F %ELSE AUX=F GETS=1 %CONTINUE %FINISH %IF NXTCHAR=';' %START %WHILE %NOT NL<=NEXTSYMBOL<=FF %THEN SKIPSYMBOL %FINISH %IF NL<=NXTCHAR<=FF %OR NXTCHAR=';' %START IN=F GOT=1 %EXIT %FINISH %REPEAT !HERE WHEN SOME FILES ARE FOUND %IF LASTINPUT#0 %START CLOSE INPUT SELECTINPUT(LASTINPUT) %FINISH %RETURN %end %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& INIT.IMP %INCLUDE "IMP:IOLIB.INC" %SYSTEMROUTINESPEC ZERO(%NAME FROM,TO) %EXTERNALPREDICATESPEC CALLI2(%INTEGER NUM,%INTEGERNAME AC) %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALINTEGERARRAYSPEC STACK(0:1); !DATA STACK WITH DUMMY SIZE %EXTERNALINTEGER STACKBASE,STACKTOP %EXTERNALINTEGERSPEC STACKSIZE %EXTERNALINTEGER CPU; !PROCESSOR TYPE %EXTERNALRECORD(SCBNAME)%ARRAYSPEC DASQVEC(1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH DASQ CHANNEL %EXTERNALRECORD(SCBNAME)%ARRAYSPEC INVEC(-1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH STREAM %EXTERNALRECORD(SCBNAME)%ARRAYSPEC OUTVEC(-1:MAXCHANS); !FOR OUTPUT %EXTERNALRECORD(SCB)%SPEC IUNSCB %EXTERNALRECORD(SCB)%SPEC OUNSCB %EXTERNALRECORD(SCB)%SPEC ITYSCB %EXTERNALRECORD(SCB)%SPEC OTYSCB %CONSTINTEGER RH=8_777777, BIT1=8_200000 000000 %CONSTINTEGER UNDEF=RH %CONSTINTEGER BASE1=8_16, P=8_17; !AC DEFNS %CONSTINTEGER PAGE SIZE=512 %CONSTINTEGER DEFLT STACKSIZE=PAGESIZE %CONSTINTEGERNAME JBFF=8_121,JBREL=8_44, JBHRL=8_115 %OWNINTEGER STACKSIZ %OWNINTEGER OLDRETRN,RETRN,LASTSTACKLEN %OWNINTEGER STACKRESTART=0 %SYSTEMROUTINE GET PAGES(%INTEGER FIRST PAGE, LAST PAGE) %INTEGER PAGE,AC %INTEGERARRAY ARGS(0:1) %RETURN %IF CPU=3; !DEC-20 ARGS(0)=1; ARGS(1)=0 %FOR PAGE=FIRST PAGE,1,LAST PAGE %CYCLE ARGS(1)=ARGS(1)&BIT1!PAGE; !IF GONE VIRTUAL SAVE THE BIT IN LH GETPAGE: AC=1<<18!ADDR(ARGS(0)); !CREATE A PAGE %UNLESS CALLI2(8_145,AC) %START %IF AC=8_12 %START; !CORE FULL- GO VIRTUAL ARGS(1)=ARGS(1)!BIT1 ->GETPAGE %FINISH ERRMSG="Cannot get store" %SIGNAL 2,1,AC %FINISH %REPEAT %END %SYSTEMROUTINE INITIO %INTEGER I ! SET UP DEFAULT STREAMS INVEC(-1)_NAME==IUNSCB; !SET SYSTEM STRING STREAM TO UNASSIGNED OUTVEC(-1)_NAME==OUNSCB; !SET SYSTEM STRING STREAM TO UNASSIGNED INVEC(0)_NAME==ITYSCB; !SET TO USER TTY OUTVEC(0)_NAME==OTYSCB %CYCLE I=1,1,MAX CHANS !DEFAULT TO UNASSIGNED ALL STREAMS INVEC(I)_NAME==IUNSCB OUTVEC(I)_NAME==OUNSCB DASQVEC(I)_NAME==UNDSCB; !AND MARK DASQ CHANNELS %REPEAT IUNSCB_NXTCHR=0; ITYSCB_NXTCHR=0 SELECT INPUT(0); SELECT OUTPUT(0) %END %SYSTEMROUTINE INITSTACK ! GET SPACE FOR STACK %INTEGER BPAGE,TPAGE %IF STACKRESTART=0 %START %IF STACKSIZE=-1 %THEN STACKSIZ=DEFLT STACKSIZE %ELSE STACKSIZ=STACKSIZE %IF ADDR(STACK(0))=UNDEF %START STACKBASE=INTEGER(JBHRL)&RH+1; !DEFAULT STACKBASE %IF STACKBASE=1 %THEN STACKBASE=8_200000; !PUT AT TOP OF LOW IF NO HIGH SEG STACKTOP=STACKBASE+STACKSIZ BPAGE=STACKBASE>>9 TPAGE=STACKTOP>>9 %IF TPAGE>=BPAGE %THEN GETPAGES(BPAGE,TPAGE) %ELSE STACKBASE=ADDR(STACK(0)) STACKTOP=STACKBASE+STACKSIZ %FINISH STACKRESTART=-1 %ELSE ZERO(INTEGER(STACKBASE),INTEGER(STACKTOP)) RETRN=AC(BASE1); !RETURN ADDRESS OLDRETRN=INTEGER(AC(BASE1)+1); !LAST RETURN ADDRESS %IF OLDRETRN=0 %THEN LASTSTACKLEN=0 %ELSE LASTSTACKLEN=RETRN&RH-OLDRETRN&RH; !LENGTH OF LAST STACK FRAME INTEGER(STACKBASE+LASTSTACKLEN+1)=1<<18!STACKBASE; !SET UP OLD STACK POINTER INTEGER(STACKBASE+LASTSTACKLEN)=INTEGER(RETRN&RH); !AND RETURN ADDRESS INTEGER(STACKBASE)=INTEGER(OLDRETRN&RH) %UNLESS OLDRETRN=0; !AND PREVIOUS RETRN AC(BASE1)=2<<18!STACKBASE+LASTSTACKLEN; !POINT TO CURRENT STACK BASE %END %SYSTEMROUTINE FINIT !FINISH OFF CHANNELS %INTEGER I %CYCLE I=0,1,MAX CHANS %UNLESS OUTVEC(I)_NAME_DEVTYP=UNDEV %START SELECTOUTPUT(I); CLOSE OUTPUT %FINISH %REPEAT %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& ISFILE.IMP !+ ! ^THIS LIBRARY CONTAINS THE ROUTINES FOR CHECKING THE EXISTENCE OF ! A FILE. !- %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER OPEN=8_050, LOOKUP=8_076; !IOUUO CODES %CONSTINTEGER SIXDSK=8_446353 000000; !SIXBIT/DSK/ %CONSTINTEGER SIXTMP=8_645560 000000; !SIXBIT/TMP/ %CONSTINTEGER SIXTTY=8_646471 000000; !SIXBIT/TTY/ %SYSTEMINTEGERFNSPEC GETCHANNEL %SYSTEMPREDICATESPEC IOUUO(%INTEGER FN,CHAN, %INTEGERNAME ADDR) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) STR) %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) SPEC) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %SYSTEMINTEGERFNSPEC TMPCOR(%INTEGER TYPE,BLOCK,NAME) %SYSTEMINTEGERFNSPEC IOWD(%INTEGER LEN, %INTEGERNAME LOC) %EXTERNALSTRING(6)%FNSPEC JOBFILE(%STRING(3) NAME) %EXTERNALSTRING(255)%FNSPEC FSTOSTR(%RECORD(FILESPEC)%NAME FS) %SYSTEMROUTINESPEC FILL PATH BLOCK(%RECORD(PATHBLOCK)%NAME PATH, %RECORD(FILESPEC)%NAME FS, %INTEGER DEVNAM) %EXTERNALSTRING(255)%SPEC ERRMSG %OWNRECORD(OPENBLOCK) OPN; !AN OPEN-BLOCK %OWNRECORD(LOOKUPBLOCK) LKUP; !A LOOKUP-ENTER-RENAME BLOCK %OWNRECORD(PATHBLOCK) PATH; !A PATH BLOCK !- ! ^ISFIL DOES THE LOOKUP ON A FILE TO SEE IF IT EXISTS ! RETURNING TRUE OR FALSE AND ALSO THE CHANNEL NUMBER IT USED AS THE ! SECOND PARAMETER. ^THIS CHANNEL MUST BE RELEASED AFTER USE. !- %SYSTEMPREDICATE ISFIL(%RECORD(FILESPEC)%NAME FS, %INTEGERNAME CHAN) !OPEN A DATA CHANNEL %RECORD (FILESPEC) WORKFS %INTEGER SIXDEV,N %INTEGERARRAY TMPBUF(1:4) CHAN=0; WORKFS=FS OPN_STATUS=8_10; !IMAGE MODE %IF WORKFS_DEV="" %THEN SIXDEV=SIXDSK %ELSE SIXDEV=STRTOSIX(WORKFS_DEV) AC(1)=SIXDEV *8_047040000064; !DEVNAM AC1, *8_402000000001; !SETZM AC1 OPN_DEVNAM=AC(1) OPN_BUFHEDS=0; !NO BUFFERS %IF OPN_DEVNAM=SIXTTY %THEN %TRUE; !TTY: %IF OPN_DEVNAM=0 %AND SIXDEV=SIXTMP %START; !TMPCOR N=TMPCOR(1,IOWD(4,TMPBUF(1)),STRTOSIX(WORKFS_FILE)) CHAN=-1 %IF N#0 %THEN %TRUE !ELSE TRY DISK OPN_DEVNAM=SIXDSK WORKFS_FILE=JOBFILE(FS_FILE); WORKFS_EXT="TMP" %FINISH CHAN=GETCHANNEL; !GET NEXT FREE CHANNEL FOR DSK TYPE DEV %UNLESS IOUUO(OPEN,CHAN,OPN_STATUS) %THEN %C ERRMSG="Cannot open device for ".FSTOSTR(WORKFS) %AND %SIGNAL 10,6,0; !FUNNY !NOW LOOKUP THE FILE LKUP_CNT=4 LKUP_NAM=STRTOSIX(WORKFS_FILE) LKUP_EXT=STRTOSIX(WORKFS_EXT) LKUP_PRV=0 LKUP_PPN=ADDR(PATH) FILL PATH BLOCK(PATH,WORKFS,OPN_DEVNAM) %IF IOUUO(LOOKUP,CHAN,LKUP_CNT) %THEN %TRUE RELEASE(CHAN) %FALSE %END !+ ! ^XISFILE TAKES A FILESPEC RECORD AND RETURNS TRUE IF THE FILE EXISTS AND !FALSE OTHERWISE. !- %EXTERNALPREDICATE XISFILE(%RECORD(FILESPEC)%NAME FS) %INTEGER CHAN %IF ISFIL(FS,CHAN) %START RELEASE(CHAN) %UNLESS CHAN<=0 %TRUE %FINISH %FALSE %END %EXTERNALPREDICATE ISFILE(%STRING(255) SPEC) %RECORD (FILESPEC) FS FS=STRTOFS(SPEC) %IF XISFILE(FS) %THEN %TRUE %ELSE %FALSE %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& RENAME.IMP !+ ! ^THIS LIBRARY CONTAINS THE ROUTINES FOR RENAMING A FILE AND DELETING A FILE. !- %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER RENAM=8_055; !IOUUO CODE %CONSTINTEGER RH=8_777777 %SYSTEMPREDICATESPEC IOUUO(%INTEGER FN,CHAN, %INTEGERNAME ADDR) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) STR) %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) SPEC) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %SYSTEMINTEGERFNSPEC TMPCOR(%INTEGER TYPE,BLOCK,NAME) %SYSTEMINTEGERFNSPEC IOWD(%INTEGER LEN, %INTEGERNAME LOC) %EXTERNALSTRING(255)%FNSPEC FSTOSTR(%RECORD(FILESPEC)%NAME FS) %SYSTEMROUTINESPEC FILL PATH BLOCK(%RECORD(PATHBLOCK)%NAME PATH, %RECORD(FILESPEC)%NAME FS, %INTEGER DEVNAM) %EXTERNALSTRING(255)%SPEC ERRMSG %OWNRECORD(OPENBLOCK) OPN; !AN OPEN-BLOCK %OWNRECORD(LOOKUPBLOCK) LKUP; !A LOOKUP-ENTER-RENAME BLOCK %OWNRECORD(PATHBLOCK) PATH; !A PATH BLOCK %SYSTEMPREDICATESPEC ISFIL(%RECORD(FILESPEC)%NAME FS, %INTEGERNAME CHAN) %EXTERNALROUTINE XRENAME(%RECORD(FILESPEC)%NAME FS1,FS2) %INTEGER CHAN, SIXDEV,DEVNAM,N %INTEGERARRAY TMPBUF(1:4) !LOOKUP THE FILE %UNLESS ISFIL(FS1,CHAN) %THEN ->FAILED !RENAME IT %IF FS2_DEV="" %THEN SIXDEV=STRTOSIX("DSK") %ELSE SIXDEV=STRTOSIX(FS2_DEV) AC(1)=SIXDEV *8_047040000064; !DEVNAM AC1, *8_402000000001; !SETZM AC1 DEVNAM=AC(1) %IF CHAN=-1 %AND FS2_FILE="" %START; !TMPCOR DELETE N=TMPCOR(2,IOWD(4,TMPBUF(1)),STRTOSIX(FS1_FILE)) %RETURN %FINISH %IF CHAN<=0 %THEN LKUP_EXT=0 %AND ->FAILED; !OTHERWISE CANNOT RENAME LKUP_CNT=4 LKUP_NAM=STRTOSIX(FS2_FILE) LKUP_EXT=STRTOSIX(FS2_EXT) LKUP_PRV=FS2_PROT<<27 LKUP_PPN=ADDR(PATH) FILL PATH BLOCK(PATH,FS2,DEVNAM) %UNLESS IOUUO(RENAM,CHAN,LKUP_CNT) %THEN ->FAILED RELEASE(CHAN) %RETURN FAILED: RELEASE(CHAN) ERRMSG="Cannot RENAME/DELETE ".FSTOSTR(FS1) %SIGNAL 10,16,LKUP_EXT&RH %END %EXTERNALROUTINE RENAME (%STRING(255) FILE1,FILE2) %RECORD(FILESPEC) FS1,FS2 FS1=STRTOFS(FILE1); FS2=STRTOFS(FILE2) XRENAME(FS1,FS2) %END %EXTERNALROUTINE XDELETE(%RECORD(FILESPEC)%NAME FS) %RECORD(FILESPEC) NUL NUL=0 XRENAME(FS,NUL) %END %EXTERNALROUTINE DELETE(%STRING(255) FILE) %RECORD(FILESPEC) FS FS=STRTOFS(FILE) XDELETE(FS) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DDT.IMP %EXTERNALINTEGER DDARG; !CONTAINS ARG IN DDT I.E. A %NAME PARAMETER IF GIVEN %EXTERNALINTEGER DDCONT=8_263740000000; !IS ADDRESS TO REENTER PROGRAM AT I.E. POPJ P,0 !USING %SYSTEMROUTINESPEC DDT(%NAME X) %OWNINTEGER FIRST=0 %CONSTINTEGERNAME JBDDT=8_74 %EXTERNALROUTINESPEC REPORT(%STRING(255) T) %SYSTEMROUTINE DDT DDARG=AC(ARG1); !SAVE ARGUMENT (IN ARG1) %IF JBDDT=0 %AND FIRST=0 %C %START REPORT(" DDT NOT LOADED - CONTINUING ") FIRST=1 %ELSE REPORT(" DDT ") AC(1)=JBDDT&8_777777 AC(ARG1)=DDARG; !RESTORE ARGUMENT *8_254020000001; !JRST @1 %FINISH %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& GETSEG.IMP %EXTERNALROUTINESPEC GGETSEG(%INTEGER D,F,E,I,P,J,K) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) S) !+ !.NF !%EXTERNALROUTINE GETSEG(%STRING(6) DEV,FILE, %STRING(3) EXT, %INTEGER PPN) !.F ! ^THIS HAS THE EFFECT OF DESTROYING THE CURRENT HIGH SEGMENT AND !REPLACING IT WITH THE GIVEN ONE, WHILST LEAVING THE LOW SEGMENT UNALTERED !^THE DEFAULTS ARE FOR DISK UNDER THE USERS OWN AREA. !- %EXTERNALROUTINE GETSEG(%STRING(6) DEV, FILE, %STRING(3) EXT, %INTEGER PPN) GGETSEG(STRTOSIX(DEV),STRTOSIX(FILE),STRTOSIX(EXT),0,PPN,0,0) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& RUN.IMP %EXTERNALROUTINESPEC RRUN(%INTEGER D,F,E,I,P,J,K,O) %SYSTEMROUTINESPEC FINIT; !CLOSE ALL STREAMS %SYSTEMROUTINESPEC RELEASE(%INTEGER N) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) S) %ROUTINESPEC CLOSE ALL !+ !.NF !%EXTERNALROUTINE RUN(%STRING(6) DEV,FILE, %STRING(3) EXT, %INTEGER PPN, OFFSET) !.F ! ^CALLING THIS ROUTINE HAS THE EFFECT OF RUNNING THE NAMED PROGRAM !THUS DESTROYING THE CURRENT CORE-IMAGE. !^THE ONLY PARAMETER WHICH IS ABSOLUTELY NECCESSARY IS THE FILE NAME, !THE REST DEFAULT TO DISK ON THE USERS OWN AREA. !^THE OFFSET IS THE ENTRY POINT AT WHICH THE PROGRAM IS STARTED !(NORMALLY = 0, CCL ENTRY POINT = 1) !- %EXTERNALROUTINE RUN(%STRING(6) DEV, FILE, %STRING(3) EXT, %INTEGER PPN, OFFSET) CLOSE ALL RRUN(STRTOSIX(DEV),STRTOSIX(FILE),STRTOSIX(EXT),0,PPN,0,0,OFFSET) %END %ROUTINE CLOSE ALL %INTEGER I FINIT %CYCLE I=0,1,15 RELEASE(I) %REPEAT %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& READFS.IMP !+ ! ^THESE TWO ROUTINES DO THE SAME THING EXCEPT THAT READFS OPERATES !ON THE CURRENT INPUT STREAM AND GETFS USES THE STRING PARAMETER IT !IS GIVEN. ^THEY BOTH HAVE THE FUNCTION OF PARSING A SEQUENCE OF CHARACTERS !INTO THE COMPONENTS OF A STANDARD DEC-10 FILE SPECIFICATION AND PUTING !THE RESULT IN THE GIVEN 'FILESPEC' RECORD. ! ^A CORRECT FILE SPECIFICATION IS A SUBSET OF THE FULL SPECIFICATION !GIVEN BELOW !.NF ! DEV:FILENAME.EXT[PROJ,PROG]/SWITCH:NUMBER/SWITCH(SWITCH) !.F ! ^FOR A DESCRIPTION OF THE 'FILESPEC' RECORD SEE 'PERMS.IMP'. !- %EXTERNALSTRING(255)%SPEC ERRMSG %OWNINTEGER FSCHAR; !LAST CHAR READ %EXTERNALROUTINESPEC READOCTAL(%INTEGERNAME N) %EXTERNALROUTINESPEC READPPN(%INTEGERNAME PPN) %SYSTEMROUTINESPEC SDINPUT(%INTEGER N,%STRING(1)%NAME STR) %SYSTEMROUTINESPEC SINPUT(%INTEGER N) %RECORD(FILESPEC)%FN GETFS %ROUTINESPEC NEXT FSCHAR %ROUTINESPEC RDFSCHAR %PREDICATESPEC ALPHANUM %ROUTINESPEC GOBBLE SPACES %ROUTINESPEC RDWORD(%STRING(1)%NAME WORD, %INTEGER LEN) %ROUTINESPEC RDFS SWITCH %INTEGER COLON,DOT,N %STRING(80) WORD %RECORD(FILESPEC) FS FS=0 WORD=""; COLON=0; DOT=0 NEXT FSCHAR %CYCLE GOBBLE SPACES %IF ALPHANUM %THEN RDWORD(WORD,6) %IF FSCHAR=':' %START %IF COLON#0 %THENEXIT COLON=1; FS_DEV=WORD WORD="" RDFSCHAR %CONTINUE %FINISH %IF FSCHAR='.' %START %IF DOT#0 %THENEXIT DOT=1; FS_FILE=WORD WORD="" RDFSCHAR %CONTINUE %FINISH %IF FSCHAR='[' %START %IF FS_PPN#0 %THENEXIT SKIPSYMBOL READPPN(FS_PPN) NEXT FSCHAR N=1 %CYCLE GOBBLE SPACES %EXIT %UNLESS FSCHAR=',' %AND N<=MAX SFDS RDFSCHAR RDWORD(FS_SFDS(N),6) N=N+1 %REPEAT %IF FSCHAR=']' %THEN RDFSCHAR %EXIT %IF ALPHANUM %CONTINUE %FINISH %IF FSCHAR='<' %START %IF FS_PROT#0 %THENEXIT SKIP SYMBOL READOCTAL(FS_PROT) NEXT FSCHAR %IF FS_PROT>8_777 %THENEXIT %IF FSCHAR='>' %THEN RDFSCHAR %EXIT %IF ALPHANUM %CONTINUE %FINISH %IF FSCHAR='/' %START RDFS SWITCH %WHILE FSCHAR='/' %FINISH %IF DOT # 0 %START %IF LENGTH(WORD)>3 %THEN FS_EXT=SUBSTRING(WORD,1,3) %ELSE FS_EXT=WORD %FINISH %ELSE FS_FILE=WORD %RESULT=FS %REPEAT !HERE FOR SYNTAX INFRINGMENT ERRMSG="Bad file specification " %SIGNAL 10,9 %ROUTINE NEXT FSCHAR FSCHAR=NEXT SYMBOL %END %ROUTINE RDFSCHAR SKIP SYMBOL; FS CHAR=NEXT SYMBOL %END %PREDICATE ALPHANUM %IF 'A'<=FSCHAR<='Z' %OR 'a'<=FSCHAR<='z' %OR '0'<=FSCHAR<='9' %THEN %TRUE %FALSE %END %ROUTINE GOBBLE SPACES %WHILE FSCHAR=' ' %OR FSCHAR=TAB %THEN RDFSCHAR %END %ROUTINE RDWORD(%STRING(1)%NAME WORD, %INTEGER LEN) %INTEGER I I=1 %WHILE ALPHANUM %CYCLE %IF I<=LEN %THEN WORD=WORD.TOSTRING(FSCHAR) %AND I=I+1 RDFSCHAR %REPEAT GOBBLE SPACES %END %ROUTINE RDFS SWITCH %CYCLE %CYCLE %IF LENGTH(FS_SWITCHES)>=39 %THEN FSCHAR=NL %AND %RETURN; !NO MORE FS_SWITCHES=FS_SWITCHES.TOSTRING(FSCHAR) RDFSCHAR %REPEAT %UNTIL %NOT ALPHANUM GOBBLE SPACES %REPEAT %UNTIL ':'#FSCHAR#'#' %AND '-'#FSCHAR#'+' %END %END %EXTERNALROUTINE READFS(%RECORD(FILESPEC)%NAME FS) FS=GETFS %END %EXTERNALRECORD(FILESPEC)%FN STRTOFS(%STRING(255) FILE) %RECORD(FILESPEC) FS %INTEGER N %ON %EVENT 10 %START CLOSE INPUT SELECT INPUT(N) ERRMSG=ERRMSG.FILE %SIGNAL 10,SUBEVENT,EVENTINFO %FINISH FILE=FILE." "; !TO ENSURE NO EOF N=INSTREAM SDINPUT(-1,FILE) SINPUT(-1) FS=GETFS CLOSE INPUT SELECT INPUT(N) %RESULT=FS %END %EXTERNALROUTINE DEFINPUT(%INTEGER N,%STRING(255) SPEC) %EXTERNALROUTINESPEC XDEFINPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %RECORD(FILESPEC) FS FS=STRTOFS(SPEC) XDEFINPUT(N,FS) %END %EXTERNALROUTINE DEFOUTPUT(%INTEGER N,%STRING(255) SPEC) %EXTERNALROUTINESPEC XDEFOUTPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %RECORD(FILESPEC) FS FS=STRTOFS(SPEC) XDEFOUTPUT(N,FS) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& READ.IMP !READ.IMP %EXTERNALSTRING(255)%SPEC ERRMSG %CONSTINTEGERARRAY NMAX(1:3) =3435973836, 13107, 25; !LARGEST INTEGERS//10 %CONSTBYTEINTEGERARRAY N1MAX(1:3) ='7', '1', '6'; !LARGEST INTEGERS LAST DIGIT %CONSTLONGREAL PMAX=1@15 %CONSTLONGREAL DZ=0.0 %EXTERNALROUTINE READ(%NAME X) !*********************************************************************** !* THIS ROUTINE IS THE IMP IMPLICITLY SPECIFIED ROUTINE WITH A * !* %NAME PARAMETER. * !*********************************************************************** %INTEGERARRAY XFRIG(0:0); !A FRIG SO THAT X=XFRIG(-1) %BYTEINTEGER TYPE,DIGIT,FLAG,CURSYM; ! FLAG= 0FOR'-',1 FOR '+' %INTEGER N %LONGREAL RWORK,SCALE %ROUTINE READ A SYMBOL SKIP SYMBOL; CURSYM=NEXT SYMBOL %END %PREDICATE SYMBOLOK SKIP SYMBOL; CURSYM=NEXT SYMBOL %TRUE %IF '0'<=CURSYM<='9' %FALSE %END TYPE=X FRIG(-1)>>23&8_17 ;!GET AT THE TYPE FEILD OF X %IF TYPE = 4 %THEN READSTRING(STRING(ADDR(X))) %AND %RETURN %IF TYPE=0 %OR TYPE=5 %OR TYPE>7 %START ERRMSG="Illegal %name type"; %SIGNAL 5,6,type %FINISH ! OTHERWISE A NUMBER FLAG=1; DIGIT=0 CURSYM=NEXT SYMBOL; ! CARE NOT TO READ TERMINATOR ! NOW IGNORE LEADING SPACES READASYMBOL %WHILE CURSYM<=' ' %IF CURSYM='-' %START FLAG=0; READASYMBOL %ELSEIF CURSYM='+' %THEN READASYMBOL %UNLESS TYPE=6 %START; !AN INTEGER TYPE VARIABLE ->NNF %UNLESS '0'<=CURSYM<='9' N=CURSYM-'0' %WHILE SYMBOLOK %CYCLE %IF N>=NMAX(TYPE) %AND CURSYM>N1MAX(TYPE) %START %WHILE SYMBOLOK %CYCLE; %REPEAT; !SKIP REST OF NUMBER ERRMSG="Integer too large" %SIGNAL 1,1,N %FINISH N=N*10+(CURSYM-'0') %REPEAT N=-N %IF FLAG=0 INTEGER(ADDR(X))=N; !RETURN RESULT %RETURN %FINISH !A REAL NUMBER %IF '0'<=CURSYM<='9' %START RWORK=CURSYM-'0'; ! KEEP TOTAL IN RWORK DIGIT=1; ! VALID DIGIT %WHILE SYMBOLOK %CYCLE RWORK=10*RWORK+(CURSYM-'0') %REPEAT %FINISH %ELSE RWORK=0 %IF CURSYM='.' %START SCALE=10 %WHILE SYMBOLOK %CYCLE DIGIT=1 RWORK=RWORK+(CURSYM-'0')/SCALE SCALE=10*SCALE %REPEAT %FINISH ! ! THE VALUE HAS NOW BEEN READ INTO RWORK. THERE MIGHT BE AN EXPONENT ! E.G. '1.7@ 10' IS VALID DATA FOR READ ! %IF CURSYM='@' %START SKIP SYMBOL; ! MOVE PAST THE '@' READ(N); ! RECURSIVE CALL TO FIND EXPONENT %IF N=-99 %THEN RWORK=0 %ELSE RWORK=RWORK*10\N %ELSE ->NNF %IF DIGIT=0 %FINISH RWORK=-RWORK %IF FLAG=0 REAL(ADDR(X))=RWORK %RETURN NNF: ERRMSG="Number not found" %SIGNAL 3,1,CURSYM %END; !OF READ %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& WRITE.IMP !WRITE.IMP %EXTERNALROUTINE WRITE(%INTEGER N, S) %ROUTINESPEC P(%INTEGER N) %INTEGER SIGN %IF S<=0 %THEN SIGN=S %ELSE SIGN = ' '; !GIVE NO SIGN FOR WRITE(N,0) S=IMOD(S); S=63 %IF S>63 %IF N < 0 %START N = -N SIGN = '-' %FINISH P(N) %ROUTINE P(%INTEGER N) S = S-1 P(N//10) %IF N >= 10 %IF SIGN > 0 %START SPACES(S-1) PRINTSYMBOL(SIGN); SIGN = 0 %ELSE %IF SIGN<0 %THEN SPACES(S) %AND SIGN=0; !FOR -VE S PRINTSYMBOL(REM(N,10)+'0') %END %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& PRINT.IMP %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALREALFNSPEC FRACPT(%LONGREAL R) %ROUTINE FRACTION(%REAL R, %INTEGER PLACES) %RETURN %IF PLACES<=0 PRINTSYMBOL('.') %WHILE PLACES>0 %CYCLE R = FRACPT(R)*10.0 PLACES=PLACES-1 PRINTSYMBOL(INTPT(R)+'0') %REPEAT %END %EXTERNALROUTINE PRINTFL(%REAL R, %INTEGER P) %INTEGER EXP,SIGN SIGN=' ' SIGN='-' %AND R=-R %IF R<0 PRINTSYMBOL(SIGN) %IF R=0 %START EXP=-99 %ELSE %IF P<=0 %START R=R+0.5 %ELSE R=R+0.5*10\(-P) %FINISH EXP=0 EXP=EXP+1 %AND R=R*0.1 %WHILE R >=10.0 EXP=EXP-1 %AND R=R*10.0 %WHILE R< 1.0 %FINISH PRINTSYMBOL(INT PT(R)+'0') FRACTION(R,P) PRINTSYMBOL('@'); WRITE(EXP,1) %END %EXTERNALROUTINE PRINT(%REAL R, %INTEGER B,A) %REAL RM %CONSTINTEGER MAX INT= 8_377777777777 %INTEGER SIGN %ROUTINE P(%INTEGER N) B = B-1 P(N//10) %IF N >= 10 %IF SIGN # 0 %START SPACES(B-1) PRINTSYMBOL(SIGN); SIGN = 0 %FINISH PRINTSYMBOL(REM(N,10)+'0') %END RM=|R| PRINTFL(R, B+A) %AND %RETURN %IF RM> MAX INT %IF A<=0 %START RM=RM+0.5 %ELSE RM=RM+0.5*10\(-A) %FINISH %IF B<=0 %THEN SIGN=0 %ELSE SIGN=' ' %IF R<0 %THEN SIGN='-' P(INT PT(RM)); !THUS ALLOWING FOR -0.1 ETC. FRACTION(RM,A) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& RAD50.IMP %EXTERNALINTEGERFN RAD50(%STRING(6) NAME) %INTEGER S, SYM, J, X %INTEGERFN SYM50 SYM=CHARNO(NAME,J) %RESULT = SYM-'A'+8_13 %IF 'A' <= SYM <= 'Z' %RESULT = SYM-'0'+1 %IF '0' <= SYM <= '9' %RESULT = 8_45 %IF SYM = '.' %RESULT = 8_46 %IF SYM = '$' %RESULT = 8_47 %IF SYM = '%' %RESULT = 0 %END X = 0 %CYCLE J = 1, 1, LENGTH(NAME) S = SYM50; %RESULT=X %IF S = 0 X = X*40+S %REPEAT %RESULT=X %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& READST.IMP ! READST.IMP %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALROUTINE READ STRING(%STRING(1)%NAME STR) %CONSTINTEGER QUOTE='"' %INTEGER S, N, LENGTH, POINT POINT=8_331100<<18!(AC(ARG1)&8_777777); ![POINT 9,STR,8] WHERE STR=ARG1 LENGTH=POINT; !POINTER TO LENGTH BYTE N=0 %WHILE NEXTSYMBOL<=' ' %THEN SKIPSYMBOL; !SKIP SPACES AND NEWLINES %UNLESS NEXTSYMBOL = QUOTE %START ERRMSG="No opening quote for string"; %SIGNAL 3,2,NEXT SYMBOL %FINISH SKIPSYMBOL %CYCLE READSYMBOL(S) %IF S=QUOTE %START %IF NEXTSYMBOL=QUOTE %THEN SKIPSYMBOL %ELSE %EXIT %FINISH N=N+1 %IF N>255 %THEN %C ERRMSG="String capacity exceeded" %AND %SIGNAL 6,1,0 AC(1)=S AC(2)=POINT *8_136040000002; !IDPB 1,2 POINT=AC(2); !DEPOSIT INCREMENTED POINTER %REPEAT AC(1)=N AC(2)=LENGTH *8_137040000002; !DPB 1,2 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& READTE.IMP ! READTE.IMP %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALROUTINE READ TEXT(%STRING(1)%NAME STR,%INTEGER DELIM) %INTEGER S, N, LENGTH, POINT POINT=8_331100<<18!(AC(ARG1)&8_777777); ![POINT 9,STR,8] WHERE STR=ARG1 LENGTH=POINT; !POINTER TO LENGTH BYTE N=0 %CYCLE READSYMBOL(S) %EXIT %IF S=DELIM N=N+1 %IF N>255 %THEN %C ERRMSG="String capacity exceeded" %AND %SIGNAL 6,1,0 AC(1)=S AC(2)=POINT *8_136040000002; !IDPB 1,2 POINT=AC(2); !DEPOSIT INCREMENTED POINTER %REPEAT AC(1)=N AC(2)=LENGTH *8_137040000002; !DPB 1,2 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& READLI.IMP ! READLI.IMP %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALROUTINE READ LINE(%STRING(1)%NAME STR) %INTEGER S, N, LENGTH, POINT %ON %EVENT 9 %START; ->END; %FINISH POINT=8_331100<<18!(AC(ARG1)&8_777777); ![POINT 9,STR,8] WHERE STR=ARG1 LENGTH=POINT; !POINTER TO LENGTH BYTE N=0 %CYCLE READSYMBOL(S) %EXIT %IF 10<=S<=13 %OR S=ESC N=N+1 %IF N>255 %THEN %C ERRMSG="String capacity exceeded" %AND %SIGNAL 6,1,0 AC(1)=S AC(2)=POINT *8_136040000002; !IDPB 1,2 POINT=AC(2); !DEPOSIT INCREMENTED POINTER %REPEAT END: AC(1)=N AC(2)=LENGTH *8_137040000002; !DPB 1,2 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DA.IMP !+ ! ^THIS IS THE LIBRARY OF DIRECT ACCESS AND SEQUENTIAL ACCESS FILES UTILITIES !^IT USES A SIMILAR MECHANISM TO THE STREAMS, USING THE SAME STREAM CONTROL !BLOCKS BUT UTILISING DUMP-MODE READING AND WRITING ROUTINES. !- %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER LH=8_777777000000, RH=8_777777 %EXTERNALINTEGERSPEC FUNCTION %EXTERNALRECORD(SCBNAME)%ARRAYSPEC DASQVEC(1:MAXCHANS) %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMROUTINESPEC RDDUMP(%RECORD(SCB)%NAME S, %INTEGER LEN,%NAME LOC) %SYSTEMROUTINESPEC WTDUMP(%RECORD(SCB)%NAME S, %INTEGER LEN, %NAME LOC) %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) SPEC) %SYSTEMROUTINESPEC OPNDASQ(%INTEGER N,%RECORD(FILESPEC)%NAME FS,%INTEGER DAORSQ) %SYSTEMROUTINESPEC DASQ CHANNEL CHECK(%INTEGER N, DAORSQ FILE) %SYSTEMINTEGERFNSPEC DASQ LENGTH(%INTEGER CHAN, %NAME BEGIN,END) %SYSTEMROUTINESPEC CLDASQ(%INTEGER N,TYPE) %EXTERNALROUTINE XOPENDA(%INTEGER N,%RECORD(FILESPEC)%NAME FS) OPNDASQ(N,FS,DAFILE) %END %EXTERNALROUTINE OPENDA(%INTEGER N,%STRING(255) SPEC) %RECORD(FILESPEC) FS FS=STRTOFS(SPEC) XOPENDA(N,FS) %END %ROUTINE DA BLOCK CHECK(%INTEGER BLOCK) %UNLESS 1<=BLOCK<=8_777777 %START ERRMSG="Illegal block number in DA read/write" %SIGNAL 10,26,BLOCK %FINISH %END %EXTERNALROUTINE READDA(%INTEGER N, %INTEGERNAME SECT, %NAME BEGIN,END) %INTEGER LENGTH %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD DASQ CHANNEL CHECK(N,DAFILE) LENGTH=DASQ LENGTH(N,BEGIN,END) DA BLOCK CHECK(SECT) DASQSCB==DASQVEC(N)_NAME %IF DASQSCB_NXTCHR # SECT %START; !ARE WE AT THE BLOCK WE WANT AC(1)=DASQSCB_USETI!SECT&RH *8_256000000001; !XCT AC1 %FINISH RDDUMP(DASQSCB,LENGTH,BEGIN) SECT=SECT+(LENGTH-1)//DASQSCB_BLOCKSIZE DASQSCB_NXTCHR=SECT+1 %END %EXTERNALROUTINE WRITEDA(%INTEGER N, %INTEGERNAME SECT, %NAME BEGIN, END) %INTEGER LENGTH %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD DASQ CHANNEL CHECK(N,DAFILE) LENGTH=DASQ LENGTH(N,BEGIN,END) !MAKE SPECIAL CASE OF APPENDING DASQSCB==DASQVEC(N)_NAME %IF SECT=-1 %START AC(1)=DASQSCB_USETI!SECT&RH *8_256000000001; !XCT AC1 %ELSE %IF SECT # DASQSCB_NXTCHR %START DA BLOCK CHECK(SECT) AC(1)=DASQSCB_USETO!SECT&RH *8_256000000001; !XCT AC1 %FINISH WTDUMP(DASQSCB,LENGTH,BEGIN) %IF SECT=-1 %START;! LAST BLOCK IN FILE DASQSCB_LKENT_SIZ=DASQSCB_LKENT_SIZ+LENGTH;!NEW SIZE OF FILE SECT=(DASQSCB_LKENT_SIZ-1)//DASQSCB_BLOCKSIZE; !LAST BLOCK WRITTEN TO %ELSE SECT=SECT+(LENGTH-1)//DASQSCB_BLOCKSIZE %FINISH DASQSCB_NXTCHR=SECT+1 %END %EXTERNALROUTINE CLOSEDA(%INTEGER N) CLDASQ(N,DAFILE) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& SQ.IMP !+ ! ^THIS IS THE LIBRARY OF DIRECT ACCESS AND SEQUENTIAL ACCESS FILES UTILITIES !^IT USES A SIMILAR MECHANISM TO THE STREAMS, USING THE SAME STREAM CONTROL !BLOCKS BUT UTILISING DUMP-MODE READING AND WRITING ROUTINES. !- %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER LH=8_777777000000, RH=8_777777 %EXTERNALINTEGERSPEC FUNCTION %EXTERNALRECORD(SCBNAME)%ARRAYSPEC DASQVEC(1:MAXCHANS) %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMROUTINESPEC BLT(%NAME FROM,TO, %INTEGER LEN) %SYSTEMROUTINESPEC RDDUMP(%RECORD(SCB)%NAME S, %INTEGER LEN,%NAME LOC) %SYSTEMROUTINESPEC WTDUMP(%RECORD(SCB)%NAME S, %INTEGER LEN, %NAME LOC) %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) SPEC) %SYSTEMROUTINESPEC OPNDASQ(%INTEGER N,%RECORD(FILESPEC)%NAME FS,%INTEGER DAORSQ) %SYSTEMROUTINESPEC DASQ CHANNEL CHECK(%INTEGER N, DAORSQ FILE) %SYSTEMINTEGERFNSPEC DASQ LENGTH(%INTEGER CHAN, %NAME BEGIN,END) %SYSTEMROUTINESPEC CLDASQ(%INTEGER N,TYPE) %EXTERNALROUTINE XOPENSQ(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %RECORD(RINGHEADER)%NAME R OPNDASQ(N,FS,SQFILE) ! NOW INITIALISE BUFFER POINTERS R==DASQVEC(N)_NAME_RINGHEAD R_BYTPTR=RH&R_BUFADR+2 R_BYTCNT=0 %END %EXTERNALROUTINE OPENSQ(%INTEGER M,%STRING(255) SPEC) %RECORD(FILESPEC) FS FS=STRTOFS(SPEC) XOPENSQ(M,FS) %END %EXTERNALROUTINE READSQ(%INTEGER M, %NAME BEGIN,END) %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD %RECORD(RINGHEADER)%NAME R %INTEGER LENGTH,N,REMAINDER,BEG DASQ CHANNEL CHECK(M,SQFILE) DASQSCB==DASQVEC(M)_NAME R==DASQSCB_RINGHEAD %IF DASQSCB_IBUFOP=0 %START ERRMSG="Inputting from an SQ channel set for output" %SIGNAL 10,27,M %FINISH !SET FOR INPUT ONLY %IF DASQSCB_OBUFOP # 0 %THEN DASQSCB_OBUFOP=0 %AND DASQSCB_USETO=0 LENGTH=DASQ LENGTH(M,BEGIN,END) BEG=ADDR(BEGIN)&RH %IF LENGTH > R_BYTCNT %START %IF R_BYTCNT # 0 %START BLT(INTEGER(R_BYTPTR),INTEGER(BEG),R_BYTCNT) BEG=BEG+R_BYTCNT LENGTH=LENGTH-R_BYTCNT R_BYTPTR=RH&R_BUFADR+2 R_BYTCNT=0 %FINISH !HERE WHEN BYTE COUNT =0 REMAINDER=REM(LENGTH,DASQSCB_BLOCKSIZE) %IF REMAINDER = 0 %START RDDUMP(DASQSCB,LENGTH,INTEGER(BEG)) %RETURN %FINISH !ELSE READ N BLOCKS AND THEN REMAINDER INTO BUFFER N=LENGTH//DASQSCB_BLOCKSIZE %IF N # 0 %START RDDUMP(DASQSCB,N*DASQSCB_BLOCKSIZE,INTEGER(BEG)) BEG=BEG+N*DASQSCB_BLOCKSIZE %FINISH R_BYTPTR=RH&R_BUFADR+2 RDDUMP(DASQSCB,DASQSCB_BLOCKSIZE,INTEGER(R_BYTPTR)) R_BYTCNT=DASQSCB_BLOCKSIZE LENGTH=REMAINDER %FINISH !HERE WHEN LENGTH <= BYTE COUNT BLT(INTEGER(R_BYTPTR),INTEGER(BEG),LENGTH) R_BYTPTR=R_BYTPTR+LENGTH R_BYTCNT=R_BYTCNT-LENGTH %END %EXTERNALROUTINE WRITESQ(%INTEGER M, %NAME BEGIN, END) %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD %RECORD(RINGHEADER)%NAME R %INTEGER LENGTH,N,REMAINDER,BUFSPACE,BEG DASQ CHANNEL CHECK(M,SQFILE) DASQSCB==DASQVEC(M)_NAME R==DASQSCB_RINGHEAD %IF DASQSCB_OBUFOP=0 %START ERRMSG="Outputting to an SQ channel set for input" %SIGNAL 10,27,M %FINISH !SET FOR OUTPUT ONLY %IF DASQSCB_IBUFOP # 0 %THEN DASQSCB_IBUFOP=0 %AND DASQSCB_USETI=0 LENGTH=DASQ LENGTH(M,BEGIN,END) BUFSPACE=DASQSCB_BLOCKSIZE-R_BYTCNT BEG=ADDR(BEGIN)&RH %IF LENGTH > BUFSPACE %START %IF BUFSPACE # 0 %START BLT(INTEGER(BEG),INTEGER(R_BYTPTR),BUFSPACE) BEG=BEG+BUFSPACE LENGTH=LENGTH-BUFSPACE %FINISH !HERE ON A FULL BUFFER R_BYTPTR=RH&R_BUFADR+2 WTDUMP(DASQSCB,DASQSCB_BLOCKSIZE,INTEGER(R_BYTPTR)) R_BYTCNT=0 BUFSPACE=DASQSCB_BLOCKSIZE REMAINDER=REM(LENGTH,DASQSCB_BLOCKSIZE) %IF REMAINDER = 0 %START !WRITE OUT WHOLE MULTIPLE OF BLOCKS WTDUMP(DASQSCB,LENGTH,INTEGER(BEG)) %RETURN %FINISH !ELSE WRITE OUT N AND FILL BUFFER N=LENGTH//DASQSCB_BLOCKSIZE %IF N # 0 %START WTDUMP(DASQSCB,N*DASQSCB_BLOCKSIZE,INTEGER(BEG)) BEG=BEG+N*DASQSCB_BLOCKSIZE %FINISH LENGTH=REMAINDER %FINISH !HERE WHEN LENGTH <=BUFSPACE BLT(INTEGER(BEG),INTEGER(R_BYTPTR),LENGTH) R_BYTPTR=R_BYTPTR+LENGTH R_BYTCNT=R_BYTCNT+LENGTH %END %EXTERNALROUTINE CLOSESQ(%INTEGER M) CLDASQ(M,SQFILE) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DASQ.IMP !+ ! ^THIS IS THE LIBRARY OF DIRECT ACCESS AND SEQUENTIAL ACCESS FILES UTILITIES !^IT USES A SIMILAR MECHANISM TO THE STREAMS, USING THE SAME STREAM CONTROL !BLOCKS BUT UTILISING DUMP-MODE READING AND WRITING ROUTINES. !- %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER LH=8_777777000000, RH=8_777777 %EXTERNALINTEGERSPEC FUNCTION %EXTERNALRECORD(SCBNAME)%ARRAYSPEC DASQVEC(1:MAXCHANS) %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMROUTINESPEC WTDUMP(%RECORD(SCB)%NAME S, %INTEGER LEN, %NAME LOC) %SYSTEMROUTINESPEC SCBDEFINE(%INTEGER N, %RECORD(FILESPEC)%NAME FS, %RECORD(SCBNAME)%NAME IOSCB,%INTEGER CHNTYP) %SYSTEMPREDICATESPEC FILOP(%RECORD(SCB)%NAME S, %INTEGERNAME ERR) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %SYSTEMROUTINESPEC FREEVEC(%INTEGER THIS) %EXTERNALSTRING(12)%FNSPEC OCTTOSTR(%INTEGER N) %EXTERNALSTRING(255)%FNSPEC FSTOSTR(%RECORD(FILESPEC)%NAME FS) %SYSTEMROUTINE OPNDASQ(%INTEGER N,%RECORD(FILESPEC)%NAME FS,%INTEGER DAORSQ) %RECORD(SCB)%NAME S %INTEGER ERROR,FN %UNLESS DASQVEC(N)_NAME==UNDSCB %START ERRMSG="OPENing already open DA/SQ channel for ".FSTOSTR(FS) %SIGNAL 10,22,N %FINISH SCBDEFINE(N,FS,DASQVEC(N),DAORSQ) %IF DASQVEC(N)_NAME_DEVTYP=UNDEV %THEN DASQVEC(N)_NAME==UNDSCB %AND %RETURN S==DASQVEC(N)_NAME S_FLAGS=S_FLAGS!N ;!KEEP CHANNEL NUMBER IN FLAG WORD %IF S_DEVTYP=DTADEV %THEN S_STATUS=S_STATUS!8_300; !NON-STANDARD BLOCKS %IF FUNCTION#-1 %THEN FN=FUNCTION %ELSE FN=4;!DEFAULT TO SINGLE USER UPDATE S_FILOPFN=S_FILOPFN!FN %UNLESS FILOP(S,ERROR) %START ERRMSG="Cannot OPEN DA/SQ channel ".FSTOSTR(FS)." Error:".OCTTOSTR(ERROR) %SIGNAL 10,21,N %FINISH %END %SYSTEMROUTINE DASQ CHANNEL CHECK(%INTEGER N, DAORSQ FILE) %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD %UNLESS 1<=N<=MAXCHANS %START ERRMSG="Read/write to illegal DA/SQ channel" %SIGNAL 10,23,N %FINISH %IF DASQVEC(N)_NAME==UNDSCB %START ERRMSG="Read/write to DA/SQ channel before OPENing it" %SIGNAL 10,23,N %FINISH DASQSCB==DASQVEC(N)_NAME %IF DASQSCB_CHNTYP # DAORSQ FILE %START ERRMSG="Accessing a DA channel by an SQ routine or vice versa" %SIGNAL 10,24,N %FINISH %END %SYSTEMINTEGERFN DASQ LENGTH(%INTEGER CHAN, %INTEGER BEGIN,END) !** THE SECOND AND THIRD PARAMETERS ARE PASSED AS %NAME TYPES %INTEGER LENGTH,LN LN=END>>27; LN=1 %IF LN=0 LENGTH=END&RH - BEGIN&RH + LN %IF LENGTH<=0 %START ERRMSG="Storage area for DA/SQ routine inside out" %SIGNAL 10,25,CHAN %FINISH %RESULT=LENGTH %END %SYSTEMROUTINE CLDASQ(%INTEGER N,TYPE) %RECORD(SCB)%NAME DASQSCB; !CONTAINS THE CURRENT DASQ RECORD %RECORD(RINGHEADER)%NAME R %UNLESS 1<=N<=MAXCHANS %START ERRMSG="Closing illegal DA/SQ channel number" %SIGNAL 10,28,N %FINISH %IF DASQVEC(N)_NAME==UNDSCB %START ERRMSG="Closing DA/SQ channel before OPENing it" %SIGNAL 10,28,N %FINISH DASQSCB==DASQVEC(N)_NAME %IF DASQSCB_CHNTYP # TYPE %START ERRMSG="Closing a DA/SQ channel with the wrong routine" %SIGNAL 10,28,N %FINISH %IF TYPE=SQFILE %AND DASQSCB_OBUFOP # 0 %START; !OUTPUT REST OF ANY OUTPUT BUFFER R==DASQSCB_RINGHEAD R_BYTPTR=RH&R_BUFADR+2; !START OF BUFFER WTDUMP(DASQSCB,R_BYTCNT,INTEGER(R_BYTPTR)) %FINISH RELEASE(DASQSCB_FILOPFN>>18) FREEVEC(ADDR(DASQSCB)) DASQVEC(N)_NAME==UNDSCB %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DEFINE.IMP %INCLUDE "IMP:IOLIB.INC" %CONTROL 16_4000 %CONSTINTEGER LH=8_777777000000, RH=8_777777 %CONSTINTEGER BIT0=8_400000000000 %CONSTINTEGER OPEN=8_050, LOOKUP=8_076, ENTER=8_077 %EXTERNALINTEGERSPEC CPU; !TYPE OF CPU %EXTERNALRECORD(SCBNAME)%ARRAYSPEC INVEC(-1:MAXCHANS) %EXTERNALRECORD(SCBNAME)%ARRAYSPEC OUTVEC(-1:MAXCHANS) %EXTERNALRECORD(SCB)%NAMESPEC INSCB %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %EXTERNALRECORD(SCB)%SPEC IUNSCB %EXTERNALRECORD(SCB)%SPEC OUNSCB %EXTERNALINTEGERSPEC RDA %EXTERNALINTEGERSPEC RDB %EXTERNALINTEGERSPEC RDTMP %EXTERNALINTEGERSPEC RDTTYA %EXTERNALINTEGERSPEC RDTTYI %EXTERNALINTEGERSPEC WTA %EXTERNALINTEGERSPEC WTB %EXTERNALINTEGERSPEC WTTMP %EXTERNALINTEGERSPEC WTTTYA %EXTERNALINTEGERSPEC WTTTYI %EXTERNALINTEGERSPEC MODE; !VALUES -1 OR 0 - 8_17 %EXTERNALINTEGERSPEC FUNCTION; !VALUES -1 OR 1-7 %EXTERNALINTEGERSPEC ALLOCATE; !VALUES 0 - %EXTERNALINTEGERSPEC BLOCKSIZE; !-1 OR 3 - 10000 %EXTERNALINTEGERSPEC BUFFNUMS; !-1 OR <20 %EXTERNALINTEGERSPEC DENSITY; !0 - MAX DENSITIES %EXTERNALINTEGERSPEC ESTIMATE; !0 - %EXTERNALINTEGERSPEC EXTEND; !5 - 8_35 %EXTERNALINTEGERSPEC PARITY; !0 OR 1 %EXTERNALINTEGERSPEC VERSION; !0 - %EXTERNALINTEGERSPEC BYTE; !0 - %EXTERNALINTEGERSPEC TRMOP; !-1 OR 0 %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(6) SPEC) %EXTERNALSTRING(6)%FNSPEC SIXTOSTR(%INTEGER I) %SYSTEMROUTINESPEC SDOUTPUT(%INTEGER N,%STRING(1)%NAME STR) %EXTERNALROUTINESPEC WRITE OCTAL(%INTEGER N,M) %SYSTEMROUTINESPEC SOUTPUT(%INTEGER N) %EXTERNALINTEGERFNSPEC PPN %EXTERNALPREDICATESPEC CALLI2(%INTEGER N,%INTEGERNAME AC) %EXTERNALROUTINESPEC GET SWITCHES(%STRING(20)%NAME SWITCHES) %SYSTEMPREDICATESPEC IOUUO(%INTEGER FN,CHAN, %INTEGERNAME ADDR) %SYSTEMINTEGERFNSPEC GETVEC(%INTEGER SIZE) %SYSTEMROUTINESPEC FREEVEC(%INTEGER THIS) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %SYSTEMINTEGERFNSPEC IOWD(%INTEGER LEN, %INTEGERNAME LOC) %SYSTEMINTEGERFNSPEC TMPCOR(%INTEGER TYPE,BLOCK,NAME) %EXTERNALINTEGERFNSPEC OUTDEV %ROUTINESPEC MTA SETUP(%RECORD(SCB)%NAME SCB) %ROUTINESPEC FILL PATH BLOCK(%RECORD(PATHBLOCK)%NAME PATH, %RECORD(FILESPEC)%NAME FS, %INTEGER DEVNAM) !+ ! ^FOR EASE OF MANIPULATING AND PASSING FILE SPECIFICATIONS AS !PARAMETERS, THERE IS A PRE-DEFINED RECORD FORMAT CALLED 'FILESPEC'. !.NF ! %RECORDFORMAT FILESPEC(%STRING(6) DEV,FILE, %STRING(3) EXT, %C ! %INTEGER PPN, %STRING(6)%ARRAY SFDS(1:MAX SFDS) %INTEGER PROT, %STRING(20) SWITCHES) !.F !^THIS LIBRARY CONTAINS THREE ROUTINES WHICH ARE USEFUL IN USING THIS !RECORD STRUCTURE. ! ^THE OTHER COMMON OPERATIONS REQUIRED ON THESE RECORDS ARE !COPYING THEM AND ZEROING THEM. ^THIS IS ACCOMPLISHED BY THE LANGUAGE !FEATURES FS2=FS1 AND FS1=0 RESPECITVELY. ! ^FOR THE USE OF FILESPECS IN OPENING INPUT AND OUTPUT STREAMS MORE !EFFICIENTLY THAN BY USING 'DEFINE INPUT' AND 'DEFINE OUTPUT' SEE 'IOLIB' !DOCUMENTATION FOR 'XDEFINEINPUT' AND 'XDEFINEOUTPUT'. ! ^ALSO FOR FACILITIES TO READ FILE SPECIFICATIONS DIRECTLY FROM !THE CONSOLE SEE 'GETLIB' AND FOR READING CUSP-TYPE FILE SPECIFICATIONS !SEE 'CSPLIB' DOCUMENTATION. !- !+ %EXTERNALROUTINE WRITEFS(%RECORD(FILESPEC)%NAME FS) %INTEGER N PRINTSTRING(FS_DEV) PRINTSYMBOL(':') %IF FS_DEV#"" PRINTSTRING(FS_FILE) PRINTSYMBOL('.') %IF FS_EXT#"" PRINTSTRING(FS_EXT) %IF FS_PPN#0 %START PRINTSYMBOL('[') WRITEOCTAL(FS_PPN>>18,0); PRINTSYMBOL(','); WRITE OCTAL(FS_PPN&8_777777,0) %CYCLE N=1,1,MAX SFDS %EXIT %IF FS_SFDS(N)="" PRINTSYMBOL(','); PRINTSTRING(FS_SFDS(N)) %REPEAT PRINTSYMBOL(']') %FINISH %IF FS_PROT#0 %START PRINTSYMBOL('<') PRINTSYMBOL(FS_PROT>>N&7+'0') %FOR N=6,-3,0 PRINTSYMBOL('>') %FINISH PRINTSTRING(FS_SWITCHES) %END %EXTERNALSTRING(255)%FN FSTOSTR(%RECORD(FILESPEC)%NAME FS) %STRING(255) STR %INTEGER N N=OUTSTREAM SDOUTPUT(-1,STR) SOUTPUT(-1) WRITEFS(FS) CLOSE OUTPUT SELECT OUTPUT(N) %RESULT=STR %END !+ ! ^THE FOLLOWING ROUTINE UTILISE THE FREE-SPACE ALLOCATION ! ROUTINE FOR THE STREAM CONTROL BLOCKS. !.S !%SYSTEMROUTINE GETSCB(%RECORD(SCBNAME)%NAME R ,%INTEGER LEN) ! ^GETS THE REQUIRED SPACE. ^WHERE '15 AC(1)=CHAN *8_047040000004; !DEVCHR AC1,0 %RESULT=CHAN %IF AC(1)=0; !DEVCHR RETURNS ZERO IF CHANNEL NOT IN USE %REPEAT ERRMSG="All I/O channels in use" %SIGNAL 2,5,0; !NONE LEFT %END %SYSTEMPREDICATE FILOP(%RECORD(SCB)%NAME SCB, %INTEGERNAME ERROR) %CONSTINTEGER JBFF=8_121 %CONSTINTEGER TSK=8_646353 %INTEGER FUNCT, FOPFN, BUFADR,BUF FUNCT,OLD JBFF %INTEGERNAME LKENT ADDR FOPFN=SCB_FILOPFN&RH OLD JBFF=AC(JBFF) AC(JBFF)=SCB_RINGHEAD_BUFADR; !POINT TO START OF RING AREA FOR FILOP TO BUILD BUFFERS %IF SCB_DEVNAM>>18#TSK %START; !DO NOT USE FILOP FOR TASKS - DOES NOT WORK AC(1)=7<<18!ADDR(SCB_FILOPFN) *8_047040000155; !FILOP AC1, *8_334000000000; !SKIPA *8_476000000001; !SETOM AC1 ERROR=AC(1) AC(JBFF)=OLD JBFF; !RESTORE VALUE OF JBFF %IF ERROR=-1 %THEN %TRUE %ELSE ->FAIL %FINISH !OR ELSE DO OLD STYLE BUFADR=SCB_RINGHEAD_BUFADR; !GETS DESTROYED ON AN OPEN %UNLESS IOUUO(OPEN,SCB_FILOPFN>>18,SCB_STATUS) %START AC(JBFF)=OLD JBFF; !RESTORE VALUE ERRMSG="Cannot open device ".SIXTOSTR(SCB_DEVNAM) %SIGNAL 10,6,0; ! OPEN IOUUO %FINISH SCB_RINGHEAD_BUFADR=BUFADR; !RESTORE %IF 2<=FOPFN<=3 %START; !RESTRICTED CHOICE FUNCT=ENTER; BUF FUNCT=SCB_OBUFOP+8_6000<<18!SCB_BUFNUM>>18; !OUTBUF CHAN,N %ELSE FUNCT=LOOKUP; BUF FUNCT=SCB_IBUFOP+8_6000<<18!(SCB_BUFNUM&RH); !INBUF CHAN,N %FINISH !DO IT %IF SCB_BUFNUM#0 %START; !ONLY BUILD BUFFERS IF BUFFERS TO BUILD AC(1)=BUF FUNCT; !GET INBUF OR OUTBUF UUO *8_256000000001; !XCT 1 %FINISH AC(JBFF)=OLD JBFF; !RESTORE OLD VALUE %IF SCB_DEVNAM>>18=TSK %THEN LKENT ADDR==SCB_LKENT_NAM %ELSE LKENT ADDR==SCB_LKENT_CNT; !SHORT FOR TASKS %IF IOUUO(FUNCT,SCB_FILOPFN>>18,LKENT ADDR) %START %IF FOPFN<=3 %THEN ERROR=-1 %AND %TRUE; !SUCCESS !ELSE UPDATE OR APPEND %IF IOUUO(ENTER,SCB_FILOPFN>>18,LKENT ADDR) %START ERROR=-1; %TRUE %FINISH %FINISH FAIL: ERROR=RH&SCB_LKENT_EXT; !ERROR CODE %FALSE %END %SYSTEMPREDICATE TAPOP(%INTEGER FUNCT,CHAN,NARGS, %INTEGERARRAYNAME ARGS, %INTEGERNAME RESULT) ! FUNCT, CHAN(PHYSICAL) AND NECCESSARY ARGS MUST BE SET UP ON ENTRY ! THE RESULT(FOR READ FUNCTIONS), BEING RETURNED IN 'RESULT' %INTEGER N %INTEGERARRAY ARGUMENTS(0:14) ARGUMENTS(0)=FUNCT; ARGUMENTS(1)=CHAN %FOR N=0,1,NARGS %CYCLE ARGUMENTS(N+2)=ARGS(N) %REPEAT AC(1)=(NARGS+2)<<18 ! (INTEGER(ARGUMENTS(0))&RH) ; ![XWD N,ADDR] *8_047040000154; !TAPOP AC, *8_402000000002; !SETZM AC2 *8_476000000002; !SETOM AC2 N=AC(1); !RESULT %IF AC(2)=0 %THEN RESULT=N %AND %FALSE; !FAILURE %IF 8_1000<=FUNCT<=8_1777 %THEN RESULT=N; !RETURN RESULT %TRUE %END %EXTERNALSTRING(6)%FN JOBFILE(%STRING(3) NAME) ! RETURNS THE FILENAME 'XXXNAM' WHERE XXX = JOB NO. %EXTERNALINTEGERFNSPEC JOBNUM %EXTERNALSTRING(12)%FNSPEC INTTOSTR(%INTEGER DECNUM) %STRING(12) S NAME=SUBSTRING(NAME,1,3) %IF LENGTH(NAME)>3 S="00".INTTOSTR(JOBNUM).NAME %RESULT=SUBSTRING(S,LENGTH(S)-5,LENGTH(S)) %END %SYSTEMROUTINE SCHECK(%INTEGER N,CHNTYP,%RECORD(SCBNAME)%NAME IOSCB) %UNLESS 1<= N <= MAX CHANS %START ERRMSG="Defining illegal stream/channel number" %SIGNAL 10,1,N %FINISH %IF (CHNTYP=STREAM %AND IOSCB_NAME_DEVTYP #UNDEV) %OR (CHNTYP#STREAM %AND %NOT IOSCB_NAME==UNDSCB) %START ERRMSG="Stream/channel already defined" %SIGNAL 10,2,N %FINISH %END %SYSTEMROUTINE SCBDEFINE(%INTEGER N, %RECORD(FILESPEC)%NAME FS, %RECORD(SCBNAME)%NAME IOSCB, %INTEGER CHNTYP) %RECORD(SCB)%NAME S %RECORD(TTSCB)%NAME T %CONSTINTEGER SIXDSK=8_446353000000, SIXTMP=8_645560000000 %CONSTINTEGER SIXTTY=8_646471000000, SIXNUL=8_566554000000 %CONSTINTEGER SIXCTY=8_436471000000, SIXMPX=8_556070 000000 %INTEGER CHAN,TTYNAM,SIXDEV,DEVSIZE,DEVNAM,DEVTYP,UDX,BLKSIZE,ARG %INTEGERARRAY ARGS(0:1) %STRING(71) ERRSTR GET SWITCHES(FS_SWITCHES) SCHECK(N,CHNTYP,IOSCB) %IF FS_DEV = "" %START %IF FS_FILE = "" %THEN SIXDEV=SIXNUL %ELSE SIXDEV=SIXDSK; !DEFAULTS DSK OR NUL %ELSE SIXDEV=STRTOSIX(FS_DEV) ARG=SIXDEV %IF CALLI2(8_64,ARG) %START; %FINISH; !GET PHYSICAL DEVICE NAME DEVNAM=ARG %IF CALLI2(8_127,ARG) %START; %FINISH; !GET UDX UDX=ARG ARG=SIXDEV %IF CALLI2(8_53,ARG) %START; %FINISH;; ! DEVTYP UUO DEVTYP=ARG&63 %IF DEVTYP=TTYDEV %AND TRMOP=0 %START; !IF A TTY DEVICE AND TRMOP REQUESTED GETSCB(IOSCB,SCBSIZE) T==RECORD(ADDR(IOSCB_NAME)) T_DEVTYP=TTYDEV T_CHNTYP=CHNTYP T_ARGPTR=3<<18!ADDR(T_FUNCT) %IF MODE&8_17=8_10 %THEN T_FUNCT=8_11 %ELSE T_FUNCT=8_10 T_UDX=UDX %RETURN %FINISH %IF DEVNAM=0 %AND (SIXDEV # SIXTMP %AND SIXDEV # SIXMPX) %START; !UNKNOWN DEVICE (NOT "TMP" OR "MPX") ERRMSG="Unknown device ".FS_DEV; %SIGNAL 10,3,0 %FINISH %IF DEVTYP=TTYDEV %AND CHNTYP#STREAM %START ERRMSG="Not a DA or SQ type device - '".FS_DEV."'" %SIGNAL 10,20,0 %FINISH GETSCB(IOSCB,SCBSIZE+EXTEND+1) S==IOSCB_NAME S_DEVTYP=DEVTYP S_CHNTYP=CHNTYP S_UDX=UDX %IF MODE=-1 %START %IF CHNTYP=STREAM %START %IF FS_EXT="REL" %THEN S_STATUS=8_14 %ELSE S_STATUS=0 %ELSE S_STATUS=8_17; !DA OR SQ CHANNEL %ELSE S_STATUS=MODE S_LKENT==RECORD(ADDR(S_PATHBLK_SFDS(MAXSFDS))+1) S_LKENT_CNT=EXTEND S_LKENT_NAM=STRTOSIX(FS_FILE) S_LKENT_EXT=STRTOSIX(FS_EXT) S_LKENT_PPN=ADDR(S_PATHBLK) S_PATHARG=(3+MAX SFDS)<<18!ADDR(S_PATHBLK) FILL PATH BLOCK(S_PATHBLK,FS,SIXDEV) S_LKENT_PRV=FS_PROT<<27 !NOW SETTINGS DEPENDENT ON LENGTH OF BLOCK %IF EXTEND>=6 %THEN S_LKENT_VER=VERSION %IF EXTEND>=8 %THEN S_LKENT_EST=ESTIMATE %IF EXTEND>=9 %THEN S_LKENT_ALC=ALLOCATE S_BUFHEDS=ADDR(S_RINGHEAD_BUFADR); !INPUT BUFFERS !NOW HANDLE TMPCOR FILES %IF DEVNAM=0 %AND SIXDEV=SIXTMP %START; !DEVICE="TMP" S_DEVNAM=SIXDEV S_RINGHEAD_BUFADR=GETVEC(TMPCORSIZE+3) S_BUFNUM=1 S_RINGHEAD_BYTPTR=8_440700<<18!(S_RINGHEAD_BUFADR+2) S_TMPNAME=FS_FILE S_DEVTYP=TMPDEV %RETURN %FINISH !OR ELSE DISK TYPE CHAN=GETCHANNEL; !GET CHANNEL NUMBER S_FILOPFN=(8_400000!CHAN)<<18; !SET NO PROTECTION CHECKING FOR [1,2] & JACCT JOBS S_DEVNAM=DEVNAM S_IBUFOP=(8_056000!CHAN<<5)<<18; ! IN CHAN,0 S_OBUFOP=(8_057000!CHAN<<5)<<18; ! OUT CHAN,0 S_USETI=(8_074000!(CHAN<<5))<<18; ! USETI CHAN,0 S_USETO=(8_075000!(CHAN<<5))<<18; ! USETO CHAN,0 S_STATZ=(8_063000!CHAN<<5)<<18!8_740000; ! STATZ CHAN,740000 ARGS(0)=0; ARGS(1)=SIXDEV AC(1)=ADDR(ARGS(0)) *8_047040000101; !DEVSIZE AC1,0 *8_402000000001; !SETZM AC1 DEVSIZE=AC(1) DEVSIZE=2<<18!8_105 %IF DEVNAM=0 %AND SIXDEV=SIXMPX %IF DEVSIZE=0 %THEN DEVSIZE=2<<18!DSKBUFFERSIZE; !DEFAULT VALUES FOR DISK %IF BLOCKSIZE=-1 %THEN BLKSIZE=DEVSIZE&RH %ELSE BLKSIZE=BLOCKSIZE S_BLOCKSIZE=BLKSIZE-3; !DATA AREA SIZE %IF CHNTYP=STREAM %START %IF BUFFNUMS= -1 %THEN BUFFNUMS=DEVSIZE>>18; !DEFAULT NUMBER OF BUFFERS S_BUFNUM=BUFFNUMS; !FOR INPUT BUFFER %ELSE %IF CHNTYP=DAFILE %THEN S_BUFNUM=0 %ELSE S_BUFNUM=1 %FINISH %UNLESS S_BUFNUM=0 %START S_BUFVEC=(BLKSIZE*S_BUFNUM)<<18 S_RINGHEAD_BUFADR=GETVEC(S_BUFVEC>>18); S_BUFVEC=S_BUFVEC!S_RINGHEAD_BUFADR %FINISH %RETURN %END %EXTERNALROUTINE XDEFINPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %RECORD(TTSCB)%NAME T %RECORD(SCB)%NAME SCB %INTEGER DEVTYP,NWDS,ERROR SCBDEFINE(N,FS,INVEC(N),STREAM) SCB==INVEC(N)_NAME %IF SCB_DEVTYP=TTYDEV %AND TRMOP=0 %START T==RECORD(ADDR(INVEC(N)_NAME)) %IF T_FUNCT=8_10 %THEN T_OPER==RDTTYA %ELSE T_OPER==RDTTYI ->RETURN1 %FINISH !TRY TMPCOR %IF SCB_DEVTYP=TMPDEV %START NWDS=TMPCOR(1,IOWD(TMPCORSIZE,INTEGER(SCB_RINGHEAD_BUFADR+2)),LH&STRTOSIX(SCB_TMPNAME)) %IF NWDS # 0 %START; !SUCCESS SCB_OPER==RDTMP SCB_RINGHEAD_BYTCNT=5*NWDS INTEGER(SCB_RINGHEAD_BUFADR+1)=NWDS; !WORD COUNT ->RETURN %ELSE; !FAILURE, SO TRY DSK FREEVEC(SCB_RINGHEAD_BUFADR) FREEVEC(ADDR(SCB)) INVEC(N)_NAME==IUNSCB; !BACK TO UNASSIGNED FS_DEV="DSK"; FS_FILE=JOBFILE(FS_FILE); FS_EXT="TMP" XDEFINPUT(N,FS) ->RETURN %FINISH %FINISH %IF SCB_STATUS&15<=1 %THEN SCB_OPER==RDA %ELSE SCB_OPER==RDB %IF SCB_DEVTYP=MTADEV %THEN MTA SETUP(SCB) %AND ->RETURN; !HANDLE MAG TAPES ! OTHERWISE DISK, DTA ETC. SCB_FILOPFN=SCB_FILOPFN!1; !READ FUNCTION %UNLESS FILOP(SCB,ERROR) %START %IF SCB_PATHBLK_SWITCHES&8_20#0 %START; !IF LIBRARY PRESENT AND TO BE SEARCHED SCB_PATHBLK_FUNCT=-4; !GET ADDITIONAL PATH AC(1)=(3+MAXSFDS)<<18!ADDR(SCB_PATHBLK) *8_047040000110; !PATH AC1,0 *8_255000000000; !JFCL %IF FILOP(SCB,ERROR) %THEN ->RETURN; !TRY AGAIN %FINISH RELEASE(SCB_FILOPFN>>18&15) FREEVEC(SCB_BUFVEC&RH) FREEVEC(ADDR(SCB)) INVEC(N)_NAME==IUNSCB; !RESET TO UNASSIGNED ERRMSG="Lookup error for ".FSTOSTR(FS) %SIGNAL 10,4,ERROR; ! LOOKUP IOUUO %FINISH RETURN: SCB_RINGHEAD_BYTPTR=(SCB_RINGHEAD_BYTPTR&RH)!BYTE<<24 %UNLESS BYTE<=0 RETURN1: %IF N=INSTREAM %THEN INSCB==INVEC(N)_NAME; !SET CURRENT SCB POINTER %END %EXTERNALROUTINE XDEFOUTPUT(%INTEGER N, %RECORD(FILESPEC)%NAME FS) %RECORD(TTSCB)%NAME T %RECORD(SCB)%NAME SCB %INTEGER ERROR,FN SCBDEFINE(N,FS,OUTVEC(N),STREAM) SCB==OUTVEC(N)_NAME %IF SCB_DEVTYP=TTYDEV %AND TRMOP=0 %START T==RECORD(ADDR(OUTVEC(N)_NAME)) T_FUNCT=T_FUNCT-3; !MAKE WRITE FUNCTION %IF T_FUNCT=5 %THEN T_OPER==WTTTYA %ELSE T_OPER==WTTTYI ->RETURN1 %FINISH !TRY TMPCOR SCB==OUTVEC(N)_NAME SCB_BUFHEDS=SCB_BUFHEDS<<18; !MOVE OUTPUT BUFFERS TO LH OF WORD SCB_BUFNUM=SCB_BUFNUM<<18 %IF SCB_DEVTYP=TMPDEV %START SCB_OPER==WTTMP SCB_RINGHEAD_BYTCNT=5*TMPCORSIZE INTEGER(SCB_RINGHEAD_BUFADR+1)=TMPCORSIZE; !WORD COUNT ->RETURN %FINISH %IF SCB_STATUS&15<=1 %THEN SCB_OPER==WTA %ELSE SCB_OPER==WTB %IF SCB_DEVTYP=MTADEV %THEN MTA SETUP(SCB) %AND ->RETURN; !HANDLE MAG TAPES ! OTHERWISE DISK, DTA ETC. %IF FUNCTION#-1 %THEN FN=FUNCTION %ELSE FN=3;!DEFAULT TO 3 SCB_FILOPFN=SCB_FILOPFN!FN; !SET FUNCTION CODE %UNLESS FILOP(SCB,ERROR) %START RELEASE(SCB_FILOPFN>>18&15) FREEVEC(SCB_BUFVEC&RH) FREEVEC(ADDR(SCB)) OUTVEC(N)_NAME==OUNSCB; !RESET TO UNASSIGNED ERRMSG="Enter error for ".FSTOSTR(FS) %SIGNAL 10,5,ERROR; ! ENTER IOUUO %FINISH RETURN: SCB_RINGHEAD_BYTPTR=(SCB_RINGHEAD_BYTPTR&RH)!BYTE<<24 %UNLESS BYTE<=0 RETURN1: %IF N=OUTSTREAM %THEN OUTSCB==OUTVEC(N)_NAME; !SET CURRENT SCB POINER %END %SYSTEMROUTINE FILL PATH BLOCK(%RECORD(PATHBLOCK)%NAME PATH, %RECORD(FILESPEC)%NAME FS, %INTEGER DEVNAM) %INTEGER IMPLIED PPN, I %RETURN %IF CPU>2; !DO NOTHING ON DEC-20 %IF FS_PPN # 0 %START PATH_PPN=FS_PPN %CYCLE I=1,1,MAX SFDS %IF FS_SFDS(I)="" %THEN PATH_SFDS(I)=0 %AND %RETURN PATH_SFDS(I)=STRTOSIX(FS_SFDS(I)) %REPEAT %ELSE PATH_PPN=0; PATH_SFDS(I)=0 %FOR I=1,1,MAX SFDS PATH_FUNCT=-1; !READ DEFAULT PATH AC(1)=(3+MAX SFDS)<<18!ADDR(PATH) *8_047040000110; !PATH AC1,0 SET UP DEFAULT PATH *8_255000000000; !JFCL AC(1)=DEVNAM *8_047040000055; !DEVPPN AC1, GET THE IMPLIED PPN FOR THE DEVICE *8_402000000001; !SETZM AC1 ZERO ON ERROR IMPLIED PPN= AC(1) %IF IMPLIED PPN#0 %AND IMPLIED PPN # PATH_PPN %START PATH_PPN=0; PATH_SFDS(1)=0 PATH_SWITCHES=PATH_SWITCHES!8_40; !IGNORE IMPLIED PPN FOR ERSATZ DEVICES %FINISH %FINISH %END %ROUTINE MTA SETUP(%RECORD(SCB)%NAME SCB) !THIS ROUTINE SETS UP THE MAG TAPE UNIT ACCORDING TO SWITCHES !GIVEN IN THE SPEC STRING %INTEGER FUNCT,N %INTEGERARRAY ARGS(0:1) %ROUTINE DOTAPOP %INTEGER RESULT %UNLESS TAPOP(FUNCT,SCB_FILOPFN>>18,1,ARGS,RESULT) %START ERRMSG="TAPOP failure" %SIGNAL 10,15,FUNCT %FINISH %END SCB_STATUS=SCB_STATUS!PARITY<<9; !SET PARITY STATUS BITS %UNLESS IOUUO(OPEN,SCB_FILOPFN>>18,SCB_STATUS) %START ERRMSG="Cannot open device ".SIXTOSTR(SCB_DEVNAM) %SIGNAL 10,6,0; ! OPEN IOUUO %FINISH %IF DENSITY>=0 %START FUNCT=8_2001 ARGS(0)=DENSITY DOTAPOP %FINISH %IF BLOCKSIZE#-1 %START FUNCT=8_1006 ARGS(0)=BLOCKSIZE DOTAPOP %FINISH %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DEFAUL.IMP !DEFAUL.IMP !+ !.NF !%EXTERNALROUTINE DEFAULT(%RECORD(FILESPEC)%NAME FS, FS1) !.F ! ^THIS SETS DEFAULT VALUES FOR A GIVEN FILE SPECIFICATION, THAT IS, !IF A RECORD ITEM DOES NOT HAVE A VALUE THEN IT TAKES THE VALUE SPECIFIED !IN THE SECOND RECORD. !- %EXTERNALROUTINE DEFAULT(%RECORD(FILESPEC)%NAME S, S1) %INTEGER I S_DEV=S1_DEV %IF S_DEV="" S_FILE=S1_FILE %IF S_FILE="" S_EXT=S1_EXT %IF S_EXT="" %IF S_PPN=0 %START S_PPN=S1_PPN %CYCLE I=1,1,MAX SFDS S_SFDS(I)=S1_SFDS(I) %REPEAT %FINISH S_PROT=S1_PROT %IF S_PROT=0 S_SWITCHES=S1_SWITCHES %IF S_SWITCHES="" %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& CHECKP.IMP !CHECKP.IMP %INCLUDE "IMP:IOLIB.INC" %CONSTINTEGER LH=8_777777000000 %EXTERNALINTEGERFNSPEC OUTDEV %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %SYSTEMPREDICATESPEC FILOP(%RECORD(SCB)%NAME SCB, %INTEGERNAME ERROR) %EXTERNALROUTINE CHECKPOINT !OUTPUTS THE FILE SO FAR %INTEGER ERROR %IF DSKDEV # OUTDEV < XDSKDEV %THEN %RETURN ; !CANNOT DO ANYTHING OUTSCB_FILOPFN = LH&OUTSCB_FILOPFN!8_10; !CHECKPOINT FUNCTION %IF FILOP(OUTSCB,ERROR) %THEN %RETURN; !SUCCESS ERRMSG="Checkpoint failure" %SIGNAL 10,14,ERROR %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& CLOSE.IMP %INCLUDE "IMP:IOLIB.INC" %CONTROL 16_4000; !ALLOW RECORD EQUATING %EXTERNALRECORD(SCBNAME)%ARRAYSPEC INVEC(-1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH CHANNEL %EXTERNALRECORD(SCBNAME)%ARRAYSPEC OUTVEC(-1:MAXCHANS); !FOR OUTPUT %EXTERNALRECORD(SCB)%NAMESPEC INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %EXTERNALRECORD(SCB)%SPEC ITYSCB %EXTERNALRECORD(SCB)%SPEC OTYSCB %EXTERNALRECORD(SCB)%SPEC IUNSCB %EXTERNALRECORD(SCB)%SPEC OUNSCB %EXTERNALSTRING(255)%SPEC ERRMSG %CONSTINTEGER OPEN=8_050, LOOKUP=8_076, ENTER=8_077 %EXTERNALROUTINESPEC XDEFOUTPUT(%INTEGER N,%RECORD(FILESPEC)%NAME FS) %SYSTEMROUTINESPEC FREEVEC(%INTEGER THIS) %EXTERNALROUTINE CLOSEINPUT %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %INTEGER INSTR %RETURN %IF INSCB_DEVTYP=UNDEV INSTR=INSTREAM %RETURN %IF INSTR=0 %IF INSCB_DEVTYP#STRDEV %START %IF INSCB_DEVTYP=TMPDEV %START FREEVEC(INSCB_RINGHEAD_BUFADR) %ELSE RELEASE(INSCB_FILOPFN>>18&15) FREEVEC(INSCB_BUFVEC&8_777777) %FINISH %FINISH FREEVEC(ADDR(INSCB)) !DEFAULT BACK TO UNDEFINED INVEC(INSTR)_NAME==IUNSCB INSCB==INVEC(INSTR)_NAME %END %EXTERNALROUTINE CLOSEOUTPUT %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %SYSTEMINTEGERFNSPEC TMPCOR(%INTEGER TYPE,BLOCK,FILENAME) %SYSTEMINTEGERFNSPEC IOWD(%INTEGER LEN, %INTEGERNAME LOC) %EXTERNALINTEGERFNSPEC STRTOSIX(%STRING(255) S) %EXTERNALSTRING(6)%FNSPEC JOBFILE(%STRING(3) NAME) %RECORD(FILESPEC) TMPFS %RECORD(SCB)%NAME TMPSCB %RECORD(STRSCB)%NAME STRSCB %INTEGER N,NCHRS,NWDS,OUTST %RETURN %IF OUTSCB_DEVTYP=UNDEV OUTST=OUTSTREAM %RETURN %IF OUTST=0 %IF OUTSCB_DEVTYP=STRDEV %START STRSCB==RECORD(ADDR(OUTVEC(OUTST)_NAME)) AC(1)=STRSCB_LENPTR AC(2)=STRSCB_LENGTH *8_137100 000001 ;!DPB 2,1 - LENGTH ->RETURN %FINISH %IF OUTSCB_DEVTYP = TMPDEV %START; !TMPCOR NCHRS=TMPCORSIZE*5-OUTSCB_RINGHEAD_BYTCNT; !NUMBER OF CHARS IN BUFFER NWDS=NCHRS//5+1; !NUMBER OF WORDS IN THE BUFFER %CYCLE N=0,1,REM(NCHRS,20); !REST OF 4 WORDS PRINTSYMBOL(0); !FILL REST OF WORD WITH ZEROS %REPEAT %IF TMPCOR(3,IOWD(NWDS,INTEGER(OUTSCB_RINGHEAD_BUFADR+2)),STRTOSIX(OUTSCB_TMPNAME)) = 0 %START ! TMPCOR FAILED, OPEN DSK FILE TMPSCB==OUTSCB; OUTVEC(OUTST)_NAME==OUNSCB; OUTSCB==OUTVEC(OUTST)_NAME TMPFS_DEV="DSK"; TMPFS_FILE=JOBFILE(TMPSCB_TMPNAME) TMPFS_EXT="TMP"; TMPFS_SWITCHES="/MODE:#14" XDEFOUTPUT(OUTST,TMPFS) SELECT OUTPUT(OUTST) %CYCLE N=2,1,NWDS+2; !NUMBER OF WORDS PRINTSYMBOL(INTEGER(TMPSCB_RINGHEAD_BUFADR+N)) %REPEAT FREEVEC(TMPSCB_RINGHEAD_BUFADR) FREEVEC(ADDR(TMPSCB)) %ELSE FREEVEC(OUTSCB_RINGHEAD_BUFADR) ->RETURN %FINISH %FINISH AC(1)=OUTSCB_OBUFOP; !OUT CHAN, ->RETURN %IF AC(1)=0; !I.E. A TTY USING TRMOPS *8_256000000001; !XCT 1 *8_255000000000; !JFCL RELEASE(OUTSCB_FILOPFN>>18&15) FREEVEC(OUTSCB_BUFVEC&8_777777) RETURN: FREEVEC(ADDR(OUTSCB)) !DEFAULT BACK TO UNDEFINED OUTVEC(OUTST)_NAME==OUNSCB OUTSCB==OUTVEC(OUTST)_NAME %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& REWIND.IMP %include "imp:iolib.inc" %externalroutinespec reset input %externalroutinespec uset input(%integer block) %externalroutine rewind input !============================ !reset the current input stream to the beginning %externalrecord(scb)%namespec inscb %integer bufadr,n %return %if inscb_devtyp=undev %or inscb_devtyp=ttydev inscb_nxtchr=0; inscb_flags=inscb_flags&8_377777 777777; !clear pending symbols reset input %if inscb_devtyp=strdev %or inscb_devtyp=tmpdev uset input(1) inscb_ringhead_bytcnt=0; !no bytes left ! inscb_ringhead_bufadr=inscb_ringhead_bufadr&8_377777 777777; ! and use bit off bufadr=inscb_ringhead_bufadr&8_777777 %for n=1,1,inscb_bufnum&8_777777 %cycle; !go round ring zeroing word count integer(bufadr+1)=integer(bufadr+1)&8_777777 000000 bufadr=integer(bufadr)&8_777777 %repeat %end %endoffile $$$$$$$$$$$$ &&&&&&&&&&&& RESETI.IMP %INCLUDE "IMP:IOLIB.INC" %CONTROL 16_4000; !ALLOW RECORDS TO MATCH %SYSTEMROUTINESPEC FREEVEC(%INTEGER ADR) %SYSTEMINTEGERFNSPEC GETVEC(%INTEGER SIZE) %EXTERNALRECORD(SCBNAME)%ARRAYSPEC INVEC(-1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH CHANNEL %EXTERNALRECORD(SCB)%NAMESPEC INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMPREDICATESPEC FILOP(%RECORD(SCB)%NAME SCB, %INTEGERNAME ERR) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %EXTERNALROUTINE RESETINPUT %RECORD(STRSCB)%NAME STRSCB %INTEGER ERR,BYTE %IF INSCB_DEVTYP=UNDEV %OR INSCB_DEVTYP=TTYDEV %THEN %RETURN INSCB_NXTCHR=0; INSCB_FLAGS=INSCB_FLAGS&8_377777 777777; !CLEAR PENDING SYMBOLS %IF INSCB_DEVTYP=STRDEV %START; !A STRING STRSCB==RECORD(ADDR(INSCB)) STRSCB_POINTER=STRSCB_LENPTR; !POINT TO BEGINNING AC(2)=STRSCB_LENPTR *8_135040 000002; !LDB 1,2 -GET LENGTH STRSCB_LENGTH=AC(1) STRSCB_NXTCHR=0 %RETURN %FINISH %IF INSCB_DEVTYP=TMPDEV %START; !TMPCOR INSCB_RINGHEAD_BYTPTR=8_700000000+INSCB_RINGHEAD_BUFADR+2; !RESET POINTER INSCB_RINGHEAD_BYTCNT=INTEGER(INSCB_RINGHEAD_BUFADR+1)*5; !AND BYTE COUNT %RETURN %FINISH BYTE=(INSCB_RINGHEAD_BYTPTR>>24)&8_77; !EXTRACT BYTE SIZE RELEASE(INSCB_FILOPFN>>18&15) !WE MUST FREE AND REGET THE BUFFER RING BECAUSE FILOP SETS IT IP FREEVEC(INSCB_BUFVEC&8_777777); !FREE OLD BUFFERS INSCB_RINGHEAD_BUFADR=GETVEC(INSCB_BUFVEC>>18) INSCB_BUFVEC=(INSCB_BUFVEC&8_777777000000)!INSCB_RINGHEAD_BUFADR %UNLESS FILOP(INSCB,ERR) %THEN %C ERRMSG="Cannot RESET input stream" %AND %SIGNAL 10,12,INSTREAM INSCB_NXTCHR=0 INSCB_RINGHEAD_BYTPTR=(INSCB_RINGHEAD_BYTPTR&8_777777)!(BYTE<<24); !RESET BYTE SIZE %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& RESETO.IMP %INCLUDE "IMP:IOLIB.INC" %CONTROL 16_4000; !ALLOW RECORDS TO MATCH %SYSTEMROUTINESPEC FREEVEC(%INTEGER ADR) %SYSTEMINTEGERFNSPEC GETVEC(%INTEGER SIZE) %EXTERNALRECORD(SCBNAME)%ARRAYSPEC OUTVEC(-1:MAXCHANS); !FOR OUTPUT %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMPREDICATESPEC FILOP(%RECORD(SCB)%NAME SCB,%INTEGERNAME ERR) %SYSTEMROUTINESPEC RELEASE(%INTEGER CHAN) %EXTERNALROUTINE RESET OUTPUT %RECORD(STRSCB)%NAME STRSCB %INTEGER ERR,BYTE %IF OUTSCB_DEVTYP=UNDEV %OR OUTSCB_DEVTYP=TTYDEV %THEN %RETURN %IF OUTSCB_DEVTYP=STRDEV %START; !A STRING STRSCB==RECORD(ADDR(OUTSCB)) STRSCB_NXTCHR=0 STRSCB_LENGTH=0 STRSCB_POINTER=STRSCB_LENPTR %RETURN %FINISH %IF OUTSCB_DEVTYP=TMPDEV %START; !TMPCOR OUTSCB_RINGHEAD_BYTPTR=8_700000000+OUTSCB_RINGHEAD_BUFADR+2; !RESET POINTER OUTSCB_RINGHEAD_BYTCNT=INTEGER(OUTSCB_RINGHEAD_BUFADR+1)*5; !AND BYTE COUNT %RETURN %FINISH AC(1)=OUTSCB_OBUFOP *8_256000000001; !XCT 1 OUT CHAN,0 *8_255000000000; !JFCL BYTE=(OUTSCB_RINGHEAD_BYTPTR>>24)&8_77; !SAVE BYTE SIZE RELEASE(OUTSCB_FILOPFN>>18&15) !WE MUST FREE AND REGET THE BUFFER RING BECAUSE FILOP SETS IT IP FREEVEC(OUTSCB_BUFVEC&8_777777); !FREE OLD BUFFERS OUTSCB_RINGHEAD_BUFADR=GETVEC(OUTSCB_BUFVEC>>18) OUTSCB_BUFVEC=(OUTSCB_BUFVEC&8_777777000000)!OUTSCB_RINGHEAD_BUFADR %UNLESS FILOP(OUTSCB,ERR) %THEN %C ERRMSG="Cannot RESET output stream" %AND %SIGNAL 10,13,OUTSTREAM OUTSCB_RINGHEAD_BYTPTR=(OUTSCB_RINGHEAD_BYTPTR&8_777777)!(BYTE<<24); !RESET BYTE SIZE %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& USET.IMP %INCLUDE "IMP:IOLIB.INC" %EXTERNALINTEGERFNSPEC INDEV %EXTERNALINTEGERFNSPEC OUTDEV %EXTERNALRECORD(SCB)%NAMESPEC INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %EXTERNALSTRING(255)%SPEC ERRMSG !+ !%EXTERNALROUTINE USET INPUT(%INTEGER I) ! ^SETS THE NUMBER OF THE NEXT BLOCK TO BE INPUT, TO BE THE ONE SPECIFIED. !- %EXTERNALROUTINE USET INPUT(%INTEGER N) %RETURN %UNLESS INDEV = DSKDEV %OR INDEV = DTADEV; !SUITABLE ONLY ON DSK: AND DTA: AC(1)=INSCB_USETI!N&8_777777 *8_256000000001; !XCT AC1 %END !+ !%EXTERNALROUTINE USET OUTPUT(%INTEGER I) ! ^SETS THE NUMBER OF THE NEXT BLOCK TO BE OUTPUT, TO BE THE ONE SPECIFIED. !- %EXTERNALROUTINE USET OUTPUT(%INTEGER N) %RETURN %UNLESS OUTDEV = DSKDEV %OR OUTDEV = DTADEV; !SUITABLE ONLY ON DSK: AND DTA: AC(1)=OUTSCB_USETO!N&8_777777 *8_256000000001; !XCT AC1 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& PROMPT.IMP %INCLUDE "IMP:IOLIB.INC" %EXTERNALRECORD(SCB)%NAMESPEC INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALPREDICATE INPUT PENDING %INTEGERARRAY ARGS(0:1) %TRUE %IF INSCB_NXTCHR#0 %IF INSCB_DEVNAM>>18=8_606471 %START; !FOR PTYS %IF INSCB_RINGHEAD_BYTCNT>0 %THEN %TRUE AC(1)=INSCB_IBUFOP *8_256000 000001; !XCT [IN CHAN,0] %IF INSCB_RINGHEAD_BYTCNT>0 %THEN %TRUE %ELSE %FALSE %FINISH %IF INSCB_DEVTYP#TTYDEV %THEN %TRUE *8_047040 000034; !GETLIN 1, %FALSE %IF AC(1)>>18=0; !IF DETACHED *8_047040000030; !PJOB AC1, *8_211041000000; !MOVNI AC1,(AC1) *8_047040000061; !JOBSTS AC1, *8_402000000001; !SETZM AC1 %FALSE %IF AC(1)&8_100000 000000; !FALSE IF IT IS AT MONITOR LEVEL %IF INSCB_UDX=0 %START; !SEE IF UDX SET, IF NOT THEN OUR TERMINAL *8_051540000000; !SKPINC (ANY INPUT) *8_634040000001; !TDZA 1,1 *8_476000000001; !SETOM AC1 %ELSE ARGS(0)=1; !TEST FOR INPUT PENDING ARGS(1)=INSCB_UDX AC(1)=2<<18!ADDR(ARGS(0)) *8_047040000116; !TRMOP 1, *8_634040000001; !TDZA 1,1 *8_476000000001; !SETOM 1 %FINISH %IF AC(1)=-1 %THEN %TRUE %FALSE %END !+ !%EXTERNALROUTINE REPORT(%STRING(255) RSTRING) ! ^OUTPUTS STRING TO THE TERMINAL IRRESPECTIVE OF THE OUTPUT STREAM NUMBER. !- %EXTERNALROUTINE REPORT(%STRING(255) RSTRING) %INTEGER N N=OUTSTREAM; !SAVE CURRENT OUTPUT STREAM NUMBER SELECT OUTPUT(0) PRINTSTRING(RSTRING) SELECT OUTPUT(N) %END %EXTERNALROUTINE PROMPT(%STRING(255) S) %SYSTEMROUTINESPEC OUTPUT %INTEGER N %RETURN %IF INSCB_DEVTYP # TTYDEV *8_047040 000034; !GETLIN 1, %RETURN %IF AC(1)>>18=0; !IF DETACHED N=OUTSTREAM SELECT OUTPUT(0) PRINTSTRING(S); OUTPUT SELECT OUTPUT(N) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& IOLIB.IMP %INCLUDE "IMP:IOLIB.INC" %OWNINTEGER INPUT, OUTPUT; !CURRENT CHANNEL NUMBERS %EXTERNALRECORD(SCBNAME)%ARRAY DASQVEC(1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH DASQ CHANNEL %EXTERNALRECORD(SCBNAME)%ARRAY INVEC(-1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH STREAM %EXTERNALRECORD(SCBNAME)%ARRAY OUTVEC(-1:MAXCHANS); !FOR OUTPUT %EXTERNALRECORD(SCB)%NAME INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALRECORD(SCB)%NAME OUTSCB %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMROUTINE SINPUT(%INTEGER N) INPUT=N INSCB ==INVEC(N)_NAME %END %EXTERNALROUTINE SELINPUT(%INTEGER N) %UNLESS 0 <= N <= MAX CHANS %START ERRMSG="Selecting illegal input stream" %SIGNAL 10,10,N %FINISH SINPUT(N) %END %SYSTEMROUTINE SOUTPUT(%INTEGER N) OUTPUT=N OUTSCB ==OUTVEC(N)_NAME %END %EXTERNALROUTINE SELOUTPUT(%INTEGER N) %UNLESS 0 <= N <= MAX CHANS %START ERRMSG="Selecting illegal output stream" %SIGNAL 10,11,N %FINISH SOUTPUT(N) %END %EXTERNALROUTINE SPACES(%INTEGER N) %RETURN %IF N<=0 SPACES(N-1) SPACE %END !+ !%EXTERNALINTEGERFN INSTREAM ! ^RETURNS THE NUMBER OF THE CURRENTLY SELECTED INPUT STREAM. !- %EXTERNALINTEGERFN INSTREAM %RESULT=INPUT %END !+ !%EXTERNALINTEGERFN OUTSTREAM ! ^RETURNS THE NUMBER OF THE CURRENTLY SELECTED OUTPUT STREAM. !- %EXTERNALINTEGERFN OUTSTREAM %RESULT=OUTPUT %END !+ !%EXTERNALINTEGERFN INDEV ! ^RETURNS THE DEVICE TYPE OF THE CURRENTLY SELECTED INPUT STREAM. !- %EXTERNALINTEGERFN INDEV %RESULT=INSCB_DEVTYP %END !+ !%EXTERNALINTEGERFN OUTDEV ! ^RETURNS THE DEVICE TYPE OF THE CURRENTLY SELECTED OUTPUT STREAM. !- %EXTERNALINTEGERFN OUTDEV %RESULT=OUTSCB_DEVTYP %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& VECLIB.IMP !VECLIB.IMP !LIBRARY OF ROUTINES USING KNUTH'S DOUBLY LINKED DYNAMIC STORAGE ALLOCATION !ROUTINES %SYSTEMROUTINESPEC GET PAGES(%INTEGER FIRST,LAST) %SYSTEMROUTINESPEC ZERO(%NAME FROM,TO) %EXTERNALINTEGERARRAYSPEC HEAP(0:1); !FREE SPACE VECTOR WITH DUMMY SIZE %EXTERNALINTEGER HEAPBASE,HEAPTOP %EXTERNALINTEGERSPEC HEAPSIZE %EXTERNALSTRING(255)%SPEC ERRMSG %OWNINTEGER AVAIL,ROVER %CONSTINTEGER TAG=8_400000 000000 %CONSTINTEGER UNDEF=8_777777 %CONSTINTEGER DEFLT HEAPSIZE=9 %CONSTINTEGERNAME JBFF=8_121,JBREL=8_44 !%ROUTINESPEC PRFREELIST %ROUTINESPEC FREEVEC(%INTEGER SIZE) %ROUTINE GET SPACE(%INTEGER N) !=============================== %INTEGER SIZE,OLDTOP %ON %EVENT 2 %START ->FAIL %FINISH OLDTOP=HEAPTOP HEAPTOP=(HEAPTOP+N)!8_777; !TOP OF PAGE %IF HEAPSIZE=-1 %START %IF HEAPTOP>INTEGER(JBREL) %START; !GET MORE CORE IF DYNAMIC GET PAGES((OLDTOP>>9)+1,HEAPTOP>>9) !NOW MAKE AREA INTO A FREE VECTOR AND THEN ADD IT TO LIST INTEGER(JBFF)=HEAPTOP+1 INTEGER(OLDTOP)=TAG!(HEAPTOP-OLDTOP)<<18; !HEAD OF NEW VECTOR = '-' SIZE,,0 INTEGER(HEAPTOP-1)=TAG; ! END OF NEW VECTOR INTEGER(HEAPTOP)=TAG; ! END OF LIST FREEVEC(OLDTOP+1) %RETURN %FINISH %FINISH FAIL: HEAPTOP=OLDTOP ERRMSG=ERRMSG." for heap" %SIGNAL 2,4,N-2 %END %INTEGERFN SIZE OF(%INTEGER X) %RESULT=INTEGER(X)>>18&8_377777 %END %INTEGERFN LINK OF(%INTEGER X) %RESULT=INTEGER(X)&8_777777 %END %PREDICATE FREE(%INTEGER X) %TRUE %IF INTEGER(X)>=0 %FALSE %END %ROUTINE SET LINK(%INTEGER N,M) INTEGER(N)=(INTEGER(N)&8_777777000000)!M %END %ROUTINE SET SIZE(%INTEGER N,M) INTEGER(N)=(INTEGER(N)&8_400000777777)!M<<18 %END %ROUTINE SET TAG(%INTEGER X) INTEGER(X)=INTEGER(X)!8_400000000000 %END %ROUTINE CLEAR TAG(%INTEGER X) INTEGER(X)=INTEGER(X)&8_377777777777 %END %SYSTEMROUTINE INITHEAP %INTEGER AC,HEAPSIZ,SIZE %OWNINTEGER HEAPRESTART=0 ! SET UP THE HEAP %IF HEAPRESTART=0 %START %IF HEAPSIZE=-1 %THEN HEAPSIZ=DEFLT HEAPSIZE %ELSE HEAPSIZ=HEAPSIZE; !DEFAULT SIZE %IF ADDR(HEAP(0))=UNDEF %START; !IS IT DUMMY HEAPBASE=INTEGER(JBFF) AC=HEAPBASE+HEAPSIZ %IF AC>INTEGER(JBREL) %START GET PAGES((INTEGER(JBREL)>>9)+1,AC>>9) %FINISH HEAPTOP=INTEGER(JBREL) HEAPSIZ=HEAPTOP-HEAPBASE INTEGER(JBFF)=INTEGER(JBREL)+1 %ELSE HEAPBASE=ADDR(HEAP(0)) HEAPTOP=HEAPBASE+HEAPSIZ %FINISH HEAP RESTART=-1 %ELSE ZERO(INTEGER(HEAPBASE),INTEGER(HEAPTOP)) !NOW SET UP THE HEAP AS A FREE SPACE LIST SIZE=HEAPTOP-HEAPBASE-3 INTEGER(HEAPBASE)=HEAPBASE+3; ! DUMMY HEADER -> FIRST INTEGER(HEAPBASE+1)=HEAPBASE+3; ! DUMMY HEADER -> PREVIOUS INTEGER(HEAPBASE+2)=TAG; ! DUMMY TAIL = NOT FREE ! INTEGER(HEAPBASE+3)=SIZE<<18!HEAPBASE;! HEADER SIZE,, -> NEXT INTEGER(HEAPBASE+4)=HEAPBASE; ! HEADER ->PREVIOUS ! ! FREE VECTOR AREA INTEGER(HEAPTOP-1)=SIZE<<18; ! TAIL SIZE,,0 INTEGER(HEAPTOP)=TAG; !OFF TOP OF VECTOR AREA AVAIL=HEAPBASE ROVER=AVAIL %END %SYSTEMINTEGERFN GETVEC(%INTEGER N) %INTEGER P,K,L,PREVIOUS P=ROVER; N=N+2;!ADJUST N FOR HEAD AND TAIL WORDS %WHILE SIZE OF(P)7 %FINISH %ELSE ->7 %IF FREE(P0-1) F=LINK OF(AVAIL) B=AVAIL %FINISH SET LINK(P0,F) SET LINK(P0+1,B) SET LINK(F+1,P0) SET LINK(B,P0) ->8 7: PREVIOUS SIZE=SIZE OF(P0-1) N=N+PREVIOUS SIZE P0=P0-PREVIOUS SIZE 8: SET SIZE(P0,N); CLEAR TAG(P0) SET SIZE(P1-1,N); CLEAR TAG(P1-1) %END %ENDOFFILE !HEREAFTER ARE DEBUGGING ROUTINES FOR PRINTING OUT VECTOR LIST VALUES %EXTERNALROUTINESPEC WRITEOCTAL(%INTEGER N,M) %EXTERNALINTEGERFNSPEC OUTSTREAM %ROUTINE PRINT WORD 1(%INTEGER N) %IF INTEGER(N)<0 %THEN PRINTSYMBOL('+') %ELSE PRINTSYMBOL('-') WRITE(INTEGER(N)>>18&8_377777,7); WRITEOCTAL(INTEGER(N)&8_777777,7);NEWLINE %END %ROUTINE PRINT WORD 2(%INTEGER N) WRITE OCTAL(INTEGER(N)&8_777777,15); NEWLINE %END %EXTERNALROUTINE PRVEC(%INTEGER N) %INTEGER SIZE SIZE=INTEGER(N)>>18&8_377777 NEWLINE PRINT WORD 1(N) PRINT WORD 2(N+1) %IF INTEGER(N)>0 PRINTSTRING("VECTOR AREA"); NEWLINE PRINT WORD 1(N+SIZE-1) %END %EXTERNALROUTINE PRFREELIST !PRINT OUT THE WHOLE FREE LIST %INTEGER P,OUT OUT=OUTSTREAM SELECT OUTPUT(0) P=AVAIL PRINTSTRING("FREE LIST:- "); NEWLINE %CYCLE PRVEC(P) NEWLINE P=LINK OF(P) %REPEAT %UNTIL P=AVAIL SELECT OUTPUT(OUT) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& HEX.IMP !+ !.AP ! ^THIS LIBRARY CONTAINS HEXIDECIMAL READING AND WRITING ROUTINES !- %SYSTEMINTEGERFNSPEC STON(%STRING(1)%NAME STR,%ROUTINE READER(%INTEGERNAME N)) %EXTERNALSTRING(255)%SPEC ERRMSG !+ !%EXTERNALROUTINE READ HEX(%INTEGERNAME N) ! ^READS AN HEX NUMBER FROM THE CURRENT INPUT STREAM INTO N. !- %EXTERNALROUTINE READ HEX(%INTEGERNAME N) %INTEGER S,SIGN S=NEXTSYMBOL %WHILE S<=' ' %THEN SKIPSYMBOL %AND S=NEXTSYMBOL N=0; SIGN=0 %IF S='-' %THEN SIGN='-' %AND SKIPSYMBOL %AND S=NEXTSYMBOL %UNLESS '0'<=S<='9' %OR 'A'<=S<='F' %START ERRMSG="Hex integer not found" %SIGNAL 3,1,S %FINISH %CYCLE %IF '0'<=S<='9' %START N=N<<4+(S-'0') SKIPSYMBOL; S=NEXTSYMBOL %CONTINUE %FINISH %IF 'A'<=S<='F' %START N=N<<4+(S-'A'+10) SKIP SYMBOL; S=NEXT SYMBOL %CONTINUE %FINISH %EXIT %REPEAT %IF SIGN#0 %THEN N=-N %END !+ !%EXTERNALROUTINE WRITE HEX(%INTEGER N,S) ! ^OUTPUTS A SIGNED HEX INTEGER N WITH S PLACES ON THE CURRENT OUTPUT STREAM. ! ^IF S=0 THEN NO PRECEDING SPACES ARE OUTPUT !- %EXTERNALROUTINE WRITE HEX(%INTEGER N,S) %INTEGER SIGN,SYM %ROUTINESPEC P(%INTEGER N) %IF S<=0 %THEN SIGN=S %ELSE SIGN=' ' S=IMOD(S); S=63 %IF S>63 %IF N<0 %THEN N=-N %AND SIGN='-' P(N) %ROUTINE P(%INTEGER N) S=S-1 P(N//16) %IF N>=16 %IF SIGN > 0 %START SPACES(S-1) PRINTSYMBOL(SIGN); SIGN=0 %ELSE %IF SIGN <0 %THEN SPACES(S) %AND SIGN=0 SYM=REM(N,16)+'0' %IF SYM >'9' %THEN SYM=SYM+7 PRINTSYMBOL(SYM) %END %END %EXTERNALINTEGERFN STRTOHEX(%STRING(1)%NAME STR) %RESULT=STON(STR,READHEX) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& PPN.IMP !+ !.AP ! ^THIS LIBRARY CONTAINS ROUTINES TO READ AND WRITE PPNS. !- %INCLUDE "IMP:IOLIB.INC" %EXTERNALROUTINESPEC READ OCTAL(%INTEGERNAME OCT) %EXTERNALSTRING(12)%FNSPEC OCTTOSTR(%INTEGER N) %EXTERNALINTEGERFNSPEC PPN !+ !%EXTERNALROUTINE READPPN(%INTEGERNAME PPN) ! ^READS A PROJECT-PROGRAMMER NUMBER 'PROJ,PROG' INTO PPN !- %EXTERNALROUTINE READPPN(%INTEGERNAME APPN) %INTEGER PROJ,PROG,N %RECORD(PATHBLOCK) PATH PROG=0; PROJ=0 %WHILE NEXTSYMBOL=' ' %THEN SKIPSYMBOL %IF NEXTSYMBOL='[' %THEN SKIPSYMBOL %IF NEXTSYMBOL='-' %START SKIPSYMBOL PATH=0 PATH_FUNCT=-1 AC(1)=8<<18!ADDR(PATH) *8_047040000110; !PATH AC1,0 SET UP DEFAULT PATH *8_255000000000; !JFCL APPN=PATH_PPN %RETURN %FINISH READ OCTAL(PROJ) %UNLESS NEXTSYMBOL=',' %WHILE NEXTSYMBOL=' ' %THEN SKIPSYMBOL %IF NEXTSYMBOL=',' %THEN SKIPSYMBOL; READ OCTAL(PROG) %UNLESS NEXTSYMBOL=',' %OR NEXTSYMBOL=']' %IF PROJ=0 %OR PROG=0 %START N=PPN %IF PROJ=0 %THEN PROJ=N>>18 %IF PROG=0 %THEN PROG=N&8_777777 %FINISH APPN=PROJ<<18!(PROG&8_777777) %END !+ !%EXTERNALROUTINE WRITEPPN(%INTEGER PPN) ! ^OUTPUTS THE GIVEN PPN IN THE FORM [ N, N] ON THE CURRENT OUTPUT STREAM. !- %EXTERNALROUTINE WRITEPPN(%INTEGER PPN) PRINTSYMBOL('[') PRINTSTRING(OCTTOSTR(PPN>>18)) PRINTSYMBOL(',') PRINTSTRING(OCTTOSTR(PPN&8_777777)) PRINTSYMBOL(']') %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& OCTAL.IMP !+ !.AP ! ^THIS LIBRARY CONTAINS OCTAL READING AND WRITING ROUTINES !- %SYSTEMINTEGERFNSPEC STON(%STRING(1)%NAME STR,%ROUTINE READER(%INTEGERNAME N)) %EXTERNALSTRING(255)%SPEC ERRMSG !+ !%EXTERNALROUTINE READ OCTAL(%INTEGERNAME N) ! ^READS AN OCTAL NUMBER FROM THE CURRENT INPUT STREAM INTO N. !- %EXTERNALROUTINE READ OCTAL(%INTEGERNAME N) %INTEGER S,SIGN S=NEXTSYMBOL %WHILE S<=' ' %THEN SKIPSYMBOL %AND S=NEXTSYMBOL N=0; SIGN=0 %IF S='-' %THEN SIGN='-' %AND SKIPSYMBOL %AND S=NEXTSYMBOL %UNLESS '0'<=S<='7' %START ERRMSG="Octal integer not found" %SIGNAL 3,1,S %FINISH %WHILE '0'<=S<='7' %CYCLE N=N<<3+(S-'0') SKIPSYMBOL; S=NEXTSYMBOL %REPEAT %IF SIGN#0 %THEN N=-N %END !+ !%EXTERNALROUTINE WRITE OCTAL(%INTEGER N,S) ! ^OUTPUTS A SIGNED OCTAL INTEGER N WITH S PLACES ON THE CURRENT OUTPUT STREAM. !- %EXTERNALROUTINE WRITE OCTAL(%INTEGER N,S) %INTEGER SIGN %ROUTINESPEC P(%INTEGER N) %IF S<=0 %THEN SIGN=S %ELSE SIGN=' ' S=IMOD(S); S=63 %IF S>63 %IF N<0 %THEN N=-N %AND SIGN='-' P(N) %ROUTINE P(%INTEGER N) S=S-1 P(N//8) %IF N>=8 %IF SIGN > 0 %START SPACES(S-1) PRINTSYMBOL(SIGN); SIGN=0 %ELSE %IF SIGN<0 %THEN SPACES(S) %AND SIGN=0 PRINTSYMBOL(REM(N,8)+'0') %END %END %EXTERNALINTEGERFN STRTOOCT(%STRING(1)%NAME STR) %RESULT=STON(STR,READOCTAL) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& SWITCH.IMP %EXTERNALINTEGERFNSPEC STRTOOCT(%STRING(1)%NAME STR) %EXTERNALINTEGERFNSPEC STRTOINT(%STRING(1)%NAME STR) %EXTERNALSTRING(255)%SPEC ERRMSG %CONSTINTEGER MAX SWITCHES=12 %OWNSTRING(11)%ARRAY SW ARRAY(1:MAX SWITCHES)= %C "MODE", "FUNCTION", "ALLOCATE", "BLOCKSIZE", "BUFFERS", %C "DENSITY", "ESTIMATE", "EXTEND", "PARITY", "VERSION", "BYTE", "TRMOP" %CONSTINTEGER MOD=1, FUNCT=2, ALLOC=3, BLKSIZE=4, %C BUFF=5, DENS=6, EST=7, EXT=8, PAR=9, VERSN=10, BYT=11, TRM=12 %OWNINTEGERARRAYNAME SW ARGS;!** (1:MAX SWITCHES) %EXTERNALINTEGERARRAY TEMP(0:0);!**TEMP** %EXTERNALINTEGER MODE; !VALUES -1 OR 0 - 8_17 %EXTERNALINTEGER FUNCTION; !VALUES -1 OR 1-7 %EXTERNALINTEGER ALLOCATE; !VALUES 0 - %EXTERNALINTEGER BLOCKSIZE; !-1 OR 3 - 10000 %EXTERNALINTEGER BUFFNUMS; !-1 OR <20 %EXTERNALINTEGER DENSITY; !0 - MAX DENSITIES %EXTERNALINTEGER ESTIMATE; !0 - %EXTERNALINTEGER EXTEND; !5 - 8_35 %EXTERNALINTEGER PARITY; !0 OR 1 %EXTERNALINTEGER VERSION; !0 - %EXTERNALINTEGER BYTE; !0 - %EXTERNALINTEGER TRMOP; %CONSTINTEGERARRAY SWITCH DEFAULTS(1:MAX SWITCHES)= -1, -1, 0, -1, -1, 0, 0, 5, 0, 0, 0, -1 %CONSTINTEGER MAX DENSITIES= 4 %CONSTSHORTINTEGERARRAY DENSITIES(0:MAX DENSITIES) = 0, 200, 556, 800, 1600 %SYSTEMPREDICATE SW MATCH(%STRING(1)%NAME TEST,TARGET) %INTEGER N,L,S,T L=LENGTH(TEST) %FALSE %IF L>LENGTH(TARGET) %OR L=0 %FOR N=1,1,L %CYCLE S=CHARNO(TEST,N) S=S-32 %IF 'a'<=S<='z' T=CHARNO(TARGET,N) T=T-32 %IF 'a'<=S<='z' %FALSE %IF S # T %REPEAT %TRUE %END %EXTERNALROUTINE GET SWITCHES(%STRING(1)%NAME SWITCHSTR) !WHEN A SWITCH IS READ IT IS SET TO THE VALUE OF ITS !ARGUMENT OR ZERO, OTHERWISE IT IS LEFT AT ITS DEFAULT VALUE %INTEGER N,LEN %STRING(39) SW,ARG,SWITCHES SWITCHES=SWITCHSTR LEN=LENGTH(SWITCHES) SW ARGS==TEMP; !**TEMP** %FOR N=0,1,MAX SWITCHES %CYCLE SW ARGS(N)=SWITCH DEFAULTS(N) %REPEAT %ROUTINE SW ERROR(%INTEGER NUMBER) ERRMSG="Incorrect argument for switch /".SW ARRAY(NUMBER) %SIGNAL 5,9,SWARGS(NUMBER) %END %RETURN %IF LEN=0 %IF CHARNO(SWITCHES,1)='/' %THEN SWITCHES=SUBSTRING(SWITCHES,2,LEN) NEXT: ->CHECK %IF SWITCHES="" %UNLESS SWITCHES->SW.("/").SWITCHES %START SW=SWITCHES; SWITCHES=""; !LAST SWITCH %FINISH %UNLESS SW->SW.(":").ARG %THEN ARG="" %FOR N=MOD,1,MAX SWITCHES %CYCLE %IF SWMATCH(SW,SWARRAY(N)) %START %IF ARG#"" %START %IF CHARNO(ARG,1)='#' %START ARG=SUBSTRING(ARG,2,LENGTH(ARG)) SWARGS(N)=STRTOOCT(ARG) %ELSE SWARGS(N)=STRTOINT(ARG) %ELSE SWARGS(N)=0 -> NEXT %FINISH %REPEAT !HERE FOR NO MATCH ERRMSG="Unknown switch /".SW %SIGNAL 5,10 CHECK: ;!HERE TO CHECK SWITCH VALUES %IF EXTEND#0 %START %UNLESS 5<=EXTEND<=8_35 %THEN SW ERROR(EXT) %ELSE EXTEND=8_35 %IF VERSION#0 %START EXTEND=6 %IF EXTEND<6 %FINISH %IF ESTIMATE #0 %START EXTEND=8 %IF EXTEND<8 %FINISH %IF ALLOCATE# 0 %START EXTEND=9 %IF EXTEND<9 %FINISH %UNLESS -1<=BUFFNUMS<=20 %THEN SW ERROR(BUFF) %UNLESS BLOCKSIZE=-1 %OR 3<=BLOCKSIZE<=10000 %THEN SW ERROR(BLKSIZE) %IF FUNCTION#-1 %START %UNLESS 1<=FUNCTION<=7 %THEN SWERROR(FUNCT) %FINISH %IF 0#PARITY#1 %THEN SW ERROR(PAR) %IF DENSITY#0 %START %FOR N=1,1,MAX DENSITIES %CYCLE %IF DENSITY=DENSITIES(N) %THEN DENSITY=N %AND ->DENSITY OK %REPEAT SW ERROR(DENS) %FINISH DENSITY OK: %END %ENDOFFILE !NOW A TEST SECTION %EXTERNALROUTINESPEC READFS(%RECORD(FILESPEC)%NAME FS) %INTEGER GOT,I %RECORD (FILESPEC) FS %CYCLE PRINTSTRING("FILE: "); READFS(FS) GET SWITCHES(FS_SWITCHES) %FOR I=1,1,MAX SWITCHES %CYCLE WRITE(SWARGS(I),3) %REPEAT NEWLINES(2) %REPEAT %ENDOFPROGRAM $$$$$$$$$$$$ &&&&&&&&&&&& SWARG.IMP %EXTERNALINTEGERFNSPEC STRTOOCT(%STRING(1)%NAME STR) %EXTERNALINTEGERFNSPEC STRTOINT(%STRING(1)%NAME STR) %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMPREDICATESPEC SW MATCH(%STRING(11)%NAME TEST,TARGET) %EXTERNALPREDICATE SWITCH ARG(%STRING(1)%NAME SOURCE,%STRING(11) TARGET, %NAME ARGUMENT) !RETURNS THE ARGUMENT OF A SWITCH IF ONE IS GIVEN !AND %FALSE IF NO SWITCH FOUND TO MATCH THE TARGET %INTEGERARRAY ARG FRIG(0:0); !SO ARGUMENT=ARG FRIG(-1) %STRING(255) SWITCHES,SW %STRING(25) SW1,ARG %INTEGER TYPE,N,CH,LEN TYPE=ARG FRIG(-1)>>23&8_17 %IF TYPE>4 %START ERRMSG="Illegal %name type parameter" %SIGNAL 5,6,type %FINISH SW="" LEN=LENGTH(SOURCE) INTEGER(ADDR(ARGUMENT))=0; !ZERO RESULT %FALSE %IF LEN=0 SWITCHES=SOURCE SOURCE="" !REMOVE FIRST SLASH %IF CHARNO(SWITCHES,1)='/' %START SWITCHES=SUBSTRING(SWITCHES,2,LENGTH(SWITCHES)) %FINISH %CYCLE %UNLESS SWITCHES->SW.("/").SWITCHES %START; !GET ONE SWITCH SW=SWITCHES; SWITCHES=""; !LAST ONE %FINISH %FALSE %IF SW=""; !NO MORE FOUND %UNLESS SW->SW1.(":").ARG %THEN SW1=SW %AND ARG=""; !GET ANY ARG %IF SWMATCH(SW1,TARGET) %START %IF ARG#"" %START %IF TYPE=4 %START; !STRING TYPE STRING(ADDR(ARGUMENT))=ARG %ELSE; !INTEGER TYPE %IF CHARNO(ARG,1)='#' %START; !OCTAL NUMBER ARG=SUBSTRING(ARG,2,LENGTH(ARG)) INTEGER(ADDR(ARGUMENT))=STRTOOCT(ARG) %ELSE INTEGER(ADDR(ARGUMENT))=STRTOINT(ARG) %FINISH %FINISH SOURCE=SOURCE."/".SWITCHES %UNLESS SWITCHES=""; !OMIT THE MATCHED SWITCH %TRUE %FINISH SOURCE=SOURCE."/".SW; !REBUILD SOURCE - OMIT THE MATCHED SWITCH %REPEAT %END %ENDOFFILE !NOW A TEST SECTION %EXTERNALROUTINESPEC READFS(%RECORD(FILESPEC)%NAME FS) %INTEGER GOT,I %RECORD (FILESPEC) FS %CYCLE PRINTSTRING("FILE: "); READFS(FS) GET SWITCHES(FS_SWITCHES) %FOR I=1,1,MAX SWITCHES %CYCLE WRITE(SWARGS(I),3) %REPEAT NEWLINES(2) %REPEAT %ENDOFPROGRAM $$$$$$$$$$$$ &&&&&&&&&&&& SDEF.IMP %INCLUDE "IMP:IOLIB.INC" %CONTROL 16_4000; !ALLOW RECORD EQUATING %EXTERNALRECORD(SCBNAME)%ARRAYSPEC INVEC(-1:MAXCHANS); !ADDRESSES OF SCBS FOR EACH CHANNEL %EXTERNALRECORD(SCBNAME)%ARRAYSPEC OUTVEC(-1:MAXCHANS); !FOR OUTPUT %EXTERNALRECORD(SCB)%NAMESPEC INSCB; !ADDRESS OF CURRENT SCB START %EXTERNALRECORD(SCB)%NAMESPEC OUTSCB %EXTERNALINTEGERSPEC RDST; !STRING READ ROUTINE -FRIG %EXTERNALINTEGERSPEC WTST; !STRING WRITE ROUTINE -FRIG %SYSTEMROUTINESPEC GETSCB(%RECORD(SCBNAME)%NAME R,%INTEGER SIZE) %SYSTEMROUTINESPEC SCHECK(%INTEGER N,CHNTYP, %RECORD(SCBNAME)%NAME IOSCB) %SYSTEMROUTINE SD INPUT(%INTEGER N,%STRING(1)%NAME STR) %RECORD(STRSCB)%NAME STRSCB GETSCB(INVEC(N),STRSCBSIZE) STRSCB==RECORD(ADDR(INVEC(N)_NAME)) STRSCB_DEVTYP=STRDEV STRSCB_OPER==RDST; !READ ROUTINE STRSCB_NXTCHR=0 STRSCB_LENPTR=8_331100<<18!ADDR(STR)&8_777777 STRSCB_POINTER=STRSCB_LENPTR AC(2)=STRSCB_LENPTR *8_135040 000002; !LDB 1,2 STRSCB_LENGTH=AC(1) %IF INSTREAM=N %THEN INSCB==INVEC(N)_NAME %END %EXTERNALROUTINE SDEF INPUT(%INTEGER N,%STRING(1)%NAME STR) SCHECK(N,STREAM,INVEC(N)) SDINPUT(N,STR) %END %SYSTEMROUTINE SD OUTPUT(%INTEGER N,%STRING(1)%NAME STR) %RECORD(STRSCB)%NAME STRSCB GETSCB(OUTVEC(N),STRSCBSIZE) STRSCB==RECORD(ADDR(OUTVEC(N)_NAME)) STRSCB_DEVTYP=STRDEV STRSCB_NXTCHR=0 STRSCB_OPER==WTST; !WRITE ROUTINE STRSCB_LENPTR=8_331100<<18!ADDR(STR)&8_777777 STRSCB_POINTER=STRSCB_LENPTR STRSCB_LENGTH=0 %IF OUTSTREAM=N %THEN OUTSCB==OUTVEC(N)_NAME %END %EXTERNALROUTINE SDEF OUTPUT(%INTEGER N,%STRING(1)%NAME STR) SCHECK(N,STREAM,OUTVEC(N)) SDOUTPUT(N,STR) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& STRTON.IMP !STRTON.IMP %SYSTEMROUTINESPEC SD INPUT(%INTEGER N,%STRING(1)%NAME STR) %SYSTEMROUTINESPEC SINPUT(%INTEGER N) %EXTERNALSTRING(255)%SPEC ERRMSG %SYSTEMINTEGERFN STON(%STRING(1)%NAME STR,%ROUTINE READER(%INTEGERNAME N)) %STRING (255) STR1 %INTEGER STREAM,N %ON %EVENT 9 %START ERRMSG="Number not found" %SIGNAL 3,1 %FINISH STREAM=INSTREAM STR1=STR." " %IF LENGTH(STR)<100; !TO ENSURE A READ TERMINATES BEFORE EOF SD INPUT(-1,STR1) SINPUT(-1) READER(N) CLOSE INPUT SELECT INPUT(STREAM) %RESULT=N %END %EXTERNALINTEGERFN STRTOINT(%STRING(1)%NAME STR) %ROUTINE READER(%INTEGERNAME N) READ(N) %END %RESULT=STON(STR,READER) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& TIME.IMP !+ !.AP ! ^THIS LIBRARY CONTAINS DATE-TIME FUNCTIONS. !- %EXTERNALINTEGERFNSPEC GETNOW %EXTERNALINTEGERFNSPEC GETDATE %EXTERNALINTEGERFNSPEC GETTIME %EXTERNALROUTINESPEC FROMUDT(%INTEGER UDT, %INTEGERNAME D,T) %EXTERNALSTRING(12)%FNSPEC INTTOSTR(%INTEGER I) %EXTERNALSTRING(255)%SPEC ERRMSG %CONSTINTEGER START OF 7401=8_122106 000000; !UDT OF START OF ACCONTING PERIOD %CONSTINTEGER LH=8_777777 000000 !+ !.AP !%EXTERNALSTRING(9)%FN DATE ! ^RETURNS THE DATE AS A STRING IN THE FORM DD-MM-YY. !- %EXTERNALROUTINE FROMDATE(%INTEGER DATE,%INTEGERNAME D,M,Y) %INTEGER I I=DATE//31 D=REM(DATE,31)+1 Y=I//12+1964 M=REM(I,12)+1 %END %EXTERNALINTEGERFN TODATE(%INTEGER DAY,MONTH,YEAR) %IF YEAR>1900 %THEN YEAR=YEAR-1900 %RESULT=((YEAR-64)*12+(MONTH-1))*31+DAY-1 %END %EXTERNALSTRING(9)%FN DATETOSTR(%INTEGER DATE) %INTEGER D,M,Y %CONSTSTRING(5)%ARRAY MONTHS(0:11) = "-Jan-", "-Feb-", "-Mar-", "-Apr-", "-May-", "-Jun-", "-Jul-", "-Aug-", "-Sep-", "-Oct-", "-Nov-", "-Dec-" FROMDATE(DATE,D,M,Y) M=REM(IMOD(M)-1,12); !make sure that number is sensible %RESULT=INTTOSTR(D).MONTHS(M).INTTOSTR(Y-1900) %END %EXTERNALSTRING(9)%FN DATE %RESULT=DATETOSTR(GETDATE) %END %EXTERNALSTRING(9)%FN DAYTOSTR(%INTEGER UDT) %OWNSTRING(9)%ARRAY DAYS(0:6)= "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday" %RESULT=DAYS(REM(UDT>>18+2,7)) %END %EXTERNALSTRING(9)%FN DAY %RESULT=DAYTOSTR(GETNOW) %END !+ !.AP !%EXTERNALSTRING(8)%FN TIME ! ^RETURNS A STRING IN THE FORM HH:MM:SS !- %EXTERNALROUTINE FROMTIME(%INTEGER TIME, %INTEGERNAME H,M,S) TIME=TIME//1000; !CONVERT TO SECONDS H=TIME//3600 M=TIME//60-H*60 S=REM(TIME,60) %END %EXTERNALINTEGERFN TOTIME(%INTEGER HRS,MINS,SECS) %RESULT=((HRS*60+MINS)*60+SECS)*1000 %END %EXTERNALSTRING(8)%FN TIMETOSTR(%INTEGER TIME) %INTEGER H,M,S %STRING(2) HS,MS,SS FROMTIME(TIME,H,M,S) HS=INTTOSTR(H) %IF H<10 %THEN HS="0".HS MS=INTTOSTR(M) %IF M<10 %THEN MS="0".MS SS=INTTOSTR(S) %IF S<10 %THEN SS="0".SS %RESULT=HS.":".MS.":".SS %END %EXTERNALSTRING(8)%FN TIME %RESULT=TIMETOSTR(GETTIME) %END %EXTERNALSTRING(18)%FN UDTTOSTR(%INTEGER UDT) %INTEGER T,D FROMUDT(UDT,D,T) %RESULT=TIMETOSTR(T)." ".DATETOSTR(D) %END %EXTERNALSTRING(18)%FN DATETIME %RESULT=TIMETOSTR(GETTIME)." ".DATETOSTR(GETDATE) %END %EXTERNALINTEGERFN ACCPER(%INTEGER UDT) %INTEGER DAYS,MONTH,YEAR DAYS=(UDT&LH-START OF 7401)>>18 MONTH=REM(DAYS,364)//28+1 YEAR=74+DAYS//364 %RESULT=YEAR*100+MONTH %END %INTEGERFN START PERIOD(%INTEGER PERIOD, DAY,WEEK) !WILL ACCEPT 4,5 OR 6 FIGURE PERIOD SPECIFICATIONS %INTEGER MONTH,YEAR,PER PER=PERIOD %IF PERIOD>=100000 %START DAY=REM(PERIOD,10)-1; PERIOD=PERIOD//10 %FINISH %IF PERIOD>=10000 %START WEEK=REM(PERIOD,10)-1; PERIOD=PERIOD//10 %FINISH MONTH=REM(PERIOD,100) YEAR=PERIOD//100 %IF DAY>6 %OR WEEK>3 %OR MONTH>13 %OR YEAR>99 %START ERRMSG="Accounting Period incorrectly specified ".INTTOSTR(PER) %SIGNAL 11,22,PER %FINISH %RESULT=((((YEAR-74)*364+(MONTH-1)*28)<<18)+START OF 7401)+(WEEK*7+DAY)<<18 %END %EXTERNALINTEGERFN STARTOFPERIOD(%INTEGER PERIOD) %RESULT=STARTPERIOD(PERIOD,0,0) %END %EXTERNALINTEGERFN ENDOFPERIOD(%INTEGER PERIOD) %RESULT=STARTPERIOD(PERIOD,6,3)!8_777777 %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& DECODE.IMP %EXTERNALROUTINE DECODE(%INTEGER VALUE, WHERE) %INTEGER OP, ACC, T, X, Y, IND %String(6)%name OPC %Conststring(6)%Array OPCODE(0:511) = "", "USER "(31), "CALL ","INIT ",""(5), "CALLI ", "OPEN ","TTCALL",""(3), "RENAME","IN ","OUT ", "SETSTS","STATO ","STATUS","STATZ ","INBUF ","OUTBUF","INPUT ","OUTPUT", "CLOSE ","RELEAS","MTAPE ","UGETF ","USETI ","USETO ","LOOKUP","ENTER ", ""(24), "UFA ","DFN ","FSC ","IBP ","ILDB ","LDB ","IDPB ","DPB ", "FAD ","FADL ","FADM ","FADB ","FADR ","FADRI ","FADRM ","FADRB ", "FSB ","FSBL ","FSBM ","FSBB ","FSBR ","FSBRI ","FSBRM ","FSBRB ", "FMP ","FMPL ","FMPM ","FMPB ","FMPR ","FMPRI ","FMPRM ","FMPRB ", "FDV ","FDVL ","FDVM ","FDVB ","FDVR ","FDVRI ","FDVRM ","FDVRB ", "MOVE ","MOVEI ","MOVEM ","MOVES ","MOVS ","MOVSI ","MOVSM ","MOVSS ", "MOVN ","MOVNI ","MOVNM ","MOVNS ","MOVM ","MOVMI ","MOVMM ","MOVMS ", "IMUL ","IMULI ","IMULM ","IMULB ","MUL ","MULI ","MULM ","MULB ", "IDIV ","IDIVI ","IDIVM ","IDIVB ","DIV ","DIVI ","DIVM ","DIVB ", "ASH ","ROT ","LSH ","JFFO ","ASHC ","ROTC ","LSHC ","", "EXCH ","BLT ","AOBJP ","AOBJN ","JRST ","JFCL ","XCT ","", "PUSHJ ","PUSH ","POP ","POPJ ","JSR ","JSP ","JSA ","JRA ", "ADD ","ADDI ","ADDM ","ADDB ","SUB ","SUBI ","SUBM ","SUBB ", "CAI ","CAIL ","CAIE ","CAILE ","CAIA ","CAIGE ","CAIN ","CAIG ", "CAM ","CAML ","CAME ","CAMLE ","CAMA ","CAMGE ","CAMN ","CAMG ", "JUMP ","JUMPL ","JUMPE ","JUMPLE","JUMPA ","JUMPGE","JUMPN ","JUMPG ", "SKIP ","SKIPL ","SKIPE ","SKIPLE","SKIPA ","SKIPGE","SKIPN ","SKIPG ", "AOJ ","AOJL ","AOJE ","AOJLE ","AOJA ","AOJGE ","AOJN ","AOJG ", "AOS ","AOSL ","AOSE ","AOSLE ","AOSA ","AOSGE ","AOSN ","AOSG ", "SOJ ","SOJL ","SOJE ","SOJLE ","SOJA ","SOJGE ","SOJN ","SOJG ", "SOS ","SOSL ","SOSE ","SOSLE ","SOSA ","SOSGE ","SOSN ","SOSG ", "SETZ ","SETZI ","SETZM ","SETZB ","AND ","ANDI ","ANDM ","ANDB ", "ANDCA ","ANDCAI","ANDCAM","ANDCAB","SETM ","SETMI ","SETMM ","SETMB ", "ANDCM ","ANDCMI","ANDCMM","ANDCMB","SETA ","SETAI ","SETAM ","SETAB ", "XOR ","XORI ","XORM ","XORB ","OR ","ORI ","ORM ","ORB ", "ANDCB ","ANDCBI","ANDCBM","ANDCBB","EQV ","EQVI ","EQVM ","EQVB ", "SETCA ","SETCAI","SETCAM","SETCAB","OPCA ","ORCAI ","ORCAM ","ORCAB ", "SETCM ","SETCMI","SETCMM","SETCMB","ORCM ","ORCMI ","ORCMM ","ORCMB ", "ORCB ","ORCBI ","ORCBM ","ORCBB ","SETO ","SETOI ","SETOM ","SETOB ", "HLL ","HLLI ","HLLM ","HLLS ","HRL ","HRLI ","HRLM ","HRLS ", "HLLZ ","HLLZI ","HLLZM ","HLLZS ","HRLZ ","HRLZI ","HRLZM ","HRLZS ", "HLLO ","HLLOI ","HLLOM ","HLLOS ","HRLO ","HRLOI ","HRLOM ","HRLOS ", "HLLE ","HLLEI ","HLLEM ","HLLES ","HRLE ","HRLEI ","HRLEM ","HRLES ", "HRR ","HRRI ","HRRM ","HRRS ","HLR ","HLRI ","HLRM ","HLRS ", "HRRZ ","HRRZI ","HRRZM ","HRRZS ","HLRZ ","HLRZI ","HLRZM ","HLRZS ", "HRRO ","HRROI ","HRROM ","HRROS ","HLRO ","HLROI ","HLROM ","HLROS ", "HRRE ","HRREI ","HRREM ","HRRES ","HLRE ","HLREI ","HLREM ","HLRES ", "TRN ","TLN ","TRNE ","TLNE ","TRNA ","TLNA ","TRNN ","TLNN ", "TDN ","TSN ","TDNE ","TSNE ","TDNA ","TSNA ","TDNN ","TSNN ", "TRZ ","TLZ ","TRZE ","TLZE ","TRZA ","TLZA ","TRZN ","TLZN ", "TDZ ","TSZ ","TDZE ","TSZE ","TDZA ","TSZA ","TDZN ","TSZN ", "TRC ","TLC ","TRCE ","TLCE ","TRCA ","TLCA ","TRCN ","TLCN ", "TDC ","TSC ","TDCE ","TSCE ","TDCA ","TSCA ","TDCN ","TSCN ", "TRO ","TLO ","TROE ","TLOE ","TROA ","TLOA ","TRON ","TLON ", "TDO ","TSO ","TDOE ","TSOE ","TDOA ","TSOA ","TDON ","TSON ", "BLKI ", ""(7), ""(56) %Routine OCTAL(%Integer N, D) D = (D-1)*3; D = 0 %If D < 0 %Cycle D = D, -3, 0 PRINTSYMBOL(N>>D&7+'0') %Repeat %End %ROUTINE WOCT(%INTEGER N, P) %INTEGER SIGN %ROUTINE Q(%INTEGER N) P = P-1 Q(N>>3) %UNLESS N&8_777770 = 0 %IF SIGN # 0 %START SPACES(P) PRINTSYMBOL(IND) %UNLESS IND = ' '; IND = ' ' PRINTSYMBOL(SIGN) %UNLESS SIGN = ' '; SIGN = 0 %FINISH PRINTSYMBOL(N&7+'0') %END SIGN = ' ' %IF N < 0 %START N = -N; SIGN = '-'; P = P-1 %FINISH P = P-1 %IF IND = '@' Q(N) %END OP = VALUE>>27 ACC = VALUE>>23&15 T = VALUE>>22&1 X = VALUE>>18&15 Y = VALUE&8_777777 OCTAL(WHERE, 6); SPACES(2) OCTAL(VALUE>>18, 6); SPACE; OCTAL(Y,6) OPC == OPCODE(OP) %IF OPC # "" %START SPACES(2); PRINTSTRING(OPC) SPACE; IND = ' ' WOCT(ACC, 2); PRINTSYMBOL(',') %If T = 0 %Then IND = ' ' %Else IND = '@' %If X = 0 %Start WOCT(Y, 7) %Else %IF Y=0 %START SPACE; PRINTSYMBOL(IND); IND = ' ' %ELSE WOCT(Y, 7) %FINISH PRINTSYMBOL('(') WOCT(X, 0) PRINTSYMBOL(')') %Finish %FINISH NEWLINE %End %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& SIGNAL.IMP %EXTERNALSTRING(255) ERRMSG %SYSTEMROUTINESPEC IMPXT %SYSTEMROUTINE SIGNAL(%INTEGER A,B,C) %UNLESS A=0 %AND B=0 %START SELECTOUTPUT(0) PRINTSTRING(ERRMSG); NEWLINE PRINTSTRING("?SIGNAL") WRITE(A, 1); WRITE(B, 1); WRITE(C, 1) NEWLINE *8_047040 000012; !EXIT 1, -ABORT BUT CAN RETURN ON A CONT %FINISH IMPXT %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& COPY.IMP %INCLUDE "IMP:DASQ.INC" %CONSTINTEGER MAX CHANS=15 !**NEXT 3 LINES SHOULD BE REPLACED BY ;%INCLUDE "IMP:IOLIB.INC" %EXTERNALINTEGERARRAYSPEC DASQVEC(1:MAX CHANS); !**TYPE FRIG %CONSTINTEGER BLOCKSIZE=24, LKENT=13, SIZ=5, DEVTYP=0; !**ADDRESSES IN SCB %CONSTINTEGER DTADEV=1; !**DTA DEV TYPE %EXTERNALRECORD(FILESPEC)%FNSPEC STRTOFS(%STRING(255) SPEC) %EXTERNALSTRING(255)%FNSPEC FSTOSTR(%RECORD(FILESPEC)%NAME FS) %EXTERNALSTRING(255)%SPEC ERRMSG %EXTERNALROUTINE XCOPY(%RECORD(FILESPEC)%NAME FS1,FS2) %INTEGER N,BLOCK,LEN,SIZE,BUFSIZ,BLSIZE %INTEGER CHAN1,CHAN2 %INTEGERFN FREECHAN(%INTEGER START) %FOR N=START,1,MAX CHANS %CYCLE %RESULT=N %IF DASQVEC(N)=0; !FREE CHAN %REPEAT ERRMSG="No free channels for COPYING ".FSTOSTR(FS1) %SIGNAL 2,5 %END CHAN1=FREECHAN(1) CHAN2=FREECHAN(CHAN1+1) FS1_SWITCHES="/FUNCT:1".FS1_SWITCHES; !READ ONLY AND INCLUDE FILE LENGTH FS2_SWITCHES="/FUNCT:3".FS2_SWITCHES; !SUPERCEDING ENTER XOPENDA(CHAN1,FS1) XOPENDA(CHAN2,FS2) SIZE=INTEGER(INTEGER(DASQVEC(CHAN1)+LKENT)+SIZ) %IF INTEGER(DASQVEC(CHAN1)+DEVTYP)=DTADEV %THEN BUFSIZ=512 %ELSE BUFSIZ=1024 BLSIZE=INTEGER(DASQVEC(CHAN1)+BLOCKSIZE) BUFSIZ=BLSIZE %IF REM(BUFSIZ,BLSIZE)#0 N=0 %BEGIN %INTEGERARRAY BUFF(1:BUFSIZ) %ON %EVENT 9 %START LEN=SIZE-N*BLSIZE %UNLESS LEN<=0 %THEN WRITEDA(CHAN2,BLOCK,BUFF(1),BUFF(LEN)) CLOSEDA(CHAN1) CLOSEDA(CHAN2) ->RETURN %FINISH %CYCLE BLOCK=N+1; READDA(CHAN1,BLOCK,BUFF(1),BUFF(BUFSIZ)) BLOCK=N+1; WRITEDA(CHAN2,BLOCK,BUFF(1),BUFF(BUFSIZ)) N=BLOCK %REPEAT RETURN: %END %END %EXTERNALROUTINE COPY(%STRING(255) SPEC1,SPEC2) %RECORD(FILESPEC) FS1,FS2 FS1=STRTOFS(SPEC1) FS2=STRTOFS(SPEC2) XCOPY(FS1,FS2) %END %ENDOFFILE $$$$$$$$$$$$ &&&&&&&&&&&& IMPPRM.MAC UNIVERSAL IMPPRM PARAMETER FILE FOR MACRO ROUTINES IN IMP ; K. FARVIS 9TH. NOV. 1976 .DIRECTIVE .NOBIN ;DEFS OF ACS T1=2 T2=3 T3=4 T4=5 T5=6 J=3 ;*** DUPLICATE USE OF REGISTER 3 *** IOREG=4 ARG3=4 ;*** NOTE DUPLICATE OF IOREG AND T3 *** ARG2=5 ;*** THIS ALSO DUPLICATE OF T4 *** ARG1=6 ;*** DUPLICATE OF T5 *** P=17 BASE1=16 BASE2=15 BASE3=14 BASE4=13 BASE5=12 ; P=17 ;PDL FOR ROUTINE ENTRY-EXIT ; ARG1=16 ;1ST PARAMETER FOR PROCEDURE ; ARG2=15 ;2ND PARAMETER ; ARG3=14 ;3RD PARAMETER ; AC'S 13-7 ARE BASE REGISTERS 5-1 ; FOR GENERAL MACRO ROUTINES THE FOLLOWING REGISTERS ARE FREE ; T6=6 ; T5=5 ; T4=4 ; T3=3 ; T2=2 ; T1=1 ;AND ALSO AC1=1 ;%RESULT REGISTER FROM MAPS ; AC=0 ;%RESULT REGISTER FROM FUNCTIONS AC=1 ;ADDITIONAL AC DEFNS FOR PRIMITIVE PROCEDURES P2=1 ;PRESERVED ACS P1=2 J=3 ;RETURN ADDRESS ARGLST==2 ;START LOCATION OF PARAMETERS ON STACK ;THE REGISTER FOR LONG REAL ARGUMENT PARAMETER LARG1==6 ;NOW LOCATION OF LONG REAL ARGUMENTS ON THE STACK A1INC==2 ;LOC OF 1ST A2INC==4 ;LOC OF 2ND A3INC==6 ;LOC OF 3RD A4INC==10 ;LOC OF 4TH A5INC==12 ;LOC OF 5TH A6INC==14 ;LOC OF 6TH ;DEVICE TYPE DEFINITIONS TMPDEV==-2 UNDEV==-1 DSKDEV==0 DTADEV==1 MTADEV==2 TTYDEV==3 XDSKDEV==4 ; SCB RECORD DEFININTIONS MUST CORRESPOND TO IMP SIDE DEVTYP==0 ;**TEMP UNTIL SHORT INTEGERS CHNTYP==1 NXTCHR==2 OPER==3 FLAGS==4 RESVD==5 TMPNAME==6 UDX==7 FILOPFN==10 STATUS==11 DEVNAM==12 BUFHEDS==13 BUFNUM==14 LKENT==15 PATHARG==16 BUFADR==17 BYTPTR==20 BYTCNT==21 MPXUDX==21 IBUFOP==23 OBUFOP==24 USETI==25 USETO==26 STATZ==27 BLOCKSIZE==30 BUFVEC==31 ;NEXT COMES THE PATH BLOCK ;THEN THE LOOKUP ENTER BLOCK ;+ADDITIONAL DEFNS FOR TERMINAL SCB ARGPTR==5 FUNCT==6 OUTARG==10 ;AND FOR STRRING SCB LENGTH==4 LENPTR==5 POINTER==6 ;THE CALLING INSTRUCTIONS FOR ROUTINES OPDEF CALL [ PUSHJ P,] OPDEF RETURN [POPJ 17,0] OPDEF GOTO [JRST] OPDEF PJRST [JRST] ;OPENING SEQUENCE FOR LONG REAL PROCEDURES, TO PUT ARGS ON STACK DEFINE IHELLO (NAME) < SALL ;**NEW**NAME: DMOVEM ARG1,A1INC(SP) NAME: MOVEM ARG1,A1INC(SP) SETZM A1INC+1(SP) MOVEM ARG2,A2INC(SP) SETZM A2INC+1(SP) MOVEM ARG3,A3INC(SP) SETZM A3INC+1(SP) > SUBTTL PROCESSOR DEFINITION (KA10/KI10) ;TYPE OF PROCESSOR KA10==1 KI10==2 IFNDEF CPU, IFN CPU-KA10,< DEFINE DOUBLE (A,B)< A B> > IFE CPU-KA10,< DEFINE DOUBLE (A,B)< ZZ1.==A&<777000,,0> IFL ZZ1.,> ZZ1.==ZZ1.-<033000,,0> IFE B, ZZ2.==ZZ1.+<_-8>&<000777,,777777> IFL ZZ1., A ZZ2. SUPPRESS ZZ1.,ZZ2.> DEFINE DMOVE(AC,M)< IFL -<@>,< MOVE AC,M MOVE AC+1,1+M> IFGE -<@>,< MOVEI AC+1,M MOVE AC,(AC+1) MOVE AC+1,1(AC+1)> > DEFINE DMOVN(AC,M)< DMOVE AC,M DFN AC,AC+1> DEFINE DMOVEM(AC,M)< MOVEM AC,M MOVEM AC+1,1+M > DEFINE FLMUL (AC,M,%OV)< MOVEM AC,AC+2 FMPR AC+2,1+M JFCL (2) FMPR AC+1,M JFCL (2) UFA AC+1,AC+2 JFCL FMPL AC,M JOV %OV UFA AC+1,AC+2 FADL AC,AC+2 %OV: > DEFINE FLDIV(AC,M,%OV)< FDVL AC,M JOV %OV MOVN AC+2,AC FMPR AC+2,1+M JFCL (2) UFA AC+1,AC+2 FDVR AC+2,M JFCL FADL AC,AC+2 %OV: > DEFINE FLADD(AC,M,%OV)< UFA AC+1,1+M FADL AC,M JOV %OV UFA AC+1,AC+2 FADL AC,AC+2 %OV: > > ;END OF KA10 CONDITIONAL IFE CPU-KI10,< OPDEF FLADD [DFAD] OPDEF FLMUL [DFMP] OPDEF FLDIV [DFDV] DEFINE DFN (A,B)< DMOVN A,A IFN < &17->, > > ;END OF KI10 CONDITIONAL SUBTTL IMP STRING DEFINITION ;DEFINE AN IMPSTRING TO BE 9-BIT BYTES WITH COUNT AS THE FIRST DEFINE IMPSTR($C) < SALL $N==0 $CT==1 IRPC $C,<$N==$N+1> IRPC $C, IFE $CT-4, < EXP $N $N=="$C" $CT==0> $CT==$CT+1> IFE $CT-3,<$N==$N_11> IFE $CT-2,<$N==$N_22> IFE $CT-1,<$N==$N_33> EXP $N > SUBTTL ERROR MACROS DEFINE ERROR(EVENT,SUBEV,XTRA,EMESS,%A)< SALL MOVE ARG3,XTRA MOVEI P2,%A MOVEI P1,ERRMSG## JSP J,.$MOVE## POP P,J ;GET ORIGINAL RETURN ADDRESS HRREI ARG1,EVENT HRREI ARG2,SUBEV GOTO .$SNAL## ;GOTO IT %A: EMESS > DEFINE PRMERROR(EVENT,SUBEV,XTRA,EMESS,%A)< SALL MOVE ARG3,XTRA MOVEI P2,%A MOVEI P1,ERRMSG## MOVEM J,ARG1 ;SAVE RETURN ADDRESS JSP J,.$MOVE## MOVE J,ARG1 ;GET ORIGINAL RETURN ADDRESS HRREI ARG1,EVENT HRREI ARG2,SUBEV GOTO .$SNAL## %A: EMESS > SUBTTL STORAGE CONSTANTS $IOSIZE==^D2000 $PDLSIZE==200 $STACKSIZE==^D20000 $ERRORS==1 END $$$$$$$$$$$$ &&&&&&&&&&&& INOUT.MAC ;MACRO SIDE OF IMP LIBRARY INVOLVING I/O ; K.FARVIS UNIV. OF EDINBURGH 24TH AUG '76 TITLE NEXTSYMBOL %INTEGERFN NEXTSYMBOL ENTRY NEXTSYMBOL EXTERN INSCB SEARCH IMPPRM NEXTSYMBOL: MOVE IOREG,INSCB SKIPE AC,NXTCHR(IOREG) ;IS THERE A CHAR PENDING POPJ P, ;YES, RETURN IT JSP J,@OPER(IOREG) ;NO, GO TO APPROPRIATE READ ROUTINE MOVEM AC,NXTCHR(IOREG) ;SAVE IT, AND RETURN IT POPJ P, PRGEND TITLE READSYMBOL %ROUTINE READSYMBOL(%INTEGERNAME S) ENTRY READSYMBOL EXTERN INSCB SEARCH IMPPRM READSYMBOL: MOVE IOREG,INSCB SKIPN AC,NXTCHR(IOREG) ;IS THERE A CHAR PENDING? JSP J,@OPER(IOREG) ;NO, GET ONE MOVEM AC,(ARG1) ;RETURN ARGUMENT FOR RSYM SKIPGE FLAGS(IOREG) ANDCAM T1,FLAGS(IOREG) ;CLEAR ZERO SYMBOL FLAG FOR BINARY SETZM NXTCHR(IOREG) ;CLEAR PENDING SYMBOL POPJ P, ;AND RETURN PRGEND TITLE NEXTITEM %STRING(1)%FN NEXTITEM ENTRY NEXTITEM EXTERN INSCB SEARCH IMPPRM NEXTITEM: MOVE IOREG,INSCB SKIPE AC,NXTCHR(IOREG) ;A CHAR PENDING JRST ITRTN ;YES, RETURN IT JSP J,@OPER(IOREG) ;GET ONE MOVEM AC,NXTCHR(IOREG) ;STORE IT ITRTN: IORI AC,1000 ;ADD LENGTH HRLZM AC,NI ;STORE IT MOVEI AC1,NI POPJ P, ; RETURN NI: Z PRGEND TITLE READITEM %ROUTINE READ ITEM(%STRINGNAME S) ENTRY READITEM EXTERN INSCB SEARCH IMPPRM READITEM: MOVE IOREG,INSCB SKIPN AC,NXTCHR(IOREG) ;IS THERE A CHAR PENDING JSP J,@OPER(IOREG) SKIPGE FLAGS(IOREG) ANDCAM T1,FLAGS(IOREG) ;CLEAR ZERO SYMBOL FLAG SETZM NXTCHR(IOREG) ;CLEAR PENDING CHAR IORI AC,1000 ;PUT IN STRING LENGTH HRLZM AC,(ARG1) ;AND PUT TO TOP OF WORD POPJ P, PRGEND TITLE SKIPSYMBOL %ROUTINE SKIPSYMBOL ENTRY SKIPSYMBOL EXTERN INSCB SEARCH IMPPRM SKIPSYMBOL: MOVE IOREG,INSCB SKIPN AC,NXTCHR(IOREG) ;IS THERE A CHAR PENDING? JSP J,@OPER(IOREG) ;NO, GET ONE SKIPGE FLAGS(IOREG) ANDCAM T1,FLAGS(IOREG) ;CLEAR ZERO SYMBOL FLAG SETZM NXTCHR(IOREG) ;AND CLEAR IT POPJ P, ;AND RETURN PRGEND TITLE PRINTSYMBOL %ROUTINE PRINTSYMBOL ; %ROUTINE NEWPAGE ; %ROUTINE NEWLINE ; %ROUTINE SPACE ; %ROUTINE PRINTSYMBOL(%INTEGER S) ENTRY NEWPAGE,NEWLINE,SPACE,PRINTSYMBOL EXTERN OUTSCB SEARCH IMPPRM NEWPAGE: MOVEI ARG1,15 PUSHJ P,PRINTSYMBOL MOVEI ARG1,14 PJRST PRINTSYMBOL NEWLINE: MOVEI ARG1,15 PUSHJ P,PRINTSYMBOL MOVEI ARG1,12 PJRST PRINTSYMBOL SPACE: MOVEI ARG1," " PRINTSYMBOL: MOVE IOREG,OUTSCB PJRST @OPER(IOREG) ;JUMP TO OUTPUT ROUTINE AND RETURN PRGEND TITLE PSTR %ROUTINE PRINTSTRING(%STRING(255) STR) ENTRY PSTR EXTERN OUTSCB,WTTTYI,WTTTYA,WTTY EXTERN OERRT SEARCH IMPPRM PSTR: LDB T4,IMPSPTR ;GET LENGTH OF STRING SKIPG T4 ;IS IT NULL POPJ P, ;YES JUST RETURN MOVE T1,IMPSPTR ;GET THE STRING POINTER MOVE IOREG,OUTSCB ;AND OUTPUT SCB MOVE T2,OPER(IOREG) ;GET THE OUTPUT ROUTINE CAIE T2,WTTY ;IS IT OUR TTY? CAIN T2,WTTTYA ;IS IT TRMOP TYPE? JRST TTYSTR ;YES PSTRLP: ILDB ARG1,T1 ;NO, GET A CHAR PUSHJ P,@OPER(IOREG) ;OUTPUT IT SOJG T4,PSTRLP ;CONTINUE POPJ P, ;AND RETURN WHEN FINISHED TTYSTR: MOVE T2,[POINT 7,1(P)];GET A POINTER TO AN ASCII STRING BASE MOVEM T2,ASCPTR ;AND SAVE MOVEI T5,15 ;LOAD A CR FOR LATER TTSTLP: ILDB T2,T1 ;GET AN IMP CHAR CAIN T2,12 ;IS IT LF IDPB T5,ASCPTR ;YES, OUTPUT A CR FIRST IDPB T2,ASCPTR ;DEPOSIT ASCII CHAR SOJG T4,TTSTLP ;AND CONTINUE IDPB T4,ASCPTR ;AND A ZERO FINALLY MOVE T2,OPER(IOREG) ;GET OPERATION CAIE T2,WTTTYA ;IS IT OUR OWN CONSOLE JRST [OUTSTR 1(P) ;YES, OUTPUT IT POPJ P,] ;AND RETURN MOVEI T1,7 ;GET OUTSTRING FUNCT CODE EXCH T1,FUNCT(IOREG);EXCHANGE FUNCTIONS MOVEI T2,1(P) ;GET ARG ADDR MOVEM T2,OUTARG(IOREG); PLACE ADDRESS IN ARG MOVE T2,ARGPTR(IOREG); GET ARG POINTER TRMOP. T2, ;DO IT JRST ERR ;FAILED MOVEM T1,FUNCT(IOREG) ;RESTORE FUNCT CODE POPJ P, ;RETURN OK ERR: MOVEM T1,FUNCT(IOREG) ;RESTORE FUNCTION CODE JRST OERRT IMPSPTR:POINT 9,(AC),8 ASCPTR: 0 LIT PRGEND TITLE RDDUMP %SYSTEMROUTINE RDDUMP(%RECORD(SCB)%NAME S, %INTEGER LENGTH, %NAME LOC) ENTRY $RDDUMP EXTERN DINERR,DMPEOF SEARCH IMPPRM $RDDUMP: MOVN 0,ARG2 ;CONSTRUCT IOWD IN AC0 HRLZ 0,0 IORI 0,-1(ARG3) SETZM 1 ;0=[IOWD LEN,BUF], 1=[0] XCT 0,IBUFOP(ARG1) ;DO IT POPJ P, ;RETURN MOVE IOREG,ARG1 ;SAVE ADDR OF SCB IN IOREG MOVE AC,FLAGS(IOREG) ANDI AC,17 ;GET DA/SQ CHANNEL NUMBER XCT 0,STATZ(ARG1) JRST DINERR JRST DMPEOF PRGEND TITLE WTDUMP %SYSTEMROUTINE WTDUMP(%RECORD(SCB)%NAME S, %INTEGER LENGTH, %NAME LOC) ENTRY $WTDUMP EXTERN DOUTERR SEARCH IMPPRM $WTDUMP: MOVN 0,ARG2 ;CONSTRUCT IOWD IN AC0 HRLZ 0,0 IORI 0,-1(ARG3) SETZM 1 ;0=[IOWD LEN,BUF] 1 =[ 0 ] XCT 0,OBUFOP(ARG1) ;DO IT POPJ P, MOVE IOREG,ARG1 ;SAVE ADDR OF SCB IN IOREG MOVE AC,FLAGS(IOREG) ANDI AC,17 ;GET DA/SQ CHANNEL NUMBER JRST DOUTERR PRGEND TITLE INOUT GENERAL INPUT/OUTPUT ROUTINES ENTRY ITYSCB,OTYSCB ENTRY IUNSCB,OUNSCB ENTRY RDTTYA,RDTTYI ENTRY WTTY,WTTTYA,WTTTYI ENTRY RDA,RDB ENTRY WTA,WTB ENTRY $INPUT,$OUTPUT ENTRY RDTMP,WTTMP ENTRY RDST,WTST ENTRY DMPEOF,DINERR,DOUTERR ENTRY EOF,INERR,OUTERR,IERRT,OERRT,$INTST,$OUTTST EXTERN ERRMSG EXTERN $GETSTS EXTERN INSCB,OUTSCB SEARCH IMPPRM ;USER CONSOLE TELETYPE INPUT RDTY: TTCALL 4,AC CAIN AC,15 JRST RDTY ;THROW AWAY CR JRST (J) ;OTHER TELETYPE INPUT RDTTYA: MOVE AC,ARGPTR(IOREG) TRMOP. AC, JRST IERRT CAIN AC,15 JRST RDTTYA ;THROW AWAY CR JRST (J) ;IMAGE READ RDTTYI: MOVE AC,ARGPTR(IOREG) TRMOP. AC, JRST IERRT JRST (J) ; ROUTINE FOR ASCII INPUT RDA: SOSGE 0,BYTCNT(IOREG) JRST RDNOK ILDB AC,BYTPTR(IOREG) JUMPE AC,RDA ;THROW AWAY NULLS CAIN AC,15 ;IS IT A CR JRST RDA ;YES THROW AWAY JRST (J) ;RETURN RDNOK: XCT 0,IBUFOP(IOREG) ;DO AN IN CHAN,0 JRST RDA JRST $INTST ;AN ERROR, EOF ETC ;ROUTINE FOR BINARY RDB: MOVSI T1,400000 ;SET BIT 0 FOR TESTING FOR ZERO SYMBOL SKIPGE FLAGS(IOREG) ;IS THE ZERO SYMBOL PENDING BIT SET(BIT 0) JRST (J) ;YES RETURN ZERO RDB01: SOSGE 0,BYTCNT(IOREG) JRST RDBNOK ILDB AC,BYTPTR(IOREG) SKIPN AC ;IS IT ZERO IORM T1,FLAGS(IOREG) ;YES, NOTE IT JRST (J) ; AND RETURN RDBNOK: XCT 0,IBUFOP(IOREG) JRST RDB01 JRST $INTST ;INPUT AND OUTPUT $OUTPUT: MOVE IOREG,OUTSCB SKIPL AC1,DEVTYP(IOREG) CAIN AC1,TTYDEV POPJ P, ;RETURN IF DEVICE IS TTY OR NULL XCT OBUFOP(IOREG) ;OUT UUO POPJ P, JRST $OUTTST ;ERROR $INPUT: MOVE IOREG,INSCB SKIPL AC1,DEVTYP(IOREG) CAIN AC1,TTYDEV POPJ P, ;RETURN IF DEVICE IS TTY OR NULL XCT IBUFOP(IOREG) ;IN UUO POPJ P, JRST $INTST ;EOF OR ERROR SUBTTL OUTPUT ROUTINES ;ALL THESE ROUTINES USE ARG1 FOR THEIR ARGUMENT AND USE THE STACK FOR RETURNING. ;USERS CONSOLE TELETYPE OUTPUT WTTY: CAIN ARG1,12 PJRST WTYNL TTCALL 1,ARG1 POPJ P, WTYNL: MOVEI ARG1,15 TTCALL 1,ARG1 ;OUTPUT CR BEFORE LF MOVEI ARG1,12 TTCALL 1,ARG1 POPJ P, ;OTHER TTY OUTPUT WTTNL: MOVEI ARG1,15 ;TO OUTPUT A NEWLINE TO A TERMINAL PUSHJ P,WTTTYI MOVEI ARG1,12 PJRST WTTTYI WTTTYA: CAIN ARG1,12 PJRST WTTNL ;WRITE A NEWLINE ;ELSE JUST DROP THROUGH WTTTYI: MOVEM ARG1,OUTARG(IOREG) MOVE ARG1,ARGPTR(IOREG) TRMOP. ARG1, JRST OERRT POPJ P, ;ROUTINE TO WRITE ASCII WTANL: MOVEI ARG1,15 ;OUTPUT A CR PUSHJ P,WTB MOVEI ARG1,12 ;AND THEN THE LF PJRST WTB ;AND PRINT WTA: CAIN ARG1,12 ;IS IT A LF PJRST WTANL ;YES, OUTPUT A CR-LF ;NO, JUST DROP THROUGH ;BINARY OUTPUT ROUTINE WTB: SOSGE 0,BYTCNT(IOREG) JRST WTNOK IDPB ARG1,BYTPTR(IOREG) POPJ P, WTNOK: XCT 0,OBUFOP(IOREG) JRST WTB JRST $OUTTST SUBTTL TMPCOR READ AND WRITE ROUTINES ;READ ROUTINE FOR TMPCOR RDTMP: SOSGE 0,BYTCNT(IOREG) JRST EOF ;END OF FILE ILDB AC,BYTPTR(IOREG) JUMPE AC,EOF ;NULLS MEAN EOF CAIN AC,15 ;IS IT A CR JRST RDTMP ;YES, THROW AWAY JRST (J) ;RETURN ;WRITE ROUTINE FOR TMPCOR WTTMNL: MOVEI ARG1,15 PUSHJ P,.WTTMP MOVEI ARG1,12 PJRST .WTTMP WTTMP: CAIN ARG1,12 ;IF NEWLINE JRST WTTMNL ;INCLUDE A CR .WTTMP: SKIPG 0,BYTCNT(IOREG) ;MORE ROOM IN CORE? POPJ P, ;NO, RETURN SOSLE 0,BYTCNT(IOREG) ;MORE ROOM IN CORE IDPB ARG1,BYTPTR(IOREG) ;YES POPJ P, ;RETURN SUBTTL STRING READ AND WRITE ROUTINES RDST: SOSGE LENGTH(IOREG) ;ANY LEFT? JRST EOF ;NO ILDB AC,POINTER(IOREG) ;GET NEXT BYTE CAIN AC,15 ;IS IT CR? JRST RDST ;YES, IGNORE IT JRST (J) ;NO, RETURN WTST: CAIN ARG1,12 ;NEWLINE? PJRST WTSNL ;YES WTST1: AOS LENGTH(IOREG) ;NOTE LENGTH IDPB ARG1,POINTER(IOREG) ;DEPOSIT BYTE POPJ P, ;RETURN WTSNL: MOVEI ARG1,15 ;INSERT CR PUSHJ P,WTST1 MOVEI ARG1,12 ;AND LINE FEED PJRST WTST1 SUBTTL ERROR TESTING $INTST: HLRZ ARG1,FILOPFN(IOREG) ;GET CHANNEL NUMBER PUSHJ P,$GETSTS ;GET THE STATUS TRNE AC,740000 JRST INERR ;AN ERROR TRNE AC,020000 JRST EOF ;ELSE NON-BLOCKING RETURN PUSHJ P,INSTREAM## ;GET STREAM NUMBER ERROR 9,1,AC,IMPSTR $OUTTST: HLRZ ARG1,FILOPFN(IOREG) ;GET CHANNEL NUMBER PUSHJ P,$GETSTS ;GET STATUS TRNE AC,740000 JRST OUTERR ;AN ERROR ;ELSE NON-BLOCKING RETURN PUSHJ P,OUTSTREAM## ;GET STREAM NUMBER ERROR 9,2,AC,IMPSTR SUBTTL ERROR CONDITIONS AND EOFS INERR: PUSH P,IOREG PUSHJ P,INSTREAM## ;GET STREAM NUMBER POP P,IOREG ;RESTORE IOREG DINERR: PUSH P,AC ;SAVE STREAM/CHANNEL NUMBER HLRZ ARG1,FILOPFN(IOREG); GET CHANNEL NUMBER ANDI ARG1,17 ;JUST THE CHANNEL PUSHJ P,$GETSTS ; GET STATUS JRST IERT0 IERRT: PUSH P,T2 ;SAVE ERROR CODE PUSHJ P,INSTREAM## EXCH AC,(P) ;SWAP ERROR CODE AND STREAM NUMBER IERT0: MOVE T1,[POINT 9,IER1+15,8]; **BBIT DODGY, PATCHING STRING MOVE T2,[POINT 3,AC,17] MOVSI T4,-6 IER0: ILDB T3,T2 ADDI T3,"0" IDPB T3,T1 AOBJN T4,IER0 POP P,AC ;RESTORE STREAM/CHANNEL NUMBER IER1: ERROR 4,1,AC,IMPSTR OUTERR: PUSH P,IOREG PUSHJ P,OUTSTREAM## ;GET STREAM NUMBER POP P,IOREG DOUTERR:PUSH P,AC ;SAVE STREAM/CHANNEL NUMBER HLRZ ARG1,FILOPFN(IOREG); GET CHANNEL NUMBER ANDI ARG1,17 ;JUST THE CHANNEL PUSHJ P,$GETSTS ; GET STATUS JRST OERT0 OERRT: PUSH P,T2 ;SAVE TTY ERROR CODE PUSHJ P,OUTSTREAM## EXCH AC,(P) ;SWAP ERROR CODE AND STREAM NUMBER OERT0: MOVE T1,[POINT 9,OER1+15,17]; **PATCHING STRING IN ERROR MACRO MOVE T2,[POINT 3,AC,17] MOVSI T4,-6 OER0: ILDB T3,T2 ADDI T3,"0" IDPB T3,T1 AOBJN T4,OER0 POP P,AC ;RESTORE STREAM/CHANNEL NUMBER OER1: ERROR 4,2,AC,IMPSTR ;EOF DMPEOF: ERROR 9,0,AC,IMPSTR EOF: PUSHJ P,INSTREAM## ERROR 9,0,AC,IMPSTR RDUND: PUSHJ P,INSTREAM## ERROR 8,1,AC,IMPSTR WTUND: PUSHJ P,OUTSTREAM## ERROR 8,2,AC,IMPSTR SUBTTL STORAGE ; SCB BLOCKS FOR UNDEFINED I/O ;**TEMP LENGTH UNTIL %SHORINTEGER DEVTYPE AND CHNTYP IUNSCB: UNDEV 0 0 RDUND BLOCK 4 OUNSCB: UNDEV 0 0 WTUND BLOCK 4 ITYSCB: TTYDEV 0 0 RDTY BLOCK 4 OTYSCB: TTYDEV 0 0 WTTY BLOCK 4 LIT END $$$$$$$$$$$$ &&&&&&&&&&&& IMPRUN.MAC TITLE IMPRUN IMP DRIVER PROGRAM SUBTTL DEFINITIONS ENTRY .$INIT,.$CCIN INTERNAL %%TRAP,MONITOR ENTRY $IMPXT INTERNAL RUNDEV,RUNFILE,RUNPPN INTERNAL CCL,BATCH ENTRY PDEC EXTERNAL ERRMSG EXTERNAL $SIGNAL,%GO,$FINIT EXTERNAL $INITIO,$INITSTACK,$INITHEAP,CPU EXTERNAL STACKSIZE,STACKTOP,STACKBASE TWOSEG 400000 SEARCH IMPPRM,C IFNDEF FTAND20, SUBTTL DRIVING CODE ; THIS SETS UP THE STACK, CALLS I/O INITIALISATION, THE MAIN PROGRAM AND ; THE I/O CLOSING ROUTINE BEFORE EXITING. .$INIT: TDZA T1,T1 ;START ADDRESS .$CCIN: SETO T1, ;FOR CCL ENTRY MOVEM T1,CCL ;SET CCL EXTERNAL IFN FTAND20,< MOVEM 0,RUNFILE ;SAVE FILE NAME MOVEM 7,RUNPPN ;SAVE DIRECTORY MOVEM 11,RUNDEV ;SAVE DEVICE >;END FTAND20 SETZB T3,CPU ;SET CPU INDICATOR MOVNI T1,1 ;DETERMINE PROCESSOR TYPE AOBJN T1,.+1 JUMPN T1,CONT ;KA10 BLT T1,0 HRRZM T1,CPU ;KL10 T1=1,1 ; KI10 T1=0 AOS CPU ;SO KL10=2, KI10=1 CONT: IFN FTAND20,< MOVEI T1,677777 MOVEM T1,.JBREL ;FOR KL20 >;END FTAND20 SETZM BATCH ;SET BATCH INDICATOR MOVNI T1,-1 CTLJOB T1, SETOM BATCH ;A BATCH JOB RESET MOVE T1,[XWD 34,11] ;MONITOR VERSION GETTAB T1, SETZ T1, HRRZ T1,T1 LSH T1,-6 ;GET JUST MAIN RELEASE NUMBER IFN FTAND20,< MOVEM T1,MONITOR JUMPN T1,CONT1 ;CONTINUE IF NON-ZERO MOVE T1,CPU CAIN T1,2 ;IF ZERO AND CPU=KL THEN A DEC-20 JRST [AOS CPU JRST CONT2] >;END FTAND20 IFE FTAND20,< SKIPN T1 >;END FTAND20 MOVEI T1,503 MOVEM T1,MONITOR ;OTHERWISE A 503 OR PREVIOUS MONITOR IFN FTAND20,< CONT1: MOVE T1,.JBFF MOVEM T1,.JBREL ;RESET JBREL IF NOT KL-20 CONT2: >;END FTAND20 SETZ T1, ;FOR THIS JOB RUNTIME T1, ;GET RUNTIME MOVEM T1,.RUN ;STORE MOVE T3,CPU ;GET CPU INDICATOR SUBI T3,3 JUMPE T3,[MSTIME T1, JRST CONT3] MOVE T1,[XWD 53,11] ;UNIVERSAL DATE-TIME GETTAB T1, SETZ T1, CONT3: MOVEM T1,.ELAP ;STORE ELAPSED TIME MOVEI T1,%%TRAP ;GET THE CORE EXPANSION TRAP ADDRESS MOVEM T1,.JBAPR ;AND SAVE IFE FTAND20,< MOVEI T1,AP.REN!AP.POV!AP.FOV!AP.AOV!AP.ILM ;GET ERROR CONDITIONS >;END FTAND20 IFN FTAND20,< MOVEI T1,AP.REN!AP.POV!AP.FOV!AP.AOV ;GET THE ERROR CONDITIONS SKIPE T3 ;SKIP IF DEC-20 IORI T1,AP.ILM ;ADD TRAP FOR ILL. MEM. REFS >;END FTAND20 APRENB T1, ;AND ENABLE TRAPPING MOVEI T1,.$REEN ;SET UP REENTER CODE MOVEM T1,.JBREN ;AND STORE IT MOVE P,[-^D25,,.WORK];GET TEMPORARY WORK PDL SETZ BASE1, ;NOTE ZERO RETURN CALL $INITIO ;SET UP INPUT OUTPUT STREAMS CALL $INITSTACK ;SET UP STACK CALL $INITHEAP ;AND HEAP CALL %GO ;GO TO IMP PROGRAM $IMPXT: CALL $FINIT ;FINISH UP ROUTINE TO CLOSE FILES ;NOW PRINT RUN AND ELAPSED TIME SETZ T1, ;FOR THIS JOB RUNTIM T1, ;GET RUNTIME SUBB T1,.RUN ;MAKE INCREMENTAL AND STORE OUTSTR [ASCIZ/ IMP: Cpu time /] MOVE P,[-^D25,,.WORK] ;SET UP STACK IDIVI T1,^D1000 ;GET NUMBER OF SECS CAIG T1,^D60 ;IS IT MORE THAN A MINUTE? JRST [PUSHJ P,PDEC ;JUST PRINT SECONDS JRST XT0] PUSHJ P,PTIME ;PRINT IT XT0: OUTCHR ["."] ;DECIMAL POINT MOVE T1,.RUN IDIVI T1,^D1000 MOVE T1,T2 ;GET FRACT PART ADDI T1,5 IDIVI T1,^D10 ;ACCURATE TO 2 DECIMAL PLACES PUSHJ P,PDEC2 ;PRINT IT OUTSTR [ASCIZ/ Elapsed /] IFN FTAND20,< MOVE T3,CPU ;GET CPU INDICATOR SUBI T3,3 JUMPE T3,[MSTIME T1, ;FOR KL-20 GET TIME OF DAY SUBB T1,.ELAP ;MAKE INCREMENTAL AND STORE IDIVI T1,^D1000 ;MAKE INTO SECONDS JRST XT1] >;END FTAND20 MOVE T1,[XWD 53,11] ;UNIVERSAL DATE TIME GETTAB T1, SETZ T1, SUBB T1,.ELAP ;STORE IT IMULI T1,^D24 ;GET HOURS HLRZ T2,T1 ;SAVE HRRZ T1,T1 ;KEEP SECS AND MINS IMULI T2,^D3600 ;GET HOURS AS SECS IMULI T1,^D3600 ;AND HOURS AND MINS HLRZ T1,T1 ADD T1,T2 ;ADD THEM TOGETHER XT1: MOVEM T1,.ELAP ;SAVE NUMBER OF SECONDS PUSHJ P,PTIME ;PRINT IT EXIT 0, ;CLOSE THE FILES %%TRAP: MOVEM T1,SAVAC ;SAVE THE T1 CONTENTS MOVE T1,.JBCNI ;GET ERROR CONDITION TRNE T1,AP.ILM ;IS IT AN ILL MEM REF? JFCL 17,%ILM ;YES TRNE T1,AP.POV ;IS IT PDL OV? JFCL 17,%POV ;YES TRNE T1,AP.AOV ;IS IT ARITH OVERFLOW? JRST %ARITH ;YES ;THIS CODE LATER FOR CORE ALLOC ; MOVE T1,.JBTPC ;GET PC ; MOVE T1,(T1) ;GET THE INSTRUCTION TRAPPED ON ; **** CHECK FOR BLT, OR SETMM ; CAMN T1,[ SETMM P,(P) ] ;IS IT SPECIAL PLANTED INSTRUCTION ; JFCL 17,%ALLOC ;YES, GET SOME CORE ILM: OUTSTR [ ASCIZ/ ?IMP: Ill Mem Ref at user pc /] JRST ABORT POV: OUTSTR[ASCIZ/ ?IMP: PDL Overflow at user pc /] ABORT: MOVE T1,SAVAC ;GET OLD VALUE MOVEM 17,ST17 MOVEI 17,SAC0 BLT 17,ST16 ;SAVE ACS HRRZ T1,.JBTPC MOVE P,[-^D25,,.WORK] ;SET UP STACK PUSHJ P,POCT ;PRINT LOCATION HRLZI 17,SAC0 BLT 17,17 ;RESTORE ACS EXIT 1, %ILM: MOVE T1,.JBTPC ;GET PC HLRZ T1,(T1) ;GET LH OF INSTRUCTION CAIN T1,416017 ;IS IT A SETMM N(P) - I.E.A PLANT JRST ILM1 ;YEP- GET ADDRESS MOVE T1,.JBTPC ;GET IT AGAIN LDB T1,[POINT 4,(T1),17]; GET INDEX REGISTER CAIE T1,P ;IS IT THE STACK POINTER? JRST ILM ;NO, GENUINE ERROR HRR T1,P ;GET LOC JRST ILM2 ;CARRY ON ILM1: MOVE T1,.JBTPC ;GET PC MOVEI T1,@(T1) ;GET REQUIRED ADDRESS ILM2: SKIPLE STACKSIZE ;HAS STACKSIZE BEEN SET? JRST ILM ;YES SO DO NOT EXPAND CAMLE T1,STACKBASE ;<=THAN CURRENT BASE OF STACK? JRST %ALLOC ;NO, GO GET IT JRST ILM ;ERROR %POV: JRST %ILM ;**TEMP** MOVE T1,.JBTPC ;GET PC LDB T1,[POINT 4,(T1),12];GET AC NUMBER CAIE T1,P ;IS IT OF THE PROCEDURE STACK JRST POV ;NO DIFFERENT PDL- ERROR ERROR 2,2,0,IMPSTR %ARITH: OUTSTR [ASCIZ/?Arithmetic overflow at user PC /] MOVE T1,SAVAC ;GET OLD VALUE MOVEM 17,ST17 MOVEI 17,SAC0 BLT 17,ST16 ;SAVE ACS HRRZ T1,.JBTPC MOVE P,[-^D25,,.WORK] ;SET UP STACK PUSHJ P,POCT ;PRINT LOCATION HRLZI 17,SAC0 BLT 17,17 ;RESTORE ACS OUTSTR [ASCIZ/ /] JRSTF @.JBTPC ;RETURN MOVE ARG3,.JBTPC ERROR 1,1,ARG3,IMPSTR %ALLOC: LSH T1,-11 ;MAKE INTO P MOVEM T1,.TOPPAGE ;SAVE VALUE SETZM .PARGS AOS .PARGS ;1 ARGUMENT MOVE T1,STACKTOP ;GET CURRENT TOP OF STACK LSH T1,-11 ;MAKE INTO PAGES MOVEM T1,.PARGS+1 ;SAVE IT GETPAGE:AOS .PARGS+1 ;NEW PAGE REQUIRED MOVE T1,[ 1,,.PARGS] PAGE. T1, ;GET IT JRST NOCORE ;FAILED HRRZ T1,.PARGS+1 CAME T1,.TOPPAGE ;GOT THEM ALL? JRST GETPAGE ;NO, GET ANOTHER LSH T1,11 ;CONVERT TO WORDS IORI T1,777 ;END OF PAGE ADDR MOVEM T1,STACKTOP ;SAVE NEW VALUE MOVE T1,SAVAC ;RESTORE AC JRSTF @.JBTPC ;CARRY ON GOVIRT:MOVE T1,.PARGS+1 ;GET PAGE NUM TLO T1,200000 ;SET VIRT BIT SOJ T1, MOVEM T1,.PARGS+1 ;FOR SAME PAGE JRST GETPAGE ;TRY AGAIN NOCORE: CAIN T1,12 ;RUN OUT OF CORE? JRST GOVIRT ;YES ERROR 2,1,T1,IMPSTR ;THE REENTER CODE HAS TO STEP ON TILL IT KNOWS IT IS IN THE BODY OF A ;BLOCK, WHICH IT KNOWS AS SOON AS IT FINDS A JUMP TYPE INSTRUCTION .$REEN: HRRZS .JBOPC ;GET JUST THE ADDRESS $REELP: MOVEM T1,ST1 ;SAVE A WORK REGISTER LDB T1,[POINT 9,@.JBOPC,8]; GET THE OP CODE OF THE INSTRUCTION CAIL T1,252 ;IS IT ANY OF THE JUMP CAILE T1,377 ;INSTRUCTIONS JRST $XCTIT ;NO, THEN EXECUTE IT CAIGE T1,277 ;UNLESS IT IS AN ADD? CAIL T1,270 ;TYPE JRST $XCTIT ;YES, DO IT CAIN T1,263 ;IS IT A POPJ - A RETURN HRRZM P,.JBOPC ;YES, SAVE THE PREVIOUS PC HRRZ J,.JBOPC ;GET THE PC THEN AND SIGNAL SETZ AC, PRMERROR 0,-2,AC,IMPSTR $XCTIT: MOVE T1,ST1 ;RESTORE T1 XCT @.JBOPC ;EXECUTE INTRUCTION AOS .JBOPC ;STEP ON THROUGH THE PROGRAM JRST $REELP ;AND CONTINUE ; PTIME PRINTS THE TIME AS HRS:MINS:SECS ; T1=TIME IN SECONDS PTIME: PUSH P,T1 ;SAVE TIME ON STACK IDIVI T1,^D3600 ;GET HOURS PUSHJ P,PDEC ;PRINT IT OUTCHR [":"] MOVE T1,(P) IDIVI T1,^D3600 MOVE T1,T2 IDIVI T1,^D60 ;GET MINUTES PUSHJ P,PDEC2 ;PRINT IT OUTCHR [":"] POP P,T1 IDIVI T1,^D60 MOVE T1,T2 PJRST PDEC2 ;PRINT IT ; POCT OUTPUTS A SIGNED OCTAL NUMBER TO THE TERMINAL ; PDEC OUTPUTS A SIGNED DECIMAL NUMBER TO THE TERMINAL ; THE NUMBER IS PASSED IN AC AND IT ZAPS T1,T2,T3 ; PDEC2 OUTPUTS 2 DECIMAL DIGITS PDEC2: MOVEI T3,^D10 CAMGE T1,T3 OUTCHR ["0"] ;OUTPUT A LEADING ZERO IF NECESSARY JRST PNUML PDEC: SKIPA T3,[^D10] POCT: MOVEI T3,^D8 JUMPGE T1,PNUML OUTCHR ["-"] MOVN T1,T1 PNUML: IDIV T1,T3 HRLM T2,(P) SKIPE T1 PUSHJ P,PNUML HLRZ T1,(P) ADDI T1,"0" OUTCHR T1 POPJ P, SUBTTL STORAGE RELOC 0 ;GENERAL AC SAVING AREA SAC0: Z ST1: Z SAC2: Z SAC3: Z SAC4: Z SAC5: Z SAC6: Z SAC7: Z ST10: Z ST11: Z ST12: Z ST13: Z ST14: Z ST15: Z ST16: Z ST17: Z ;STORAGE FOR %%TRAP SAVAC: Z ;SAVE THE AC .TOPPAGE: Z ;TOP PAGE OF REQUIRED STACK .PARGS: BLOCK 2 ;PAGE ARGUMENT BLOCK ;GLOBALS CCL: Z ;SET TO -1 IF PROGRAM ENTERED AT CCL ENTRY BATCH: Z ;SET TO -1 IF PROGRAM RUN UNDER BATCH MONITOR: Z ;MONITOR NUMBER RUNFILE: Z ;RUN PROGRAMS FILE NAME RUNDEV: Z ;AND DEVICE NAME RUNPPN: Z ;AND DIRECTORY .RUN: Z ;STORE RUNTIME IN MILISECS .ELAP: Z ;STORE ELAPSED TIME IN MILISECS .WORK: BLOCK ^D25 ;WORK SPACE LIT END $$$$$$$$$$$$ &&&&&&&&&&&& PRMLIB.MAC TITLE .$ALOC ARRAY SPACE ALLOCATION ENTRY .$ALOC EXTERN ERRMSG,.$SNAL,.$MOVE SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$ALOC: SUB T1,T2 AOJLE T1,$.ERR IMUL T1,AC IMUL T2,AC MOVN T2,T2 JRST AC,0(J) $.ERR: PRMERRORR 23,0,0,IMPSTR PRGEND TITLE .$CONC STRING CONCATENATION PRIMITIVE ; .$CONC CONCTENATES THE STRING POINTED TO BY P2 ONTO THE END OF ; THE STRING POINTED TO BY P1. ; P1 AND P2 ARE PRESERVED ; AC,T4 AND T5 ARE DESTROYED ENTRY .$CONC EXTERN ERRMSG,.$SNAL,.$MOVE SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$CONC: MOVE AC,[POINT 9,(P2),8] MOVEM AC,P2POINT ;SAVE IT LDB T2,P2POINT ;GET LENGTH OF P2 JUMPE T2,0(J) ;IF NULL RETURN MOVEM T2,AC ;STORE LENGTH FOR A CYCLE COUNT LDB T1,BYTTBL ;GET LENGTH OF P1 ADD T2,T1 ;GET NEW LENGTH CAILE T2,^D255 JRST $COERR ;TOO LONG DPB T2,BYTTBL ;DEPOSIT NEW LENGTH IN NEW STRING MOVEM T1,T2 ;MAKE COPY OF LENGTH OF P1 ANDI T2,3 ;GET BYTE NUMBER LSH T1,-2 ;AND WORD NUMBER IOR T1,BYTTBL(T2) ;AND HENCE APPROPRIATE POINTER SLP: ILDB T2,P2POINT ;GET BYTE FROM P2 IDPB T2,T1 ;COPY IT ONTO END OF P1 SOJG AC,SLP ;CONTINUE JRST 0(J) ;RETURN $COERR: PRMERROR 6,1,0,IMPSTR P2POINT: Z BYTTBL: POINT 9,(P1),8 POINT 9,(P1),17 POINT 9,(P1),26 POINT 9,(P1),35 PRGEND TITLE .$MOVE STRING MOVE ENTRY .$MOVE SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 ; .$MOVE TAKES THE STRING POINTED TO BY P2 AND MOVES IT TO THE ; LOCATIONS POINTED TO BY P1. ; P1 IS PRESERVED ; P2 AND AC ARE DESTROYED .$MOVE: HRL P2,P2 HLRZ AC,0(P2) ;GET FIRST WORD OF STRING LSH AC,^D-11 ;GET NUMBER OF WORDS FROM LENGTH HRR P2,P1 HRRZ T1,P1 ADD T1,AC BLT P2,(T1) ;COPY JRST 0(J) ;RETURN PRGEND TITLE .$COMP STRING COMPARISON ENTRY .$COMP SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 ; .$COMP COMPARES THE STRINGS POINTED TO BY P1 AND P2 ; RESULTS ARE AC<0 IF P10 IF P1>P2 ; P1 AND P2 ARE PRESERVED ; AC,T1 AND T2 ARE DESTROYED .$COMP: DMOVE T1,P1PT ;GET THE 2 POINTERS DMOVEM T1,P1PTR ;SAVE THEM LDB AC,P1PTR ;GET LENGTH OF P1 LDB T2,P2PTR ;GET LENGTH OF P2 CAMLE T2,AC ; MOVE T2,AC ;GET WHICHEVER LENGTH IS SHORTER JUMPE T2,COMFIN ;IF ZERO DO NOT COMPARE FIRST BYTE LP: ILDB AC,P1PTR ;GET CHAR FROM P1 ILDB T1,P2PTR ;GET CHAR FROM P2 SUB AC,T1 JUMPN AC,0(J) ;RETURN WITH CORRECT VALUE IN AC IF NOT EQUAL SOJG T2,LP ;KEEP GOING UNTIL DONE ;HERE WHEN ALL EQUAL COMFIN: LDB AC,P1PT ;GET LENGTH OF P1 LDB T1,P2PT ;GET LENGTH OF P2 SUB AC,T1 ;GET APPROPRIATE VALUE IN AC JRST 0(J) ;RETURN P1PT: POINT 9,(P1),8 P2PT: POINT 9,(P2),8 P1PTR: Z P2PTR: Z PRGEND TITLE .$IEXP INTEGER EXPONENTIATION SEARCH IMPPRM ENTRY .$IEXP ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$IEXP: MOVEI P2,1 IEX1: SOJL AC,0(J) IMUL P2,P1 JRST AC,IEX1 ;*;SINGLE PRECISION INTEGER TO INTEGER EXP FUNCTION. ;* ;*;EXP CALCULATES I**J, WHERE ;* ;*A=0 ;*B=1 ;*C=2 ;*D=3 ;*E=4 ;*F=5 ;*G=6 ;*H=7 ;*P=17 ;* ;*; J=Q(0) + Q(1)*2 + Q(2)*4 + ..., WHERE Q(I)=0 OR 1. ;*IEXP: JUMPE B,[MOVEI A,1 ;BASE**0 RETURNS 1 ;* POPJ P,] ;* JUMPN A,BASNT0 ;GO AHEAD IF BASE NE 0. ;* JUMPGE B,IEXP4 ;RETURN IF BASE=0, EXP >= 0. ;*IOVFL: ERROR (APR,5,1,.+1) ;O'E, SET UP ;* HRLOI 0,377777 ;ANS.= INFINITY ;* POPJ 17, ;AND RETURN. ;* ;*BASNT0: JUMPL B,[TRNN B,1 ;TEST FOR EXP<0. IS EXP ODD? ;* MOVMS A ;EXP IS EVEN. GET ABS(BASE) ;* CAIE A,1 ;IS BASE +-1? ;* CAMN A,[-1] ;* POPJ P, ;YES, RETURN +-1 ;* MOVEI A,0 ;NO, RETURN 0 ;* POPJ P,] ;* PUSH P,C ;SAVE A WORKING AC. ;* MOVEI C,1 ;INITIALIZE ANSWER TO 0. ;* MOVEM C,SAVEC ;INITIALIZE FLAG WORD TO > 0. ;* JUMPG A,IEXP2 ;GO TO CALC. IF ANSWER WILL BE > 0. ;* TRNN B,1 ;IS EXP ODD OR EVEN? ;* JRST IEXP2 ;EXP IS EVEN, ANS WILL BE > 0. ;* SETCMM SAVEC ;EXP IS ODD, BASE < 0, ANS WILL BE <0. ;* JRST IEXP2 ;GO TO CALC. ;* ;*IEXP1: IMUL A,A ; ;* JFCL 1,OVER ;TRANSFER TO OVER IF OVERFLOW. ;* LSH B,-1 ;DIVIDE B BY 2. ;*IEXP2: TRZE B,1 ;CHECK LAST BIT OF B. ;* IMUL C,A ; ;* JFCL 1,OVER ;TRANSFER TO OVER IF OVERFLOW. ;* JUMPG B,IEXP1 ;GO TO RETURN IF B HAS BECOME 0. ;*IEXP3: MOVE A,C ;PUT ANSWER IN AC A. ;*IEXP3A: POP P,C ;RESTORE AC C. ;*IEXP4: POPJ P, ;RETURN. ;* ;*OVER: PUSHJ P,IOVFL ;SET ANSWER TO + INFINITY. ;* SKIPL SAVEC ;SKIP IF ANS IS TO BE < 0. ;* JRST IEXP3A ;GO TO RETURN. ;* MOVNS A,A ;SET UP - ;* SUBI A,1 ;INFINITY ;* JRST IEXP3A ;GO TO RETURN. ;* ;*SAVEC: 0 ;* ;* LIT PRGEND TITLE .$REXP REAL EXPONENTIATION SEARCH IMPPRM ENTRY .$REXP ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$REXP: MOVM T5,AC HRLZI P2,201400 SOJL T5,REX2 REX1: FMPR P2,P1 SOJGE T5,REX1 REX2: JUMPGE AC,0(J) MOVE P1,P2 HRLZI P2,201400 FDVR P2,P1 JRST AC,0(J) ;*;SINGLE PRECISION FORTRAN IV EXP.3 FUNCTIONS ;*;THESE ROUTINES CALCULATE A FLOATING POINT NUMBER RAISED TO A ;*;FLOATING POINT POWER. THE CALCULATION IS ;*; A**B= EXP(B*LOG(A)) ;* ;*;IF THE EXPONENT IS AN INTEGER < 2**35 IN MAGNITUDE, THE ;*;RESULT WILL BE COMPUTED USING "EXP2.." AND THE ANSWER ;*;WILL HAVE THE CORRECT SIGN. (REMEMBER THAT THE "INTEGER" ;*;HAS ONLY 27 SIGNIFCANT BITS.) ;*;SINCE NEGATIVE NUMBERS RAISED TO NON-INTEGER POWERS YIELD ;*;COMPLEX ANSWERS, THE MAIN ALGORITHM CALCULATES ;*; EXP(B*LOG(ABSF(A))) ;*;ACCUMULATOR DEFINITIONS ;* A= 0 ;* B= 1 ;* C= 2 ;* D= 3 ;* E= 4 ;* F= 5 ;* G= 6 ;* H= 7 ;* Q= 16 ;* P= 17 ;* ;*REXP: JUMPE B,[MOVSI A,(1.0) ;BASE**0, RETURNS 1 ;* POPJ P,] ;* JUMPN A,EXP30A ;GO AHEAD IF BASE NE 0. ;* JUMPGE B,EXP3A ;EXIT IF BASE = 0, EXP >= 0, ;* ERROR (APR,5,1,.+1) ;O'E, TYHE AN ERROR MESSAGE ;* HRLOI A,377777 ;ANS.=+INFINITY ;* POPJ 17, ;AND EXIT. ;* ;*EXP30A: PUSH P,C ;SAVE AC C ;* PUSH P,D ;SAVE AC D ;* MOVM D,B ;SET EXP. POSITIVE. ;* MOVEI C,0 ;CLEAR AC C TO ZERO ;* LSHC C,11 ;SHIFT 9 PLACES LEFT ;* SUBI C,200 ;TO OBTAIN SHIFTING FACTOR ;* PUSH P,E ;SAVE AC E. ;* JUMPLE C,EXP3GO ;IS C > 0 ;* HRR E,C ;SET UP E AS AN INDEX REG. ;* MOVEI C,0 ;CLEAR OUT AC C ;* LSH D,-1 ;RIGHT ADJUST EXP TO BIT 1. ;* ASHC C,(E) ;SHIFT LFT BY CONTENTS OF E ;* JFCL EXP3GO ;IF OVERFLOW, GO TO EXP3GO. ;* JUMPN D,EXP3GO ;IS EXPONENT AN INTEGER ? ;* JUMPGE B,.+2 ;YES, WAS IT NEG. ? ;* MOVNS C ;YES, NEGATE IT ;* MOVE B,C ;MOVE INTEGER INTO B ;* PUSHJ P,EXP2.. ;%216% OBTAIN RESULT USING EXP2.. ;* JRST EXPPOP ;RETURN TO RESTORE ACS C&D&E. ;* ;*EXP3GO: MOVM E,A ;GET ABS(BASE) IN NE 0 OR 1. ;* MOVE D,A ;SAVE SIGN OF A ;* MOVE C,B ;SAVE AC B. ;* FUNCT ALOG., ;CALCULATE LOG OF A ;* FMPRM A, C ;CALCULATE B*LOG(A) ;* FUNCT EXP., ;CALCULATE EXP(B*LOG(A)) ;* JUMPGE D,EXPPOP ;SHOULD SIGN BE NEGATIVE? ;* MOVN A,A ;YES, NEGATE RESULT ;*EXPPOP: POP P,E ;RESTORE AC E. ;* POP P,D ;RESTORE AC D. ;* POP P,C ;RESTORE AC C. ;*EXP3A: POPJ P, ;EXIT ;* ;* LIT ;* PRGEND ;*;SINGLE PRECISION EXP.2 FUNCTIONS ;*;THESE ROUTINES CALCULATE A FLOATING POINT NUMBER TO A FIXED ;*;POINT POWER. THE CALCULATION IS A**B, WHERE B IS OF THE FORM ;* ;*; B=Q(0) + Q(1)*2 + Q(2)*4 + ...WHERE Q(I)=0 OR 1 ;* ;*;THERE ARE NO RESTRICTIONS ON THE BASE OR EXPONENT ;* ;*EXP2..: JUMPE B,[MOVSI A,(1.0) ;BASE**0, RETURNS 1 ;* POPJ P,] ;* JUMPN A,EXP2A ;GO AHEAD IF BASE NE 0. ;* JUMPGE B,FEXP4 ;EXIT IF BASE =0, EXP >= 0, ;* ERROR (APR,5,1,.+1) ;O'E, SET UP ;* HRLOI 0,377777 ;AN ANSWER OF INFINITY. ;* POPJ 17, ;RETURN. ;* ;*EXP2A: MOVEM C,SAVEC ;SAVE A WORKING ACCUMULATOR. ;* MOVSI C, 201400 ;GET 1.0 IN ACCUMULATOR C. ;* MOVEM A,SAVEA ;STORE BASE IN SAVEA. ;* MOVEM B,SAVEB ;STORE EXP. IN SAVEB. ;* JUMPGE B, FEXP2 ;IS EXPONENT POSITIVE? ;* MOVMS B ;NO, MAKE IT POSITIVE ;* JFCL MININF ;IF EXP WAS 400000,,0 GO TO MININF. ;* PUSHJ P, FEXP2 ;CALL MAIN PART OF PROGRAM. ;*INV: MOVSI B, 201400 ;GET 1.0 IN B. ;* FDVM B, A ;FORM 1/(A**B) FOR NEG. EXPONENT. ;* POPJ P, ;RETURN. ;* ;*FEXP1: FMP A, A ;FORM A**N, FLOATING POINT. ;* JFCL OVER ;IF OVER/UNDERFLOW, GO TO OVER. ;* LSH B, -1 ;SHIFT EXPONENT FOR NEXT BIT. ;*FEXP2: TRZE B, 1 ;IS THE BIT ON? ;* FMP C, A ;YES, MULTIPLY ANSWER BY A**N. ;* JFCL OVER ;IF OVER/UNDERFLOW, GO TO OVER. ;* JUMPN B, FEXP1 ;UPDATE A**N UNLESS ALL THROUGH. ;*FEXP3: MOVE A, C ;PICK UP RESULT FROM C. ;*FEXP3A: MOVE C,SAVEC ;RESTORE A WORKING ACCUMULATOR. ;*FEXP4: POPJ P, ;RETURN. ;*OVER: MOVE C,.JBTPC ;PICK UP FLAGS. ;* SKIPG SAVEB ;JUMP TO INVERT IF ;* JRST INVERT ;EXP. WAS NEGATIVE. ;* TLNE C,(1B11) ;UNDERFLOW, IN WHICH CASE, ;* ERROR (APR,7,1,OUT) ;UNDER FLOW ;* ERROR (APR,5,1,OUT) ;OVER FLOW ;*OUT: HRLOI A,377777 ;ANS. IS SET TO + INFINITY. ;* TLNE C,(1B11) ;SKIP IF OVERFLOW FLAG SET. ;* SETZ A, ;O'E, SET ANSWER TO 0. ;*OUT2: SKIPL SAVEA ;ANS. IS >= 0, IF ;* JRST FEXP3A ;A WAS >= 0. ;* MOVE B,SAVEB ;PICK UP THE EXP. ;* TRNE B,1 ;ANS. IS < 0, IF A < 0 AND ;* MOVNS A ;THE EXP. WAS ODD. ;* JRST FEXP3A ;GO TO RETURN. ;* ;*INVERT: SUB P,[XWD 1,1] ;ADJUST PDP. ;* TLCN C,(1B11) ;IF TRUE UNDERFLOW, GO ;* JRST ALOGRT ;TO ALOGRT. ;* ERROR (APR,1,1,OUT) ;TYPE AN ERROR MESSAGE ;* ;*ALOGRT: MOVM C,SAVEA ;PICK UP ABS(BASE). ;* FUNCT ALOG., ;CALC. LOG(ABS(A)). ;* MOVEM A,C ;RESULTS TO C. ;*IFE CPU-KI10, ;*IFE CPU-KA10, ;MAKE EXP. A FLOATING ;*> ;* FMPRM A,C ;CALC. B*ALOG(ABS(A)). ;* FUNCT EXP., ;FIND EXP. OF THIS. ;* JRST OUT2 ;GO AND TYPE ERROR MESSAGE. ;* ;*MININF: HRLOI B,377777 ;SET EXP = +INFINITY. ;* PUSHJ P,FEXP2 ;GO TO MAIN ROUTINE. ;* FMPR A,SAVEA ;ANS. = ANS. TIMES A. ;* JFCL OVER ;GO TO OVER IF OVERFLOW. ;* JRST INV ;OTHERWISE, GO TO INV. ;* ;* ;*SAVEA: 0 ;TEMP FOR A. ;*SAVEB: 0 ;TEMP FOR B. ;*SAVEC: 0 ;TEMP FOR C. ;* ;* LIT ;* PRGEND PRGEND TITLE .$SRES STRING RESOLUTIION ENTRY .$SRES, .$RESF EXTERNAL .$SNAL SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 TWOSEG RELOC 400000 ; S -> A.(B).C .$SRES: MOVEM 6,A MOVEM 5,C HRLI 2,331100 HRLI 1,331100 MOVEM 2,S MOVEM 1,B LDB 0,1 LDB 4,2 SUB 4,0 ; LENGTH OF REMAINDER JUMPL FAIL ; PAST THE END MOVNM 4,X ; X = -(LENGTH OF REM) RES0: MOVEM 2,SB RES1: SOJL 0,FOUND ILDB 5,2 ILDB 6,1 CAMN 5,6 JRST RES1 SOJL 4,FAIL MOVE 2,SB IBP 0,2 MOVE 1,B LDB 0,1 JRST RES0 FAIL: SETZ 1,0 MOVE 2,S JRST 0(3) ASS: JUMPN 2,ASS1 JUMPE 4,0(5) JRST FAIL ASS1: HRLI 2,331100 DPB 4,2 ASS2: ILDB 6,1 IDPB 6,2 SOJG 4,ASS2 ;KMF REMOVED SOSGE 4,ASS2 JRST 0(5) FOUND: MOVEM 2,TEMP ADDM 4,X ; X = -(LENGTH OF LHS) MOVEM 4,SB MOVE 1,S HRLI 1,331100 MOVE 2,A MOVN 4,X JSP 5,ASS MOVE 1,TEMP MOVE 2,C MOVE 4,SB JSP 5,ASS SETO 1,0 MOVE 2,S JRST 0(3) .$RESF: PRMERROR 7,0,0,IMPSTR RELOC 0 TEMP: 0 S: 0 SB: 0 A: 0 B: 0 C: 0 X: 0 PRGEND TITLE .$SNAL SIGNAL MECHANISM SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 TWOSEG RELOC 400000 ENTRY .$SNAL ENTRY EVENT, SUBEVE, EVENTI EXTERNAL %PROG,.$HERE EXTERNAL $SIGNAL .$SNAL: MOVEM 6,.EVENT MOVEM 5,.SUBEV MOVEM 4,.EVINF MOVEI 5,1 LSH 5,0(6) FF0: HRRZ 3,3 CAIE 3,.$HERE ;PROC PARAM JRST FF01 ;NO MOVEI 0,TEMPL EXCH 0,1(BASE5) JRST 0(3) ;LET .$PENT RECOVER TEMPL: HRRZ 3,0 ;RESTORE RETN ADDR FF01: MOVEI 4,%PROG FF1: MOVEI 2,1(4) MOVE 1,0(2) CAMG 3,2 JRST FF11 CAMG 3,1 JRST FF12 FF11: SKIPN 4,0(4) JRST FF5 JRST FF1 FF12: MOVEI 6,20 MOVEI 1,1(2) FF2: SOJ 6,0 MOVE 2,1 MOVE 1,0(2) CAMLE 3,1 JRST FF2 ; FIND TRAP MOVEI 1,1(2) FF3: MOVE 2,1 HLRZ 1,0(2) JUMPE 1,FF4 CAMLE 3,1 JRST FF3 HRRZ 1,0(2) CAMG 3,1 JRST FF4 TSNN 5,1(2) JRST FF4 HRRZ 3,1(2) JRST 0(3) FF4: CAIN 6,17 JRST FF41 ; CHEAP PROCEDURE MOVE 17,@6 MOVE 0,1(17) MOVEM 0,@6 FF41: POP 17,3 JRST FF0 ; GIVE UP AND REPORT IT FF5: MOVE 6,.EVENT MOVE 5,.SUBEV MOVE 4,.EVINF JRST $SIGNAL EVENT: MOVE 1,.EVENT POPJ 17, SUBEVE:MOVE 1,.SUBEV POPJ 17, EVENTI:MOVE 1,.EVINF POPJ 17, RELOC 0 .EVENT: 0 .SUBEV: 0 .EVINF: 0 PRGEND TITLE .$PENT PROCEDURE ENTRY ENTRY .$PENT,.$HERE ; PROC PARM ENTRY SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$PENT: MOVEM J,1(2) ; SAVE RETURN ADDR EXCH BASE1,2(2) EXCH BASE2,3(2) EXCH BASE3,4(2) EXCH BASE4,5(2) EXCH BASE5,6(2) PUSHJ P,@0(2) ; ENTER THE PROCEDURE .$HERE: MOVE J,1(BASE5) ; RETURN ADDRESS EXCH BASE1,2(BASE5) EXCH BASE2,3(BASE5) EXCH BASE3,4(BASE5) EXCH BASE4,5(BASE5) EXCH BASE5,6(BASE5) JRST 0(3) ; RETURN TO PROGRAM PRGEND TITLE .$PASS PROCEDURE PARAMETERS ENTRY .$PASS ; PROCEDURE PARAM ASSIGNMENT SEARCH IMPPRM ;AC DEFNS AC==0 T4==1 T1==5 T2==6 T3==7 .$PASS: MOVEM 0,0(2) ; ENTRY POINT MOVEM BASE1,2(2) MOVEM BASE2,3(2) MOVEM BASE3,4(2) MOVEM BASE4,5(2) MOVEM 2,6(2) ; ADDRESS OF VECTOR JRST 0(J) PRGEND TITLE FLOAT SEARCH IMPPRM ENTRY FLOAT FLOAT: HLRE AC,ARG1 HLL ARG1,AC FSC ARG1,233 SKIPGE 0,ARG1 AOSE 0,AC FSC AC,255 FADR AC,ARG1 JRST 0(J) END $$$$$$$$$$$$ &&&&&&&&&&&& MACLIB.MAC TITLE SAVEACS ROUTINE TO SAVE REGISTERS 2-17 ENTRY SAVEACS,RESTORE,SACS TWOSEG 400000 SEARCH IMPPRM ; SAVEACS SAVES REGISTERS 2-17 SAVEACS: MOVEM 17,SACS+17 ;SAVE THE ACS MOVEI 17,SACS ;LOCALLY BLT 17,SACS+16 MOVE 17,SACS+17 ;GET OLD STACK POINTER POPJ 17, ;RETURN SUBTTL RESTORE ROUTINE TO RESTORE PREVIOUS ENVIRONMENT ; RESTORE RESTORES THE PREVIOUS ENVIRONMENT AFTER A CALL TO SAVEACS ; EXCEPT FOR AC'S 0 AND 1, SO THAT RESULTS MAY BE PASSED BACK ; FROM IMP FUNCTIONS AND MAPS. HENCE PREVIOUS CONTENT ; OF ACS 0 AD 1 ARE LOST. RESTORE: MOVE 2,(P) ;GET RETURN ADDRESS HRRZ 3,SACS+17 MOVEM 2,(3) ;AND OVERWRITE WITH PRESENT ONE HRLI 17,SACS+2 HRRI 17,2 BLT 17,17 ;RESTORE POPJ P, ;RETURN RELOC 0 SACS: BLOCK 20 PRGEND TITLE ZERO %SYSTEMROUTINE ZERO(%NAME FROM, TO) ENTRY $ZERO TWOSEG 400000 SEARCH IMPPRM $ZERO: SETZM (ARG1) HRL ARG1,ARG1 AOS ARG1 HLRZ AC,ARG2 LSH AC,-^D9 ;GET LENGTH OF "TO" ITEM SOSGE AC ;SUBTRACT 1 SETZ AC, ;BUT IF AC WAS ZERO MAKE IT 1-1 ADD ARG2,AC BLT ARG1,(ARG2) ;ZERO AREA POPJ P, PRGEND TITLE BLT %SYSTEMROUTINE BLT(%NAME FROM, TO, %INTEGER LEN) ENTRY $BLT TWOSEG 400000 SEARCH IMPPRM $BLT: MOVEI AC,(ARG2) ;"TO" AREA ADDRESS ;; CAIL AC,(ARG1) ;IS IT A BLT OR REVERSE BLT ;; JRST REVBLT ;REVERSE BLT HRL AC,ARG1 ;"FROM" AREA ADDRESS ADDI ARG3,(ARG2) ;FINAL ADDRESS+1 BLT AC,-1(ARG3) ;DO IT POPJ P, ;;REVBLT: SOS ARG3 ;N-1 ;; ADDI ARG3,400000 ;N-1+400000 ;; HRL ARG1,ARG3 ;ARG1=XWD N-1+400000,"FROM" ;; SUBI AC,(ARG1) ;"TO-"FROM" ;; HRRM AC,PNTR ;SET UP POINTER ;; POP ARG1,@PNTR ;; JUMPL ARG1,.-1 ;; POPJ P, ;; ;; RELOC 0 ;;PNTR: (ARG1) PRGEND TITLE IOWD %SYSTEMINTEGERFN IOWD(%INTEGER LEN, %INTEGERNAME LOC) ENTRY $IOWD TWOSEG 400000 SEARCH IMPPRM $IOWD: MOVN AC,ARG1 ;GET -VE LENGTH HRLZ AC,AC ;INTO LH IORI AC,-1(ARG2) ;AND ADDRESS-1 IN RH POPJ P, ;RETURN PRGEND TITLE IOUUO %SYSTEMPREDICATE IOUUO(%INTEGER FN,CHAN, %INTEGERNAME ADDR) ENTRY $IOUUO TWOSEG 400000 SEARCH IMPPRM $IOUUO: SETO AC, MOVE T1,ARG1 LSH T1,33 HRLZ T2,ARG2 LSH T2,5 IOR T1,T2 HRR T1,ARG3 XCT 0,T1 SETZ AC, ;ERROR RETURN POPJ P, PRGEND TITLE GETTAB %SYSTEMPREDICATE GETTAB(%INTEGER TABLE,INDEX %INTEGERNAME RESULT) ENTRY $GETTAB TWOSEG 400000 SEARCH IMPPRM $GETTAB:SETOM AC ;SET %TRUE MOVS T1,ARG2 ;GET INDEX OR JOBNUM HRR T1,ARG1 ;AND TABLE NUMBER GETTAB T1, ;GETTAB SETZM AC ;%FALSE MOVEM T1,(ARG3) ;RETURN RESULT POPJ P, ;RETURN PRGEND TITLE CLOSE %SYSTEMROUTINE CLOSE(%INTEGER CHAN) AND %SYSTEMROUTINE RELEASE(%INTEGER CHAN) ENTRY $CLOSE,$RELEASE TWOSEG 400000 SEARCH IMPPRM $RELEASE: SKIPA T1,[ XWD 071000,000000 ] ;RELEASE OPCODE $CLOSE: HRLZI T1,70000 ;CLOSE OPCODE HRLZ T2,ARG1 ;GET CHANNEL NUMBER LSH T2,5 IOR T1,T2 XCT 0,T1 ;DO IT POPJ P, LIT PRGEND TITLE TMPCOR %SYSTEMROUTINE TMPCOR(%INTEGER TYPE, BLOCK-IOWD, SIXBIT-FILENAME) ENTRY $TMPCOR TWOSEG 400000 SEARCH IMPPRM $TMPCOR: HRL AC,ARG1 ;TYPE SETZM ARG1 ;CLEAR IT HRRI AC,ARG3 ;BLOCK ADDRESS [NAME,,0 ; IOWD BUFLEN,,BUFFER] HLLZ ARG3,ARG3 ;ZAP RH TMPCOR AC, ;DO THE TMPCOR SETZM AC ;FAIL POPJ P, PRGEND TITLE RRUN RUN PROCEDURE CALLED BY IMP RUN ENTRY RRUN TWOSEG 400000 SEARCH IMPPRM ; RRUN RUNS THE PROGRAM SPECIFIED ON THE STACK ; AS CALLED BY %EXTERNALROUTINE RUN(%STRING(6) DEV,FILE,EXT, %INTEGER PPN, OFFSET) RRUN: MOVEM ARG1,ARGLST(P) ; MOVE TOP 3 ARGS ONTO STACK MOVEM ARG2,ARGLST+1(P) MOVEM ARG3,ARGLST+2(P) HRLI AC,ARGLST(P) ; DEV ON THE STACK HRRI AC,144 ; JOBS LOWEST CORE+4 BLT AC,152 ; THE 7 WORD ARGUMENT BLOCK MOVS AC,CODEX ; XWD 140,CODE BLT AC,143 ; MOVE THE CODE DOWN HRL T1,ARGLST+7(P) ; STARTING OFFSET HRRI T1,144 ; STARTING ADDRESS OF SPEC MOVE AC,ONEONE JRST 140 ;GO TO THE CODE CODE: CORE AC,0 ;REDUCE CORE HALT 141 RUN T1,0 ;RUN THE PROGRAM HALT 143 CODEX: XWD 140,CODE ONEONE: XWD 1,1 PRGEND TITLE GGETSEG FOR USE WITH IMP GETSEG ROUTINE ; %EXTERNALROUTINE GETSEG(%STRING(6) DEV,FILE,EXT, %INTEGER PPN) ENTRY GGETSEG TWOSEG 400000 SEARCH IMPPRM GGETSEG: MOVEM ARG1,ARGLST(P) ;PUT TOP 3 ARGS ONTO THE STACK MOVEM ARG2,ARGLST+1(P) MOVEM ARG3,ARGLST+2(P) MOVEM 17,.SAC17 ;SAVE AC17 MOVEI 17,.SAC0 BLT 17,.SAC16 ;SAVE ACS MOVE P,.SAC17 ;RESTORE STACK POINTER HRLI AC,GETS01 HRRI AC,ARGLST+4(P) ;WHERE TO SAVE THE CODE ON THE STACK HRRI T1,ARGLST+4(P) BLT AC,4(T1) ;SAVE CODE IN LOW SEG HRLZI T1,1 HRRZI AC,ARGLST(P) ;ADDRESS OF SPEC LIST JRST ARGLST+4(P) ;JUMP TO CODE GETS01: CORE T1,0 ;KILL HIGH SEG HALT GETSEG AC,0 ;GET NEW SEGMENT HALT JRST ENDBLOCK ENDBLOCK: HRLZI 17,.SAC0 BLT 17,17 ;RESTORE ACS JRST 400010 ;START ADDR RELOC 0 .SAC0: BLOCK ^D14 .SAC16: 0 .SAC17: 0 LIT PRGEND TITLE CHARNO %INTEGERFN CHARNO(%STRINGNAME S, %INTEGER I) ENTRY CHARNO TWOSEG 400000 SEARCH IMPPRM CHARNO: HLRZ AC,(ARG1) LSH AC,-9 ;GET LENGTH SKIPL ARG2 ; %IF I<0 %C CAMGE AC,ARG2 ; %OR I>LENGTH(S) %C JRST CHA001 ; %THEN %RESULT=0 MOVEM ARG2,T1 LSH T1,-2 ;DIVIDE BY FOUR ADD T1,ARG1 ;ADDRESS OF WORD MOVE AC,(T1) ;GET WORD TRNN ARG2,2 ;L OR R HALF HLRZ AC,AC TRNN ARG2,1 ;L OR R QUARTER CHA001: LSH AC,-9 ANDI AC,777 ;MASK OFF BYTE POPJ P, ;RETURN PRGEND TITLE MATCH %INTEGERFN MATCH(%STRINGNAME S,%STRING(255) T) ENTRY MATCH TWOSEG 400000 SEARCH IMPPRM MATCH: MOVE T1,[POINT 9,(ARG1),8] MOVEM T1,SPTR MOVE T1,[POINT 9,(AC),8] ;SECOND STRING ARGUMENT MOVEM T1,TPTR LDB T1,SPTR ;GET LENGTH OF S LDB T2,TPTR JUMPE T2,MATNOK ;FAIL IF T IS NULL MOVN T2,T2 HRLZM T2,TLEN ;SAVE AOBJP POINTER FOR T ILDB T4,TPTR ;POINT TO FIRST CHAR ADD T1,T2 ;LEN1-LEN2 FOR AMMOUNT OF STRING1 TO LOOK AT ADDI T1,2 ;ADJUST FOR ALLIGNMENT MOVN T1,T1 HRLZM T1,MATLEN ;SAVE AOBJP POINTER FOR S MATLP: MOVE T3,MATLEN MATLP1: AOBJP T3,MATNOK ;END OF STRING? ILDB T1,SPTR CAME T1,T4 ;MATCH FIRST CHAR? JRST MATLP1 ;NO ;HERE TO SEE IF REST OF STRING MATCHES MOVEM T3,MATLEN ;SAVE AOBJN POINTER MOVE T1,SPTR MOVEM T1,SPTR1 ;GET LOCAL VERSION OF POINTERS MOVE T1,TPTR MOVEM T1,TPTR1 MOVE T3,TLEN ;AOBJN POINTER MATLP2: AOBJP T3,MATOK ;END OF STRING T? ILDB T1,SPTR1 ILDB T2,TPTR1 CAME T1,T2 JRST MATLP ;MISMATCH FOUND JRST MATLP2 ;SO FAR SO GOOD MATOK: HRRZ AC,MATLEN ;GET CHAR POSITION POPJ P, MATNOK: SETZ AC, POPJ P, RELOC 0 SPTR: Z SPTR1: Z TPTR: Z TPTR1: Z TLEN: Z MATLEN: Z LIT PRGEND TITLE TOSTRING %STRING(1)%FN TO STRING(%INTEGER N) ENTRY TOSTRING TWOSEG 400000 SEARCH IMPPRM TOSTRING: MOVE AC,ARG1 IORI AC,1000 ;ADD LENGTH HRLZM AC,-1(P) ;PUT TO TOP OF WORD ON STACK POPJ P, PRGEND TITLE SUBSTRING %STRING(255)%FN SUB STRING(%STRINGNAME S, %INTEGER I,J) ENTRY SUBSTRING TWOSEG 400000 SEARCH IMPPRM SUBSTRING: JUMPLE ARG2,F2ERR ;%IF 1>=I %THEN ->ERROR HLRZ T1,(ARG1) LSH T1,-9 ;GET LENGTH OF S CAMLE ARG3,T1 ;%IF J>LENGTH(S) %C JRST F3ERR ; CAMLE ARG2,T1 ; %OR I>LENGTH(S) %THEN JRST F2ERR ; ->ERROR SUB ARG3,ARG2 ;GET LENGTH OF NEW STRING ADDI ARG3,1 JUMPL ARG3,FMSERR ; %IF I-1>J %THEN ->ERROR JUMPG ARG3,.+3 SETZM -100(P) ;%IF J=I-1 %THEN %RESULT="" POPJ P, MOVE T2,ARG2 ANDI ARG2,3 LSH T2,-2 ;GET WORD BASE IOR T2,IBYTPTR(ARG2) ;GET APPROPRIATE BYTE POINTER, BYTE ALLINGNED MOVE T1,[POINT 9,-100(P),8] ;POINTER TO RESULT DPB ARG3,T1 ;DEPOSIT NEW LENGTH FMSLP: ILDB AC,T2 IDPB AC,T1 SOJG ARG3,FMSLP ;CONTINUE UNTIL ALL TRANSFERRED POPJ P, FMSERR: SETZ AC, ERROR 5,^D8,AC,IMPSTR F2ERR: MOVE ARG3,ARG2 ;GET ARGUMENT F3ERR: ERROR 5,7,ARG3,IMPSTR RELOC 0 IBYTPTR: POINT 9,(ARG1),-1 POINT 9,(ARG1),8 POINT 9,(ARG1),17 POINT 9,(ARG1),26 LIT PRGEND TITLE STRTOSIX %INTEGERFN STRTOSIX(%STRING(255) STR) ENTRY STRTOSIX TWOSEG 400000 SEARCH IMPPRM STRTOSIX: SETZ T5, ;RESULT INITIALLY TO BE PUT IN T5 MOVE T2,[POINT 6,T5] MOVE T3,[POINT 9,(AC),8] LDB T4,T3 ;LENGTH OF STRING CAILE T4,6 MOVEI T4,6 ;MAX LENGTH SIXL3: SOJL T4,SIXL4 ;FINISHED ILDB T1,T3 CAIL T1,40 CAILE T1,137 JRST SIXL1 SUBI T1,40 SIXL2: IDPB T1,T2 JRST SIXL3 SIXL1: CAIGE T1,140 MOVEI T1,100 SUBI T1,100 JRST SIXL2 SIXL4: MOVEM T5,AC ;RETURN RESULT POPJ P, LIT PRGEND TITLE SIXTOSTR %STRING(6)%FN SIXTOSTR(%INTEGER SIXBIT) ; CONVERT A SIXBIT INTEGER TO A STRING ENTRY SIXTOSTR TWOSEG 400000 SEARCH IMPPRM SIXTOSTR: MOVE T1,[POINT 9,-2(P),8] ;POINT TO RESULT MOVEI T4,^D6 DPB T4,T1 ;DEPOSIT LENGTH OF 6 ALWAYS MOVE T3,ARG1 ;GET THE SIXBIT ARGUMENT SIX2LP: LSHC T2,6 ;COMBINED SHIFT INTO BOTTOM OF T2 ANDI T2,77 ;MASK OFF CHARACTER ADDI T2," " ;CONVERT TO ASCII IDPB T2,T1 ;DEPOSIT AS NINE-BIT SOJG T4,SIX2LP ;CONTINUE FOR WHOLE WORD POPJ P, LIT PRGEND TITLE ASCTOSTR %STRING(255)%FN ASCTOSTR(%NAME ADR) SEARCH IMPPRM ENTRY ASCTOSTR ASCTOSTR:HRLI T1,440700 HRR T1,ARG1 ;[POINT 7,@ARG1] MOVE T2,[POINT 9,-100(P),8] ;**[POINT 9,IS,8] SETZ T3, LOOP: ILDB AC,T1 JUMPE AC,END CAIE AC,15 ;DO NOT INSERT IDPB AC,T2 AOJA T3,LOOP END: DPB T3,[POINT 9,-100(P),8] ;**[POINT 9,IS,8] MOVEI AC1,IS POPJ P, IS: BLOCK 64 LIT PRGEND TITLE STRTOASC %ROUTINE STRTOASC(%STRINGNAME S,%NAME ADR) SEARCH IMPPRM ENTRY STRTOASC STRTOASC: SETZM (ARG2) ;ZERO FIRST WORD LDB T1,[POINT 9,@ARG1,8] ;GET LENGTH JUMPE T1,END ;LENGTH ZERO IDIVI T1,5 ;GET NUMBER OF ASCII WORDS TO INITIALISE TO ZERO JUMPE T1,STOA1 ;LENGTH LESS THAN 5 HRR T2,ARG2 HRL T2,ARG2 AOS T2 HRRZ T3,ARG2 ADDI T3,T1 BLT T2,(T3) ;ZERO THE AREA STOA1: HRLI T1,331100 HRR T1,ARG1 ;[POINT 9,@ARG1,8] HRLI T2,440700 HRR T2,ARG2 ;[POINT 7,@ARG2] LDB T3,T1 ;GET LENGTH JUMPE T3,END LOOP: ILDB AC,T1 CAIN AC,12 JRST [MOVEI AC,15 IDPB AC,T2 ;INSERT MOVEI AC,12 JRST .+1] IDPB AC,T2 SOJG T3,LOOP END: POPJ P, LIT PRGEND TITLE BINTOSTR %STRING(36)%FN BINTOSTR(%INTEGER BINNUM) ; CONVERT A BINARY INTEGER TO A STRING ENTRY BINTOSTR TWOSEG 400000 SEARCH IMPPRM BINTOSTR: MOVE T1,[POINT 9,-12(P),8] ;POINT TO RESULT MOVEI T4,^D36 DPB T4,T1 ;DEPOSIT LENGTH OF 36 ALWAYS MOVE T3,ARG1 ;GET THE BINARY ARGUMENT SIX2LP: LSHC T2,1 ;COMBINED SHIFT INTO BOTTOM OF T2 ANDI T2,1 ;MASK OFF CHARACTER ADDI T2,"0" ;CONVERT TO ASCII IDPB T2,T1 ;DEPOSIT AS NINE-BIT SOJG T4,SIX2LP ;CONTINUE FOR WHOLE WORD POPJ P, LIT PRGEND TITLE HEXTOSTR %STRING(9)%FN HEXTOSTR(%INTEGER HEXNUM) ; CONVERTS AN HEX NUMBER INTO A STRING ENTRY HEXTOSTR TWOSEG 400000 SEARCH IMPPRM HEXTOSTR: SKIPE T3,ARG1 ;IS IT A ZERO? JRST HEX2L0 ;NO MOVSI AC,1060 ;YES, STRING "0" MOVEM AC,-3(P) ;RETURN IT POPJ P, HEX2L0: MOVE T1,[POINT 9,-3(P),8] ;POINT TO RESULT MOVEI T4,^D9 ;GET MAX LENGTH HEX2L1: ROTC T2,4 ;SHIFT INTO BOTTOM OF T2 TRNN T2,17 ;SEE IF ANY BITS SET SOJG T4,HEX2L1 ;CONTINUE IF A ZERO DPB T4,T1 ;OTHERWISE DEPOSIT LENGTH SKIPA HEX2LP: ROTC T2,4 ANDI T2,17 ;MASK OFF CHARACTER ADDI T2,"0" ;CONVERT TO ASCII CAILE T2,"9" ;IS IT GREATER THAN 9 ADDI T2,7 ;IF SO MAKE 'A'-'F' IDPB T2,T1 ;DEPOSIT AS NINE-BIT SOJG T4,HEX2LP ;CONTINUE FOR WHOLE WORD POPJ P, LIT PRGEND TITLE OCTTOSTR %STRING(12)%FN OCTTOSTR(%INTEGER OCTNUM) ; CONVERTS AN OCTAL NUMBER INTO A STRING ENTRY OCTTOSTR TWOSEG 400000 SEARCH IMPPRM OCTTOSTR: SKIPE T3,ARG1 ;IS IT A ZERO? JRST OCT2L0 ;NO MOVSI AC,1060 ;YES, STRING "0" MOVEM AC,-4(P) ;RETURN IT POPJ P, OCT2L0: MOVE T1,[POINT 9,-4(P),8] ;POINT TO RESULT MOVEI T4,^D12 ;GET MAX LENGTH OCT2L1: ROTC T2,3 ;SHIFT INTO BOTTOM OF T2 TRNN T2,7 ;SEE IF ANY BITS SET SOJG T4,OCT2L1 ;CONTINUE IF A ZERO DPB T4,T1 ;OTHERWISE DEPOSIT LENGTH SKIPA OCT2LP: ROTC T2,3 ANDI T2,7 ;MASK OFF CHARACTER ADDI T2,"0" ;CONVERT TO ASCII IDPB T2,T1 ;DEPOSIT AS NINE-BIT SOJG T4,OCT2LP ;CONTINUE FOR WHOLE WORD POPJ P, LIT PRGEND TITLE INTTOSTR %STRING(12)%FN INTTOSTR(%INTEGER DECNUM) ; CONVERTS A DECIMAL NUMBER TO A STRING, WITH NO LEADING SPACES ENTRY INTTOSTR TWOSEG 400000 SEARCH IMPPRM INTTOSTR: MOVMM ARG1,T1 ;GET NUMBER MOVEM P,T3 ;SAVE STACK POINTER MOVEI T4,1 ;START COUNT I2SLP0: IDIVI T1,^D10 ADDI T2,"0" ;MAKE ASCII PUSH P,T2 ;SAVE ON STACK SKIPE T1 ;FINISH WHEN 0 AOJA T4,I2SLP0 ;OTHERWISE CONTINUE JUMPGE ARG1,I2SL1 ;IF POSITIVE CONTINUE MOVEI T2,"-" PUSH P,T2 ;ELSE OUTPUT A - SIGN AOS T4 ;NOW FILL THE STRING I2SL1: MOVE T2,[POINT 9,-4(T3),8];POINT TO STRING ON STACK DPB T4,T2 ;PUT IN LENGTH I2SLP1: POP P,T1 ;GET CHAR IDPB T1,T2 ;STORE IT SOJG T4,I2SLP1 ;CONTINUE POPJ P, LIT PRGEND TITLE CALLIS %EXTERNALROUTINE CALLI1(%INTEGER NUM, %INTEERNAME AC) ENTRY CALLI1,CALLI2,CALLI3 TWOSEG 400000 SEARCH IMPPRM ; %EXTERNALROUTINE CALLI 1(%INTEGER NUM, %INTEGERNAME AC) - FOR SIMPLE RETURN CALLIS ; %EXTERNALPREDICATE CALLI 2(%INTEGER NUM,%INTERNAME AC) - FOR ; NON-SKIP ERROR RETURNS AND SKIP NORMAL RETURNS ; %EXTERNALPREDICATE CALLI 3(%INTEGER NUM,%INTEGERNAME AC) - FOR ; UNCOMMON NON-SKIP NORMAL RETURNS AND SKIP ERROR RETURNS CALLI1: CALLI2: MOVE T1,@ARG2 ;GET AC CONTENTS HRLZI T2,<47000+T1*40> ;CREATE LH OF INSTRUCTION HRRI T2,(ARG1) ;AND RH XCT T2 ;DO IT TDZA AC,AC ;CLEAR AC AND SKIP SETO AC, ;OR SET THE AC MOVEM T1,@ARG2 ;RETURN ANY VALUE POPJ P, CALLI3: PUSHJ P,CALLI2 ;SAME AS CALLI2 SETCA AC, ;EXCEPT CONDITION IS REVERSED POPJ P, PRGEND TITLE JOBNUM %EXTERNALINTEGERFN JOBNUM ENTRY JOBNUM TWOSEG 400000 SEARCH IMPPRM JOBNUM: PJOB AC, POPJ P, PRGEND TITLE PPN %EXTERNALINTEGERFN PPN ENTRY PPN TWOSEG 400000 SEARCH IMPPRM PPN: GETPPN AC, JUMP POPJ P, PRGEND TITLE GETNOW %EXTERNALINTEGERFN GETNOW ENTRY GETNOW TWOSEG 400000 SEARCH IMPPRM SEARCH UUOSYM GETNOW: MOVE AC,[%CNDTM] GETTAB AC, ;GET ENTRY FROM TABLE SETZ AC, POPJ P, LIT PRGEND TITLE GETDATE %EXTERNALINTEGERFN GETDATE ENTRY GETDATE TWOSEG 400000 SEARCH IMPPRM GETDATE: DATE AC, POPJ P, PRGEND TITLE CPUTIME %EXTERNALINTEGERFN CPUTIME ENTRY CPUTIME TWOSEG 400000 SEARCH IMPPRM CPUTIME: SETZ AC, ;SPECIFY THIS JOB RUNTIM AC, ;GET RUN TIME IN MILLISECS POPJ P, PRGEND TITLE GETTIME %EXTERNALINTEGERFN GETTIME ENTRY GETTIME TWOSEG 400000 SEARCH IMPPRM GETTIME: MSTIME AC, ;GET TIME SINCE MIDNIGHT IN MILLISECS POPJ P, PRGEND TITLE SLEEP %EXTERNALROUTINE SLEEP(%INTEGER I) ENTRY SLEEP TWOSEG 400000 SEARCH IMPPRM SLEEP: HRRE ARG1,ARG1 ;GET ONLY TIME SKIPG ARG1 ;IS IT > 0 POPJ P, ;NO, RETURN HIBER ARG1, ;YES, HIBERNATE SKIPA ;NOT IMPLEMENTED POPJ P, ;OK HRRZ AC,ARG1 ;GET ONLY RH ADDI AC,^D500 ;ROUND UP IDIVI AC,^D1000 ;GET SECS CALLI AC,31 ;SLEEP POPJ P, PRGEND SUBTTL TELETYPE ROUTINES TITLE ECHO %EXTERNALROUTINE ECHO ENTRY ECHO TWOSEG 400000 SEARCH IMPPRM ECHO: SETOM AC ;FOR THIS LINE GETLCH AC TLZ AC,4 SETLCH AC POPJ P, PRGEND TITLE NOECHO %EXTERNALROUTINE NOECHO ENTRY NOECHO TWOSEG 400000 SEARCH IMPPRM NOECHO: SETOM AC ;FOR THIS LINE GETLCH AC TLO AC,4 SETLCH AC POPJ P, PRGEND TITLE SETSTS %SYSTEMROUTINE SETSTS(%INTEGER CHAN,BITS) ENTRY $SETSTS SEARCH IMPPRM $SETSTS: LSH ARG1,5 ;CHAN IORI ARG1,060000 ;SETSTS HRRZ AC,ARG2 ;GET BITS IN RH HRL AC,ARG1 ;AND SETSTS CHAN, IN LH XCT AC ;DO IT POPJ P, ;RETURN PRGEND TITLE GETSTS %SYSTEMINTEGERFN GETSTS(%INTEGER CHAN) ENTRY INSTATUS,OUTSTATUS ENTRY $GETSTS EXTERN INSCB,OUTSCB SEARCH IMPPRM INSTATUS: SKIPA IOREG,INSCB OUTSTATUS: MOVE IOREG,OUTSCB SETZ AC, SKIPL T2,DEVTYP(IOREG) ;IF NUL: OR TMP: CAIN T2,3 ;OR TTY: POPJ P, ;RETURN 0 HLRZ ARG1,FILOPFN(IOREG) ANDI ARG1,17 $GETSTS: LSH ARG1,5 ;CHAN IORI ARG1,062000 ;GETSTS HRLZ ARG2,ARG1 ;IN LH HRRI ARG2,AC ;ADDR OF %RESULT IN RH XCT ARG2 ;DO IT POPJ P, ;RETURN PRGEND TITLE SHIFTC %INTEGERFN SHIFTC(%INTEGER N) ENTRY SHIFTC TWOSEG 400000 SEARCH IMPPRM SHIFTC: MOVEM ARG1,AC ROT AC,ARG2 POPJ P, PRGEND TITLE FRACPT %LONGREALFN FRACPT(%LONGREAL X) ENTRY FRACPT EXTERN INTPT TWOSEG 400000 SEARCH IMPPRM FRACPT: MOVE AC,LARG1 ;SAVE X FIX T2,AC ;MAKE INTEGER SKIPN T2 ;IF INT PT=0 POPJ P, ;THEN RETURN ORIGINAL NUMBER FLTR T2,T2 ;MAKE FLOATING AGAIN FSBR AC,T2 ;TAKE AWAY FROM NUMBER YOU FIRST THOUGHT OF SKIPGE AC FADR AC,[EXP 1.0] ;ADD 1 IF NEGATIVE TO MAKE POSITIVE POPJ P, ;THEN RETURN PRGEND TITLE INTPT %INTEGERFN INTPT(%LONGREAL R) ENTRY INTPT TWOSEG 400000 SEARCH IMPPRM INTPT: SETZM LARG1+1 ;**TEMP** ZAP LOW PART HLRE T1,LARG1 ;GET THE EXPONENT ASH T1,-9 ;RIGHT 8 BITS JUMPGE LARG1,INT.T ;JUMP IF POS. DFN LARG1,LARG1+1 ;NEGATE TRC T1,-1 ;COMPLEMENT THE EXPONENT INT.T: TLZ LARG1,777000 ;CLEAR THE EXPONENT IFE CPU-KA10,< LSH LARG1+1,8 ;WIPE OUT THE LOW ORDER EXPONENT > ASHC LARG1,-201-^D26(T1) ;CHANGE FRACTION TO INTEGER MOVEM LARG1,AC ;PUT RESULT IN AC SKIPL T1 ;SKIP IF NEG. POPJ P, ;IF POSITIVE, RETURN MOVNS AC ;NEGATE SKIPE LARG1+1 ;WAS NUMBER AN INTEGER? SOS AC ;NO, SO TAKE LOWER INTEGER POPJ P, ;RETURN AC=FIXED NUMBER PRGEND TITLE INT %INTEGERFN INT(%LONGREAL R) ENTRY INT TWOSEG 400000 SEARCH IMPPRM INT: SETZM LARG1+1 ;**TEMP** ZAP LOW END JUMPGE LARG1,INT.1 ;JUMP IF POS. DFSB LARG1,[EXP 0.5,0]; SUBTRACT 0.5 SKIPA INT.1: DFAD LARG1,[EXP 0.5,0]; ADD 0.5 HLRE AC,LARG1 ;GET THE EXPONENT ASH AC,-9 ;RIGHT 8 BITS JUMPGE LARG1,INT.T ;JUMP IF POS. DFN LARG1,LARG1+1 ;NEGATE TRC AC,-1 ;COMPLEMENT THE EXPONENT INT.T: TLZ LARG1,777000 ;CLEAR THE EXPONENT IFE CPU-KA10,< LSH LARG1+1,8 ;WIPE OUT THE LOW ORDER EXPONENT > ASHC LARG1,-201-^D26(AC) ;CHANGE FRACTION TO INTEGER SKIPGE AC ;SKIP IF POS. MOVNS LARG1 ;NEGATE MOVEM LARG1,AC POPJ P, ;RETURN AC=FIXED NUMBER LIT PRGEND TITLE IMOD %INTEGERFN IMOD(%INTEGER N) ENTRY IMOD TWOSEG 400000 SEARCH IMPPRM IMOD: MOVMM ARG1,AC POPJ P, PRGEND TITLE MOD %LONGREALFN MOD(%LONGREAL R) ENTRY MOD TWOSEG 400000 SEARCH IMPPRM MOD: MOVMM ARG1,AC ;SINGLE PREC POPJ P, ; =**TEMP** JUMPL ARG1,.+3 DMOVE AC,ARG1 POPJ P, DMOVN AC,ARG1 POPJ P, PRGEND TITLE FROMUDT %EXTERNALROUTINE FROMUDT(%INTEGER UDT,%INTEGERNAME DATE,TIME) ENTRY FROMUDT TWOSEG 400000 SEARCH IMPPRM SEARCH UUOSYM ;ADDITIONAL DEFNS AC1==AC+1 ;FROMUDT -- SUBROUTINE TO CONVERT FROM INTERNAL DATE/TIME FORMAT ; ; ; RETURN WITH TIME=TIME IN MS., DATE=DATE IN SYSTEM FORMAT (.LT. 0 IF ARG .LT. 0) ;BASED ON IDEAS BY JOHN BARNABY, DAVID ROSENBERG, PETER CONKLIN ;USES T1-4 ;ACTS AS A MEMO FUNCTION AND RETURNS PREVIOUS RESULTS IF GIVEN SAME ARGUMENT FROMUDT:MOVEM ARG1,ARGLST(P) ;SAVE ARGS FOR LATER MOVEM ARG2,ARGLST+1(P) MOVEM ARG3,ARGLST+2(P) JUMPL ARG1,CNTDT6 ;DEFEND AGAINST JUNK INPUT CAMN ARG1,CNTUDT ;IS IT SAME ARGUMENT AS LAST TIME JRST CNTMEM ;YES, GIVE SAME RESULTS HLRZ T1,ARG1 ;GET DATE PORTION (DAYS SINCE 1858) RADIX 10 ;**** NOTE WELL **** ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17 ;T1=DAYS SINCE JAN 1, 1501 [311] IDIVI T1,400*365+400/4-400/100+400/400 ;SPLIT INTO QUADRACENTURY [311] LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS [311] IDIVI T2,<100*365+100/4-100/100>*4+400/400 ;SPLIT INTO CENTURY [311] IORI T3,3 ;DISCARD FRACTIONS OF DAY [311] IDIVI T3,4*365+1 ;SEPARATE INTO YEARS [311] LSH T4,-2 ;T4=NO DAYS THIS YEAR [311] LSH T1,2 ;T1=4*NO QUADRACENTURIES [311] ADD T1,T2 ;T1=NO CENTURIES [311] IMULI T1,100 ;T1=100*NO CENTURIES [311] ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR [311] MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR TRNE T2,3 ;IS THE YEAR A MULT OF 4? [311] JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR [311] IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100 [311] SKIPN T3 ;IF NOT, THEN LEAP [311] TRNN T2,3 ;IS YEAR MULT OF 400? [311] TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL [311] CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG [311] ;T3 IS 0 IF LEAP YEAR ;UNDER RADIX 10 **** NOTE WELL **** CNTDT1: SUBI T1,1964 ;SET TO SYSTEM ORIGIN IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29 JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER SOS T4 ;YES--BACK OFF ONE DAY CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH JRST CNTDT4 ;YES--GO FINISH UP ADDI T1,31 ;NO--COUNT SYSTEM MONTH AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT CNTDT6: EXCH T1,ARGLST(P) ;SAVE ANSWER, GET TIME TLZ T1,-1 ;CLEAR DATE MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC. ASHC T1,17 ;POSITION RESULT MOVE T2,ARGLST(P) ;RECOVER DATE MOVEM T1,CNTTIM ;REMEMBER TIME MOVEM T2,CNTDAT ;REMEMBER DATE CNTRTN: MOVEM T2,@ARGLST+1(P) ;RETURN VALUES (DATE) MOVEM T1,@ARGLST+2(P) ;AND TIME POPJ P, ;RETURN CNTMEM: MOVE T1,CNTTIM ;GET LAST TIME MOVE T2,CNTDAT ;AND DATE JRST CNTRTN ;AND RETURN THEM ;UNDER RADIX 10 **** NOTE WELL **** MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365 RELOC 0 ;MEMORY OF ARGUMENT AND RESULTS CNTUDT: Z CNTDAT: Z CNTTIM: Z LIT PRGEND TITLE TOUDT %EXTERNALINTEGERFNSPEC TOUDT(%INTEGER DATE,TIME) ENTRY TOUDT TWOSEG 400000 SEARCH IMPPRM SEARCH UUOSYM AC1==AC+1 ;TOUDT -- CONVERT ARBITRARY DATE TO SPECIAL FORMAT ; ; WHERE TIME=TIME IN MILLISEC. ;AND DATE=DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64 ;RETURNS WITH RESULT IN AC (.GT.0; OR -1 IF BEYOND SEPT. 27,2217) ; NOTE THAT IN SPECIAL FORMAT, THE LEFT HALF DIVIDED ; BY 7 GIVES THE DAY OF THE WEEK (0=WED.) ;USES T2, T3, T4 ;ALSO ACTS AS A MEMO FUNCTION BY REMEMBERING LAST ARGUMENTS TOUDT: CAIN ARG1,CNVDAT ;IS DATE SAME CAIE ARG2,CNVTIM ;AND IF SO IS TIME THE SAME SKIPA T2,ARG1 ;NO, JUST GET DATE JRST CNVMEM ;YES, GET MEMORY MOVEM ARG2,ARGLST+1(P) ;SAVE TIME FOR LATER MOVEM ARG1,CNVDAT ;REMEMBER DATE MOVEM ARG2,CNVTIM ;AND TIME RADIX 10 ;**** NOTE WELL ****** IDIVI T2,12*31 ;T2=YEARS-1964 CAILE T2,2217-1964 ;SEE IF BEYOND 2217 JRST GETNW2 ;YES--RETURN -1 IDIVI T3,31 ;T3=MONTHS-JAN, T4=DAYS-1 ADD T4,MONTAB(T3) ;T4=DAYS-JAN 1 MOVEI T5,0 ;LEAP YEAR ADDITIVE IF JAN, FEB CAIL T3,2 ;CHECK MONTH MOVEI T5,1 ;ADDITIVE IF MAR-DEC MOVE T1,T2 ;SAVE YEARS FOR REUSE ADDI T2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED IDIVI T2,4 ;HANDLE REGULAR LEAP YEARS CAIE T3,3 ;SEE IF THIS IS LEAP YEAR MOVEI T5,0 ;NO--WIPE OUT ADDITIVE ADDI T4,<1964-1859>*365+<1964-1859>/4+<31-18>+31(T2) ;T4=DAYS BEFORE JAN 1,1964 +SINCE JAN 1 ; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64 MOVE T2,T1 ;RESTORE YEARS SINCE 1964 IMULI T2,365 ;DAYS SINCE 1964 ADD T4,T2 ;T4=DAYS EXCEPT FOR 100 YR. FUDGE HRREI T2,64-100-1(T1) ;T2=YEARS SINCE 2001 JUMPLE T2,GETNW1 ;ALL DONE IF NOT YET 2001 IDIVI T2,100 ;GET CENTURIES SINCE 2001 SUB T4,T2 ;ALLOW FOR LOST LEAP YEARS CAIE T3,99 ;SEE IF THIS IS A LOST L.Y. GETNW1: ADD T4,T5 ;ALLOW FOR LEAP YEAR THIS YEAR CAILE T4,^O377777 ;SEE IF TOO BIG GETNW2: SETOM T4 ;YES--SET -1 MOVE AC,ARGLST+1(P) ;GET MILLISEC TIME MOVEI AC1,0 ;CLEAR OTHER HALF ASHC AC,-17 ;POSITION DIV AC,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS HRL AC,T4 ;INCLUDE DATE MOVEM AC,CNVUDT ;REMEMBER DATE/TIME GETNWX: POPJ P, ;RETURN CNVMEM: MOVE AC,CNVUDT ;GET REMEMBERED DATE/TIME POPJ P, ;RETURN ;UNDER RADIX 10 **** NOTE WELL **** MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365 RELOC 0 ;MEMORY CNVUDT: Z CNVDAT: Z CNVTIM: Z LIT PRGEND TITLE %GO IS A DEFAULT VALUE FOR AN IMP PROGRAM WHICH IS LOADED ENTRY %GO,%PROG TWOSEG 400000 %GO: OUTSTR [ASCIZ/?IMP: No main program loaded /] EXIT LIT %PROG: Z EXP 400000000000 ;MINUS INFINITY .LNKEND 1,%PROG PRGEND TITLE STACKSIZE IS THE DEFAULT SIZE FOR THE DATA STACK ENTRY STACKSIZE SEARCH IMPPRM STACKSIZE: -1 PRGEND TITLE HEAPSIZE IS THE DEFAULT SIZE FOR HEAP ENTRY HEAPSIZE SEARCH IMPPRM HEAPSIZE: -1 PRGEND TITLE HEAP DEFAULT HEAP ENTRY HEAP HEAP=-1 PRGEND TITLE STACK DEFAULT STACK ENTRY STACK STACK=-1 END $$$$$$$$$$$$ &&&&&&&&&&&& IMPFOR.MAC TITLE FORTRAN CALLING ROUTINES SEARCH IMPPRM ENTRY CALL0,CALL1,CALL2,CALL3,CALL4,CALL5,CALL6,CALL7,CALL8,CALL9 ENTRY ICALL0,ICALL1,ICALL2,ICALL3,ICALL4,ICALL5,ICALL6,ICALL7,ICALL8,ICALL9 ENTRY RCALL0,RCALL1,RCALL2,RCALL3,RCALL4,RCALL5,RCALL6,RCALL7,RCALL8,RCALL9 CALL9: ICALL9: RCALL9: MOVSI T2,-^D9 JRST .C9 CALL8: ICALL8: RCALL8: MOVSI T2,-^D8 JRST .C8 CALL7: ICALL7: RCALL7: MOVSI T2,-7 JRST .C7 CALL6: ICALL6: RCALL6: MOVSI T2,-6 JRST .C6 CALL5: ICALL5: RCALL5: MOVSI T2,-5 JRST .C5 CALL4: ICALL4: RCALL4: MOVSI T2,-4 JRST .C4 CALL3: ICALL3: RCALL3: MOVSI T2,-3 JRST .C3 CALL2: ICALL2: RCALL2: MOVSI T2,-2 JRST .C2 CALL1: ICALL1: RCALL1: MOVSI T2,-1 JRST .C1 CALL0: ICALL0: RCALL0: SETZB T2,FARGS JRST .C0 .C9: MOVEI T1,@ARGLST+^D9(P) MOVEM T1,FARGS+^D8 .C8: MOVEI T1,@ARGLST+^D8(P) MOVEM T1,FARGS+7 .C7: MOVEI T1,@ARGLST+7(P) MOVEM T1,FARGS+6 .C6: MOVEI T1,@ARGLST+6(P) MOVEM T1,FARGS+5 .C5: MOVEI T1,@ARGLST+5(P) MOVEM T1,FARGS+4 .C4: MOVEI T1,@ARGLST+4(P) MOVEM T1,FARGS+3 .C3: MOVEI T1,@ARGLST+3(P) MOVEM T1,FARGS+2 .C2: MOVEI T1,(ARG3) MOVEM T1,FARGS+1 .C1: MOVEI T1,(ARG2) MOVEM T1,FARGS .C0: MOVEM ARG1,ARGLST(P) MOVEM T2,FARGN MOVEM BASE1,B1SAV MOVEM BASE2,B2SAV MOVEM BASE3,B3SAV MOVEM BASE4,B4SAV MOVEM BASE5,B5SAV MOVEI 16,FARGS PUSHJ P,@ARGLST(P) MOVE AC,0 ;GET RESULT FROM FUNCTION MOVE BASE1,B1SAV MOVE BASE2,B2SAV MOVE BASE3,B3SAV MOVE BASE4,B4SAV MOVE BASE5,B5SAV POPJ P, ;RETURN TO CALLER B1SAV: Z B2SAV: Z B3SAV: Z B4SAV: Z B5SAV: Z FARGN: Z FARGS: BLOCK ^D9 PRGEND TITLE INITFOR DO A RESET. TO FOROTS ; %SYSTEMROUTINE INITFOR ; CAUSES FOROTS TO BE LOADED AND INITIALISES IT .REQUEST SYS:FORLIB.REL EXTERN %%TRAP,RESET. ENTRY $INITFOR SEARCH IMPPRM,C $INITFOR:MOVEM P,SAVP ;SAVE IMP STACK POINTER MOVEM BASE1,SAVB1 ;AND CURRENT BASE REG. TOP LEVEL JSP 16,RESET. EXP 0 ;ARG TO FOROTS MOVEI AC1,%%TRAP MOVEM AC1,.JBAPR ;OVERWRITE FOROTS ERROR TRAPPING MOVEI AC1,AP.REN!AP.POV!AP.ILM!AP.FOV!AP.AOV ; SET CONDITIONS APRENB AC1, ;SET IT MOVE BASE1,SAVB1 ;RESTORE CURRENT BASE REGISTER MOVE P,SAVP POPJ P, SAVP: Z SAVB1: Z END $$$$$$$$$$$$ &&&&&&&&&&&& JSYS.MAC TITLE JSYS4 DEC-20 MONITOR CALL ENTRY JSYS4 EXTERN JSYS0 SEARCH IMPPRM JSYS4: MOVEM ARG3,ARGLST+2(P) MOVE 4,@ARGLST+4(P) MOVE 3,@ARGLST+3(P) MOVE 2,@ARGLST+2(P) MOVE 1,@ARG2 PUSHJ P,JSYS0 MOVEM 1,@ARG2 MOVEM 2,@ARGLST+2(P) MOVEM 3,@ARGLST+3(P) MOVEM 4,@ARGLST+4(P) POPJ P, PRGEND TITLE JSYS3 DEC-20 MONITOR CALL ENTRY JSYS3 EXTERN JSYS0 SEARCH IMPPRM JSYS3: MOVE 3,@ARGLST+3(P) MOVE 2,@ARG3 MOVE 1,@ARG2 PUSHJ P,JSYS0 MOVEM 1,@ARG2 MOVEM 2,@ARG3 MOVEM 3,@ARGLST+3(P) POPJ P, PRGEND TITLE JSYS2 DEC-20 MONITOR CALL ENTRY JSYS2 EXTERN JSYS0 SEARCH IMPPRM JSYS2: MOVE 2,@ARG3 MOVE 1,@ARG2 PUSHJ P,JSYS0 MOVEM 1,@ARG2 MOVEM 2,@ARG3 POPJ P, PRGEND TITLE JSYS1 DEC-20 MONITOR CALL ENTRY JSYS1 EXTERN JSYS0 SEARCH IMPPRM JSYS1: MOVE 1,@ARG2 PUSHJ P,JSYS0 MOVEM 1,@ARG2 POPJ P, PRGEND TITLE JSYS DEC-20 MONITOR CALL ENTRY JSYS0 SEARCH IMPPRM JSYS0: HRLZI 0,104000 HRR 0,ARG1 XCT 0 JUMPA 16,JSYSER POPJ P, JSYSER: ERROR ^D11,0,ARG1,IMPSTR END $$$$$$$$$$$$