IFNDEF NOCODE, ;NOCODE=1 : JUST DEFINE SYMBOLS FOR ;GETSEG SEGMENTS IFE NOCODE,< TITLE BASIC-PLUS V-1 IMPURE SECTION 4-JUL-79 > IFN NOCODE,< UNIVERSAL BSYICL > SUBTTL IMPURE AREA ;***COPYRIGHT 1969, 1970, 1971, 1972, 1973,1974, DIGITAL EQUIPMENT CORP., MAYNARD, MASS.*** ;ALPHABETICAL LIST OF INTERNALS. INTERN LCRFNH,GOSBFL,TTYCRF,OUCRFF,CRFERR INTERN ACTBL,AFLAG,APBMAX,APPLST,APPMAX,ARAROL,ARATOP,ARGROL INTERN BA,BADGNN,BATCH,BGNTIM,BLOCK INTERN CATFL1,CATCNT,CATLOK INTERN C3,CADROL,CATFLG,CEIL,CHAFL2,CHAFLG,CLOSED,CMDROL,CODROL,COMTIM INTERN COMTOP,CONROL,COPFLG,CORINC,CURBAS,CURDEV,CUREXT,CURLIN,CURNAM INTERN CRTVAL INTERN DATAFF,DATLIN,DECROL,DETER,DEVBAS,DEVICE,DREL,DRMBUF,DSKSYS INTERN ELETOP,ENT,ENTDSK,EOFFLG,ERR,ERL,ERRGO,ERRTRO,ES2,EX1 INTERN ELECT1,ELECT2,ELECT3,EXTD,EXTFG INTERN FADROL,FCLROL,FCNLNK,FCNROL,FILCNT,FILD,FILD1,FILDIR INTERN FILFLG,FILNM,FILTYP,FIRSFL,FLOAT,FLOOR,FMTPNT,FORROL INTERN FPPN,FRSTLN,FUNAME,FUNLOW,FUNSTA INTERN GSBROL,GTSTS INTERN HEDFLG,HPOS INTERN IBDSK,IBDSK2,IBF,IFFLAG,IFIFG,IFNFLG,INDSK INTERN ININI1,INITO,INNDSK,INPFLA,INPRES,INVFLG,INVLRG INTERN LADROL,LASREC,LASTLN,LEAD,LETSW,LIBFLG,LINB0,LINNUM INTERN LINROL,LITROL,LOCLOF,LOK,LOKUP,LOWEST,LOWSTA,LZ INTERN MARGIN,MARWAI,MASAPP,MASMAX,MIDSAV,MINFLG,MODBLK,MONLVL,MTIME INTERN MIXFLG INTERN NEWOL1,NUMAPP,NUMCOT,NUMMSP,NUMRES,NXTROL,NEGONE,NOBFLG INTERN OBF,OBDSK,OBDSK2,ODF,OLDFLA,ONCESW,OUTDSK,OUTTDS INTERN PAGCNT,PAGLIM,PAKFLA,PAKFLG,PARAM,PINPNM,PINPUT INTERN PIVOT,PLIST,POINT,PSAV,PREAD,PROTEC,PSHPNT,PSHROL,PTMROL INTERN PTHBLK,QUERYF,QLIST,QLSPEC,QUOFL1,QUOFLG,QUOTBL,RENDON INTERN RANCNT,RANTST,REAINP,REATMP,REFROL,REGPNT,RELROL,RENAMD,RENFLA INTERN RENSW,RETUR1,REVFL,RNDDAT,RNDIDX,ROLMSK,ROLTOP,RUNFLA,RUNLIN INTERN SADROL,SAVE1,SAVI,SB1M1,SB2M1,SCAROL,SEQPNT,SEXROL,SJOBRL INTERN SJOBSA,SLTROL,SORCLN,SPEC,SRTDBA,STADSK,STARFL,STAROL,STMROL INTERN STODSK,STOTRP,STQDSK,STRCTR,STRFCN,STRLEN,STRPTR INTERN STWDSK,SVRBOT,SVRROL,SVRTOP,SWAPSS,SX INTERN TABFG,TABLE,TABVAL,TEMLOC,TEMP1,TEMP2,TEMP3,TMPLOW,TMPPNT INTERN TMPROL,TOPSTG,TRAIL,TRNFL2,TRNFLG,TRPLOC,TTYBUF,TTYPAG INTERN TXTROL,TYI,TYO,TTYIN,TYPE,FTYPE,PFLAG,INLNFG INTERN UFD,USETID,USETOD,USGFLG,UUOH,UXFLAG INTERN VALPTR,VARFRE,VARROL,VECT1,VECT2,VPAKFL,VRFBTB,VRFBOT INTERN VRFSET,VRFTOP,VSPROL,VIRSIZ,VIRDIM,VIRROL INTERN VIRWRD,VIRBLK INTERN WRIPRI,WRREFL INTERN ZONFLG ;ALPHABETICAL LIST OF EXTERNALS. EXTERN CMDCEI,CMDFLO,RELCEI,RELFLO,STACEI,STAFLO DECCEI==0 DECFLO==0 EXTERN UUOHAN,ERRTTY ;****** UOFP SEGMENTED BASIC ****** T=1 X1=13 X2=14 P=17 EXTERN .JBOPC,.JBTPC,.JBSA,.JBFF,.JBREL EXTERN EDTXIT,UXIT1,RUNNH,EXECUT,OVTRAP,REUXIT,BASCRF EXTERN HSGVER,SAVE,TIMOUT INTERN LBASIC,LUXIT,LUXIT1,LRUNNH,LEXECT INTERN LOVRFL,REENTR,ERRBPT,ERRTCN,ERRTBL,ERRTXT INTERN FORCAR,FORPNT INTERN SAVRUN,NOTLIN,MULLIN,OLDCOD,RUNFIL,RUNUUO INTERN LSAVE,LCHAIN,START,SVDV,IOW INTERN KWDIND,THENAD,THNCNT,THNELS,FTRUTH,LOGNEG,TRUTH,RELNEG,JFCLAD INTERN CENTRY,JAROUN,ELSFLG,ELSEAD,OPNFLG,INPOUT,INPPRI INTERN ONGFLG IFN NOCODE,< IF2,< END> > LSGVER: SIXBIT /BASX13/ ;[3] MUST BE CHANGED FOR EACH NEW HI-SEG ;VERSION, TO AGREE WITH HSGVER ;OLD BASXCT SHOULD BE SSAVED UNDER THIS NAME SYSERR: JFCL ;TEMPORARY CODE TO ALLOW SYSMES: BLOCK 20 ;EXIT AND SAVE ON SYSTEM ERROR CRSHCD: Z MOVEM P,SYSMES+17 ;SAVE THE MOVEI P,SYSMES ;ACS BLT P,SYSMES+16 MOVE P,.JBREL ;AND THE AREA MOVEM P,.JBFF ;ABOVE .JBFF HRLM P,.JBSA ;FOR LATER INSPECTION EXIT 1, ;AND EXIT IFNDEF BASTEK, INTERN SYNTAX SYNTAX: BLOCK 1 EXTERN DDTNH INTERN LDDTNH INTERN DDCODE,DDSTRT,RUNDDT,DDTFLG,DDTCOD,DDTERR,ONGADR INTERN DERRGO,NOLINE INTERN .USREL,.DDFF,.DDREL,.DDSA,.DDTMP OUCRFF: Z ;SET TO -1 MEANS ALL ERRORS TO CREF FILE .USREL: BLOCK 1 .DDFF: BLOCK 1 .DDREL: BLOCK 1 .DDSA: BLOCK 1 .DDTMP: BLOCK 1 RUNDDT: BLOCK 1 DERRGO: BLOCK 1 NOLINE: BLOCK 1 DDCODE: BLOCK 1 DDSTRT: BLOCK 1 DDTFLG: BLOCK 1 DDTCOD: BLOCK 1 DDTERR: BLOCK 1 ONGADR: BLOCK 1 XLIST IFN BASTEK,< LIST INTERN NOORG,XORG,YORG,YABS,XABS,PLTTMP,PLTOUT,PLTIN INTERN XMAX,YMAX NOORG: BLOCK 1 ;FLAG FOR BASCOM XMAX: BLOCK 1 ;X MAXIMUM VALUE YMAX: BLOCK 1 ;Y MAXIMUM VALUE XORG: BLOCK 1 ;XORIGIN YORG: BLOCK 1 ;YORGIN YABS: BLOCK 1 ;Y ABSOLUTE XABS: BLOCK 1 ;X ABSOLUTE PLTOUT: BLOCK 1 PLTIN: BLOCK 1 PLTTMP: BLOCK 5 XLIST > LIST ;VIRTUAL ARRAY LOW SEGMENT STORAGE AFLAG: BLOCK 1 ;A FLAG VIRDIM: BLOCK 1 ;COMPILE TIME, STORES CHANNEL NUMBER VIRWRD: BLOCK 1 ;STORES CURRENT WORD VIRBLK: BLOCK 1 ;STORES CURRENT BLOCK VIRSIZ: BLOCK 1 ;COMPILE TIME, RELATIVE SIZE OF VIRTUAL ARRAYS ONCESW: EXP -1 ;ONCE-ONLY SWITCH FOR START ;AFTERWARDS, THE CONSTANT ZERO. VPAKFL: BLOCK 1 ;-1 IF VARIABLE SPACE PACKED. ;TEMPORARY STORAGE FOR RUN-TIME IFN SUBS PIVOT: ES2: C3: BLOCK 1 SX: LZ: BLOCK 1 DEVBAS: BLOCK 1 ;< > 0 ON EXIT FROM FILNAM IF DEV IS FAKED BAS. FILFLG: BLOCK 1 STARFL: BLOCK 1 ;*** COMTIM: BLOCK 1 ;-1=COMPILE TIME, 1=EXEC TIME, 0=COMMAND TIME. FILTYP: BLOCK 1 CHAFL2: BLOCK 1 UXFLAG: BLOCK 1 DATAFF: BLOCK 1 ;DATA/READ FLG AND FIRST DATA PTR TOPSTG: BLOCK 1 ;HIGHEST UNMOVEABLE(STODGY)ROLL SVRBOT: BLOCK 1 ;BOTTOM OF STRING VECTOR POINTER SPACE. SVRTOP: ARATOP: BLOCK 1 ;TOP OF SPACE RESERVED FOR ARRAYS. VARFRE: BLOCK 1 ;NEXT FREE WORD IN VARIABLE SPACE. FCNLNK: BLOCK 1 ;LINK IN FCN AND GOSUB CALLS CATCNT: BLOCK 1 ;COUNTER FOR TABS IN CAT/F CATLOK: BLOCK 4 ;LOOKUP BLOCK FOR PROTECTION CATFL1: BLOCK 1 ;FLAG FOR CAT/F = -1 CATFLG: BLOCK 1 ;FLAG AND LOOP COUNTER FOR CAT, XFOR, ETC. CHAFLG: BLOCK 1 ;-1 IF CHAINING, 0 OTHERWISE. TEMLOC: BLOCK 1 ININI1: BLOCK 1 DEVICE: BLOCK 2 UFD: BLOCK 4 TABFG: BLOCK 1 TEMP1: BLOCK 1 TEMP2: BLOCK 1 TEMP3: BLOCK 1 DRMBUF: BLOCK 203 VECT1=DRMBUF+2 ;TEMP SPACE FOR MAT INVERT VECT2=DRMBUF+102 RENFLA: EXP -1 ;-1 ALLOWS REEN;0 PREVENTS REEN;>0 REQUESTS REEN RENDON: Z ;SET TO -1 WHILE SERVICING ^C ;SYSTEM PARAMETERS. BATCH: BLOCK 1 ;< > 0 IF UNDER MPB. DSKSYS: BLOCK 1 MONLVL: BLOCK 1 ;DISTINGUISHES BETWEEN LEVEL C AND LEVEL D. SWAPSS: BLOCK 1 ;0 FOR NON-SWAP SYS, -1 FOR SWAPPING. SJOBSA: BLOCK 1 ;INITIAL LH OF .JBSA. SJOBRL: BLOCK 1 ;INITIAL .JBREL ;END--SYSTEM PARAMETERS. ;COMMAND TIME. COPFLG: BLOCK 1 ;COPFLG IS USED BY THE COPY ROUTINE. HEDFLG: BLOCK 1 ;HEADING FLAG FOR QUEUE AND UNSAVE. BADGNN: BLOCK 2 CURDEV: BLOCK 1 ;THE DEVICE ASSOCIATED WITH THE "CURRENT" FILE. CURNAM: BLOCK 1 ;NAME OF THE "CURRENT" FILE. CUREXT: BLOCK 1 ;ITS EXTENSION. CURBAS: BLOCK 1 ;< > 0 SAYS CURRENT DEVICE IS FAKED BAS. RETUR1: BLOCK 1 USGFLG: BLOCK 1 ;USED BY RES TO SEE IF # FOLLOWING USING IS LINE #. OLDFLA: BLOCK 1 ;ZERO WHEN FILE NAME SHOULD BE NEW, ELSE -1. RENSW: BLOCK 1 REVFL: BLOCK 1 LOWSTA: BLOCK 1 SEQPNT: BLOCK 1 ;POINTER TO LINBUF DURING RESEQUENCE. LOWEST: BLOCK 1 ;RESEQUENCE LINES WITH NUMBERS >=LOWEST PAKFLG: BLOCK 1 ;FLAG THAT TELLS IF CORE SHOULD BE CRUNCHED. PAKFLA: BLOCK 1 ;-1 IF TEXT IS NOT PACKED NOBFLG: BLOCK 1 ;-1 IF GEN NOBLANK, 0 IF GEN FRSTLN: BLOCK 1 LASTLN: BLOCK 1 FILNM: BLOCK 2 ;END--COMMAND TIME. ;COMPILE AND LOAD TIME. NEGONE: OCT -1 LOCLOF: BLOCK 1 ;USED BY XINFCN. IFFLAG: BLOCK 1 FILCNT: BLOCK 1 LETSW: BLOCK 1 TYPE: BLOCK 1 FTYPE: BLOCK 1 PFLAG: BLOCK 1 INLNFG: BLOCK 1 QUERYF: Z ;0 - OUTPUT QUERY ON INPUT, -1 - DO NOT WRREFL: BLOCK 1 ;0 IF COMPILING PRINT#/INPUT#, -1 IF WRITE#/READ#. TABLE: BLOCK 1 FUNAME: BLOCK 1 ;IF NZERO, NAME OF MULTI-LINE FN BEING DEFINED RUNFLA: BLOCK 1 ;-1 IF COMPILE OR RUN FUNSTA: BLOCK 1 ;RHALF HAS LOCATION OF JRST AROUND FUNCTION ;LHALF SAVES ARGUMENT COUNT IN A MULTILINE FN FUNLOW: BLOCK 1 ;SAVE VALUE OF TMPLOW DURING MULTILINE FN REGPNT: BLOCK 1 ;POINTER TO SUBEXP IN REG TMPLOW: BLOCK 1 ;CURRENT TEMP UNPROTECTED. (-1 TO START) TMPPNT: BLOCK 1 ;CURRENT TMP USED (-1 TO START) PSHPNT: BLOCK 1 ;COUNTS GENNED "PUSH" INSTS TRNFLG: BLOCK 1 ;USED TO HANDLE SETTING A TRNFL2: BLOCK 1 ;MATRIX EQUAL TO ITS OWN TRANSPOSE. ;END--COMPILE AND LOAD TIME. ;EXECUTION TIME, INTRINSIC FUNCTIONS. DETER: BLOCK 1 ;CONTAINS THE DETERMINATE OF LAST MAT INVERTED. NUMRES: BLOCK 1 ;SET BY MAT INPUT TO NUMBER OF ELEMENTS INPUT. MIDSAV: BLOCK 1 ;USED BY MIDB. STRFCN: BLOCK 1 ;USED BY STRB. STRPTR: BLOCK 1 STRCTR: BLOCK 1 VALPTR: BLOCK 1 ;USED BY VALB. BGNTIM: BLOCK 1 ;STORAGE USED BY TIM. FLOAT: BLOCK 1 RNDIDX: BLOCK 1 ;INDEX FOR RND FUNCTION. RNDDAT: BLOCK 7 ;DATA LOCATIONS FOR RND FUNCTION. RANTST: BLOCK 1 RANCNT: BLOCK 1 ;END--EXECUTION TIME, INTRINSIC FUNCTIONS. ;EXECUTION TIME, CORE MANAGER. APBMAX=^D47 ;MAX APPEND BLOCK LENGTH MASMAX=^D47 ;SAME FOR MASTER APP BLOCK MASAPP: BLOCK MASMAX SRTDBA: BLOCK 9 BA: BLOCK 9 CORINC: BLOCK 1 ;INCREMENT FOR CORE DURING PROGRAM EXECUTION. NUMMSP: BLOCK 1 NUMAPP: BLOCK 1 VRFBOT: BLOCK 1 VRFTOP: BLOCK 1 VRFBTB: BLOCK 1 VRFSET: BLOCK 1 ;END--EXECUTION TIME, CORE MANAGER. ;EXECUTION TIME, MISC. N=0 EX1: FSC N,0 ;SCALE THE RESULTS. IFNFLG: BLOCK 1 EXTFG: BLOCK 1 CRTVAL: BLOCK 1 ;CRT VALUE FALG ;=0 10-13 ILLEGAL IN CHANGE STATEMENT ;<> 0 10-13 ARE LEGAL ;"ON ERROR GOTO" LOCATIONS ERR: BLOCK 1 ;ERROR # WHEN ERROR ENCOUNTERED ERL: BLOCK 1 ;LINE # OF ERROR STATEMENT ERRGO: BLOCK 1 ;USERS "ON ERROR GOTO" ADDRESS ERRTRO: BLOCK 1 ;ADDRESS OF ERROR UUO SO CAN FINISH UP ;NORMAL ERROR PROCESSING IF NEEDED. MIXFLG: BLOCK 1 ;IF MIX MODE ARITH WAS PERFORMED INPRES: BLOCK 1 ;SAVES P TO RESUME FROM INPUT ERROR SORCLN: BLOCK 1 ;AT EXECUTION TIME, THE CURRENT SOURCE LINE NO. ;POINTER TRAIL: BLOCK 1 ;FLAGS FOR LEAD: BLOCK 1 ;USING STATEMENTS. INVFLG: BLOCK 1 ;NE 0 MEANS INVERTING A MATRIX. INVLRG: BLOCK 1 ;DURING MAT INV HAS ELM OF LRGS MAG. REATMP: BLOCK 1 ;USED BY STRETT AND STRETR. SB1M1: BLOCK 1 SB2M1: BLOCK 1 INPFLA: BLOCK 1 ;NON-ZERO DURING INPUT,ZERO DURING READ LIBFLG: BLOCK 1 DATLIN: BLOCK 2 ;DATA LINE PREAD: BLOCK 2 ;POINTER TO DATA LINES PINPUT: BLOCK 2 ;POINTER TO INPUT LINES QUOFL1: BLOCK 1 ;-1 SAYS READING A QUOTED STRING. QUOFLG: BLOCK 1 ;<>0 SAYS MUST QUOTE THIS STRING WHEN PRINTING. ELETOP: BLOCK 1 ;UPPER BOUND OF "MAT INPUT" ELECT1: BLOCK 1 ;UPPER BOUND OF COLUMN DIMENSION ELECT2: BLOCK 1 ;RUNNING COUNT OF PLACE IN COLUMNS ELECT3: BLOCK 1 ;STORED VALUE FROM ELECT2 AT START OF INPUT ;END--EXECUTION TIME, MISC. ;FORMAT AND FILE CONTROL. PINPNM: BLOCK ^D9 LINNUM: BLOCK ^D9 TABVAL: BLOCK ^D10 POINT: BLOCK ^D9 ;USED BY THE R.A. ROUTINES. BLOCK: BLOCK ^D9 MODBLK: BLOCK ^D9 STRLEN: BLOCK ^D9 LASREC: BLOCK ^D9 ZONFLG: BLOCK ^D10 ;USED TO FORCE COMMAS TO SPACE. EOFFLG: BLOCK ^D9 FIRSFL: BLOCK ^D10 ;TELLS IF ANY OUTPUT HAS BEEN DONE ON THIS PAGE. PROTEC: BLOCK ^D9 ;< > FOR FILES AT RUNTIME. PAGCNT: BLOCK ^D10 PAGLIM: BLOCK ^D10 QUOTBL: BLOCK ^D10 PARAM: ;WARNING ******************************** WRIPRI: BLOCK ^D9 ;PARAM IS A ^D32 WORD BLOCK FOR USE BY QUEUE. REAINP: BLOCK ^D9 MARGIN: BLOCK ^D10 MARWAI: BLOCK ^D10 FILD: BLOCK ^D9 EXTD: BLOCK ^D9 FPPN: BLOCK ^D9 ACTBL: BLOCK ^D9 FMTPNT: BLOCK ^D10 ;LAST FORMAT CHAR FLAG HPOS: BLOCK ^D10 ;HORIZ POSITION. TTYPAG: BLOCK 1 IFIFG: BLOCK 1 ;INPUT FROM DSK (IF NOT ZERO). ODF: BLOCK 1 ;END--FORMAT AND FILE CONTROL. ;MISC. NUMCOT: BLOCK 1 ;USED AT COMMAND AND RUNTIME TO ADJUST SEQ. NOS. RUNLIN: BLOCK 1 ;HAS START LINE NO. FOR PROG EXEC OR -1 IF NONE. MTIME: BLOCK 1 ;HOLDS TIME FOR "TIME:" MESSAGE. ;END--MISC. ;DISPATCH. TRPLOC: XWD 4,TRPMSG 400000000002 BLOCK 2 STOTRP: BLOCK 1 ;TEMP USED FOR LOC AT CTRL C INTERP. UUOH: BLOCK 1 JRST UUOHAN TRPMSG: SKIPN RENDON ;ALREADY SERVICING ONE ? AOSE RENFLA ;OR LOCK ON ? JRST TRPMS0 ;YES, JUST DISMISS TRPMS3: SETOM RENDON ;NO, MARK THAT SERVICING STARTS SETZM TRPLOC+2 ;ALLOW NEW INTERRUPTS SKIPGE RUNDDT ;RUNNING IN DDT ? JRST TRPMS1 ;YES, JUST BACK TO INPUT LEVEL SKIPE RUNDDT ;AT DDT INPUT LEVEL ? JRST LDRXIT ;YES SKIPLE COMTIM ;COMPILE OR EXECUTE ? JRST LREXIT ;EXECUTE JRST LBASIC ;COMPILE TRPMS0: AOS RENFLA ;JUST MARK SETZM STOTRP ;AND GET EXCH TRPLOC+2 ;INTERCEPT ADDRESS EXCH STOTRP ;AND RE-ENABLE EXCH TRPLOC+2 ;RESTORING AC0 JRST 2,@STOTRP ;AND CARRY ON TRPMS1: SETOM DDTERR ;RUNNING IN DDT, FAKE AN ERROR SETZM RENDON ;ALLOW NEW INTERRUPTS SETOM RENFLA JRST DDTNH ;AND BACK TO DDT INPUT LEVEL REENTR: SKIPL RENFLA JRST REENT1 SKIPLE COMTIM JRST LREXIT ;CLOSE FILES. JRST LBASIC ;REENTER IF ALLOWED REENT1: AOS RENFLA ;MAKE REQUEST BY SETTING FLAG PLUS JRST 2,@.JBOPC LOVRFL: MOVEM X1,SEGSAV ;SAVE X1 MOVE X1,.JBCNI## ;GET STATE OF APR TRNN X1,230000 ;CHECK FOR SYSTEM ERRORS JRST LOVRF1 ;NO, OUTSTR [ASCIZ / ? System error - please contact computer center /] OUTSTR SYSMES ;PUT OUT ANY SPECIAL MESSAGE XCT SYSERR ;AND EXECUTE ANY SPECIAL PATCH CODE MOVE P,PLIST ;RESTORE P IN CASE PDL OV. SETOM RUNUUO ;GO GET NEW IMAGE JRST NEWIMG ;IN CASE THINGS CLOBBERED LOVRF1: MOVE X1,SEGSAV ;RESTORE X1 SKIPG COMTIM JRST OVFLCM SKIPN BXSDDT SKIPE BXSXCT JRST OVTRAP ;GO TO EXECUTE TRAP OVFLCM: PUSH P,X1 MOVEI X1,230010 APRENB X1, SETOM LIBFLG POP P,X1 JRST @.JBTPC LBASIC: MOVE P,PLIST ;RESTORE PDL LUXIT: SETZM SAVRUN ;ERROR, DONT MAKE SAV CODE SETZM NOTLIN ;OR CRUNCH LINES SETZM MULLIN ;AND UNSET MULTI-LINE SKIPE OLDCOD ;ERROR IN CRUNCHED CODE ? JRST GETNEV ;YES, JUST GET NEW IMAGE PUSH P,[XWD 0,EDTXIT] JRST GETIC LUXIT1: SKIPN SAVRUN ;RUNNING SAV CODE ? JRST NUXIT ;NO, NORMAL EXIT SKIPE CHAFLG ;CHAINING ? JRST LCHAIN ;YES, GO CHAIN JRST GETNEW ;ELSE GET NEW IMAGE NUXIT: SKIPN ERRTCN ;ANY ERRORS ? JRST NUXIT2 ;NO, CONTINUE PUSHJ P,GETERR ;YES, GO PUT OUT SKIPE RUNDDT ;USING BASDDT? JRST NUXIT1 ;YES, BACK TO BASXCT NUXIT2: PUSH P,[XWD 0,UXIT1] JRST GETIC ;AND BACK TO BASIC NUXIT1: PUSH P,[XWD 0,DDTNH] ;GOTO DDTINT SETOM DDTERR ;SET ERROR FLAG JRST GETDDT ;AND BACK TO BASDDT LRUNNH: PUSH P,[XWD 0,RUNNH] JRST GETCOM START: TDZA X1,X1 ;STARTED BY MONITOR RUN CMND SETO X1, ;STARTED BY BASEDT OR CHAIN STAT MOVEM X1,RUNUUO ;FLAG WHICH (FOR NEWIMG) STARTX: RESET MOVE P,PLIST ;SET UP PUSH-DOWN POINTER SETZB X1,RENDON ;ALLOW ^C RUNTIM X1, ;GET RUN TIME FOR PRINT-OUT MOVEM X1,MTIME LEXECT: PUSH P,[XWD 0,EXECUT] JRST GETXCT LREXIT: PUSH P,[XWD 0,REUXIT] JRST GETXCT LCRFNH: PUSH P,[XWD 0,BASCRF] JRST GETCRF LDDTNH: PUSH P,[XWD 0,DDTNH] JRST GETDDT LDRXIT: PUSH P,[XWD 0,REUXIT] JRST GETDDT DEFINE SEGS< X IC X COM X XCT X DDT X ERR X CRF > NUMSEG=0 DEFINE X(A) IFN NUMSEG, NUMSEG=NUMSEG+1> CORSEG: SEGS %N==0 DEFINE X(A) < A'NO==%N %N==%N+1> SEGS SAVX1: Z ;X1 SAVED HERE DURING GETSEG DEFINE X(A) < SIXBIT /BAS'A/> SEGNAM: SEGS SEGADR: TTYIN TTYIN TTYIN TTYIN ERRTTY TTYIN DEFINE X(A) SEGS DEFINE X(A) < SETZM BXS'A> MARKER: SKIPGE RENFLA ;ALREADY LOCKED ? SETZM RENFLA ;NO, LOCK OUT ^C FOR GETSEG MOVEM X1,SAVX1 ;SAVE X1 POP P,X1 ;GET CALLING P.C. +1 HRRZS X1 ;JUST R.H. SUBI X1,GETIC+1 ;X1 = SEGMENT INDEX SKIPE CORSEG(X1) ;ALREADY THERE? JRST GODOIT ;YES, DO YOUR THING ! SEGS ;ELSE SETOM CORSEG(X1) ;MARK NEW SEGMENT IN CORE PUSH P,X1 ;SAVE X1 PUSHJ P,DELHI ;DELETE HI SEG POP P,X1 ;RESTORE X1 MOVEM P,SEGSAV+17 ;START SAVING ACS MOVE P,SEGNAM(X1) ;GET SEGMENT NAME SKIPN SAVRUN ;SAV FILE ? SETNAM P, ;NO, PUT IT IN SYSTAT TABLE MOVEM P,SEGFIL ;SAVE FOR GETSEG MOVEI P,SEGSAV ;AND FINISH BLT P,SEGSAV+16 ;SAVING ACS MOVEI P,SEGARG ;GETSEG BLOCK ADDRESS GETSEG P, ;GET THE NEW SEGMENT JRST [MOVEI X1,[ASCIZ / ? Segment control error /] CAIN P,10 ;JUST A CORE HOG ? MOVEI X1,[ASCIZ / ? Out of room /] TTCALL 3,(X1) ;GIVE MESSAGE MOVE X1,CELIN ;TOP OF LINROL HRLI X1,1 ;TO DELETE HI SEG CORE X1, ;CONTRACT HALT ;IMPOSSIBLE ! SKIPN X1,SEGSAV+X1 ;GET SEG BEING GOT EXIT ;BASEDT, JUST GIVE UP CAIN X1,XCTNO ;BASXCT ? SKIPN SAVRUN ;AND SAVE CODE ? JRST LBASIC ;NO, JUST BACK TO BASICS MOVE X1,[SIXBIT /BASXCT/] CAME X1,SEGNAM+XCTNO ;YES, IS IT A DEAD OTS ? JUMPE P,[TTCALL 3,[ASCIZ / ? Version no longer supported - resave /] EXIT] MOVE P,PLIST ;NO, GET A FRESH IMAGE JRST GETNEW] MOVSI P,SEGSAV ;RESTORE BLT P,16 ;THE ACS MOVE P,SEGSAV+17 ;ALL OF THEM CAIN X1,XCTNO ;GETTING EXECUTE SEG ? SKIPN SAVRUN ;AND RUNNING SAV CODE JRST GODOIT ;NO TO ONE OF ABOVE PUSHJ P,SEGCHK ;YES, CHECK WE HAVE RIGHT VERSION GODOIT: PUSH P,SEGADR(X1) EXCH X1,SAVX1 ;RESTORE X1, SAVE SEGMENT INDEX SKIPN RENDON ;LOCKED OUT ? JRST GODOT2 ;NO, GO SEE IF REQUEST IN SKIPE SAVX1 ;YES, GOING TO BASEDT ? POPJ P, ;NO, CARRY ON THE GOOD WORK SETZM RENDON ;YES, RE-ENABLE GODOT1: SETOM RENFLA ;THE ^C INTERRUPT POPJ P, ;AND OFF WE GO ........... GODOT2: SKIPG RENFLA ;WERE WE RUDELY INTERRUPTED ? JRST GODOT1 ;NO, RE-ENABLE AND RETURN SKIPE SAVX1 ;YES, GOING TO BASEDT ? JRST TRPMS3 ;NO, GO HANDLE JRST GODOT1 ;YES, JUST CARRY ON SEGCHK: MOVE X2,LSGVER ;GET SAV VERSION CAMN X2,HSGVER ;SAME AS HI-SEG VERSION POPJ P, ;YES, ALL IS WELL MOVEM X2,SEGNAM(X1) ;NO, VERSION IS SIXBIT NAME OF OLD SEG TTCALL 3,[ASCIZ / % Using obsolete version, resave soon /] SETZM CORSEG(X1) ;MARK SEG NOT IN CORE JRST STARTX ;GO TRY AGAIN LCHAIN: SKIPL RUNUUO ;RUN BY BASEDT ? TDZA X2,X2 ;NO, MUST BE BY RUN CMND HRLZI X2,1 ;YES, SO FLAG MOVE X1,NEWOL1 ;GET DEVICE MOVEM X1,RUNFIL ;SAVE IN RUN BLOCK SETZM FILDIR+1 SETZM FILDIR+2 SETZM FILDIR+4 ;SET UP FOR RUN PUSHJ P,DELHI ;DELETE HI SEG HRRI X2,RUNFIL ;GET RUN UUO BLOCK RUN X2, ;AND RUN CHAIN FILE MOVE P,PLIST ;ERROR, RESTORE PDL AOS ERRTCN ;SET ERROR COUNT TTCALL 3,[ASCIZ / ? Cannot run /] MOVEI X1,ERRTXT MOVEM X1,ERRTBL ;SET TEXT ADDRESS MOVE X1,[XWD 700,ERRTXT-1] MOVEM X1,ERRBPT MOVE X1,[XWD 440600,FILDIR] LCHER: ILDB X2,X1 JUMPE X2,LSCRLF ;GO PUT OUT MESSAGE ADDI X2,40 IDPB X2,ERRBPT JRST LCHER LSCRLF: MOVEI X2,15 ; IDPB X2,ERRBPT MOVEI X2,12 ; IDPB X2,ERRBPT PUSH P,[XWD 0,NEWIMG] JRST GETERR ;GO PUT OUT MESSAGE SANS TIME GETNEV: SETOM RUNUUO ;DON'T EXIT GETNEW: PUSH P,[XWD 0,NEWIMG] JRST SVTIME ;DONT MAKE SAV CODE LSAVE: PUSH P,[XWD 0,NEWIMG] PUSH P,[XWD 0,SAVE] SETOM RUNUUO ;DONT EXIT SVTIME: PUSH P,[XWD 0,TIMOUT] JRST GETERR ;GO GET ERROR SEG NEWIMG: SETOB X1,RENFLA ;TURN ON ^C AND ECHO IN CASE GETLCH X1 ;IT WAS LEFT OFF TLZ X1,(1B15) ;ECHO BIT ON SETLCH X1 ;RESET LINE CHARACTERISTICS PUSHJ P,DELHI ;DELETE HI SEG SKIPN RUNUUO ;RUN BY BASEDT ? EXIT ;NO, SO JUST EXIT MOVE X1,SEGNAM MOVEM X1,SEGFIL ;SET TO RUN BASIC MOVEI X1,SEGARG RUN X1, ;RUN IT HALT ;MONITOR HANDLES ERRORS DELHI: HRLZI X1,1 ;SET CORE ARG CORE X1, ;TO ZAP HI SEG HALT ;ERRORS IMPOSSIBLE POPJ P, ;RETURN TTYIN: PUSH P,T TTYDSK: MOVEI T,TTYBUF MOVEM T,.JBFF INIT 1 SIXBIT /TTY/ XWD TYO,TYI HALT .+3 INBUF 1 OUTBUF 1 SETZ T, DEVCHR T, ;GET DEVICE CHARACTERISTICS TLNE T,10 ;TERMINAL ? TLNE T,200100 ;AND NOT DSK OR DTA (I.E. NUL:) JRST [OUTSTR [ASCIZ / ? Command device is not a terminal, .DEA TTY & .CONT /] EXIT 1, JRST TTYDSK] POP P,T POPJ P, IOW: BLOCK 2 ;IOWD FOR SAVE SVDV: EXP 17 ;OPEN BLOCK FOR SAVE DEVICE SIXBIT /DSK/ Z ;GETSEG UUO BLOCK INTERN SEGARG SEGARG: SIXBIT /SYS/ SEGFIL: BLOCK 5 ;PLACE TO SAVE ACS DURING GETSEG SEGSAV: BLOCK 20 ;SAVRUN HOLDS SAV FILE NAME IF SAV CODE BEING MADE, ELSE 0 SAVRUN: Z ;NOTLIN = 0 IF NOT CRUNCHING LINE #S, = -1 IF WE ARE CRUNCHING NOTLIN: Z ;RUNUUO = 0 IF RUN AT .JBSA, = -1 IF AT .JBSA+1 (AS BY BASEDT) RUNUUO: Z ;MULLIN CONTAINS POINTER TO BEG OF STMNT IF NOT FIRST IN LINE, ELSE 0 MULLIN: Z ;OLDCOD HAS OLD FLCOD IF CRUNCHING FOR SAV, ELSE 0 OLDCOD: Z ;THESE TWO HAVE SAVED INFO FOR SCANNING FORS AFTER ASSUMED STEP 1 FORCAR: Z FORPNT: Z ;INDEX OF KEYWORD FOUND IN SEARCH KWDIND: Z ;COUNT OF THENS NOT MATCHED BY ELSES THNCNT: BLOCK 1 ;ADDRESS OF LAST JRST AROUND THEN THENAD: Z ;FLAG THAT REST OF LINE IS UNDER CONDITIONAL THNELS: Z ;TRUTH VALUE OF FOR RANGE TEST FTRUTH: Z ;LOGNEG=-1 NEGATE LOGIC OF IF =0 DO NOT LOGNEG: Z ;TRUTH VALUE OF LAST IF TRUTH: Z ;RELNEG=-1 NEGATE LOGIC OF IF RELATIONAL ELEMENT RELNEG: Z ;ADDRESS OF JFCL AT BEG OF STMNT, USED FOR JRST INTO MODIFIERS JFCLAD: Z ;ADDRES OF ENTRY INTO LAST MODIFIER CENTRY: Z ;ADDRESS OF JRST AROUND MODIFIER JAROUN: Z ;ELSFLG=-1 ONE-WORD THEN =0 MULTI-WORD THEN ELSFLG: Z ;ADDRESS OF LAST JRST AROUND ELSE ELSEAD: BLOCK 1 ;OPNFLG=-1 OPEN STMNT =0 FILE STMNT OPNFLG: Z ONGFLG: Z ;INPOUT=-1 FOR OUTPUT =1 FOR INPUT =0 FOR NEITHER IN OPEN STMNT INPOUT: Z ;INPPRI=-1 FOR STRING OUTPUT ON INPUT FROM TTY, 0 OTHERWISE INPPRI: BLOCK 1 ;BYTE POINTER FOR ERRORS STORED IN ERRTXT ERRBPT: Z ;COUNT OF ERRORS TO BE OUTPUT BY BASERR ERRTCN: Z ;TABLE OF ERROR ADDRESSES FOR BASERR ERRTBL: BLOCK 44 ;TEXT OF VARIABLE MESSAGES - E.G LINE #S, IN ASCIZ ERRTXT: BLOCK 44 ;END--DISPATCH. ;IO. SPEC: EXP 1 NEWOL1: SIXBIT /DSK/ EXP TYI SAVI: OCT 1 SAVE1: SIXBIT /DSK/ XWD TYO, IBF: BLOCK 3 OBF: BLOCK 3 RUNFIL: Z ;DEVICE FOR RUN UUO FILDIR: BLOCK 6 FILD1: BLOCK 4 LOK: BLOCK 4 ENT: BLOCK 4 PTHBLK: BLOCK ^D9 ;PATH BLOCK, ROOM FOR 5 SFDS TYI: BLOCK 3 TYO: BLOCK 3 TTYBUF: BLOCK 46 LINB0: BLOCK ^D51 APPMAX=^D100 ;MAX NO OF APPEND BLOCKS APPLST: ;APPLST IS RUNTIME, QLSPEC IS COMMAND TIME. QLSPEC: BLOCK APPMAX+1 OBDSK2: OUTBUF 0,2 OBDSK: OUTBUF 0,1 IBDSK2: INBUF 0,2 IBDSK: INBUF 0,1 OUTDSK: OUTPUT 0, OUTTDS: OUT 0, INDSK: INPUT 0, INNDSK: IN 0, STODSK: STATO 0,740000 STADSK: STATZ 0,20000 STWDSK: STATZ 0,400000 STQDSK: STATZ 0,040000 GTSTS: GETSTS 0,N CLOSED: CLOSE 0, RENAMD: RENAME 0,LOK CURLIN: BLOCK 1 DREL: RELEASE 0, LOKUP: LOOKUP 0,LOK ENTDSK: ENTER 0,ENT DEFINE R(A) < IRP A < USETO A,0>> USETOD: R<1,2,3,4,5,6,7,8,9> DEFINE R(A) < IRP A < USETI A,0>> USETID: R<1,2,3,4,5,6,7,8,9> DEFINE R(A) < IRP A < OPEN ^D,OPS'A>> INITO: R<1,2,3,4,5,6,7,8,9> DEFINE R(A) > R<1,2,3,4,5,6,7,8,9> XXLOC=. DEFINE R(A) < IRP A > R<1,2,3,4,5,6,7,8,9> DEFINE R(A) < IRP A > R<1,2,3,4,5,6,7,8,9> ;END--IO. ;PUSHDOWN LISTS. PSAV: XWD -300,PLIST ;TO SAVE P IN CASE ERROR INTERCEPT IN FN ;OR GOSUB PLIST: XWD -300,. BLOCK 300 QLIST: XWD -100,. BLOCK 100 ;END--PUSHDOWN LISTS. ;ROLLS. DEFINE ROLLS < X TXT X LIN X COD X CON X SLT X LIT X ARA X SVR X GSB X VIR X SCA X VSP X PTM X TMP X STM X SEX X VAR X ARG X REF X FCN X FCL X FAD X CAD X LAD X SAD X FOR X NXT X DON X DLT X DIT X DPT X DTP INTERN DONROL,DLTROL,DITROL,DPTROL,DTPROL > PSHROL=200000 ;ADDRESS ASSOCIATED WITH THIS ;PHANTOM ROLL ARE ABSOLUTE, INDEXED BY (P) DEFINE TBLS< X CMD X STA X DEC X REL > ZZ.=0 DEFINE X(A) TBLS ROLLS ROLTOP=ZZ.-1 FLOOR: DEFINE X(A) TBLS DEFINE X(A) ROLLS CEIL: DEFINE X(A) TBLS DEFINE X(A) ROLLS COMBOT=SEXROL ;BOTTOM COMPILE ROLL AFTER CODROL COMTOP=DTPROL ;TOP COMPILE ROLL. MINFLG=400000 ;MINUS FLAG IN LEFT HALF OF EXPR PNTR ROLMSK=377777 ;ROLL NUMBER MASK IN SAME SUBTTL LITERALS DEFINE IMP(A) < CE'A=CEIL+A'ROL FL'A=FLOOR+A'ROL INTERN CE'A,FL'A > IMP SVR IMP SLT IMP LIT IMP SCA IMP ARA IMP STM IMP PTM IMP LAD IMP GSB IMP VIR IMP FOR IMP FCL IMP CAD IMP ARG IMP REF IMP COD IMP SEX IMP SAD IMP NXT IMP LIN IMP CON IMP VSP IMP TXT IMP TMP IMP FAD IMP VAR IMP DON IMP DLT IMP DIT IMP DPT IMP DTP ;END--ROLLS. ;LOW SEGMENT STUFF FOR CREF RELOC XXLOC HASH=145 INTERNAL L1,L2,SVJFF,.WPL,WRITEE,WRITEX,AWRITE,M6X,M0XCT INTERN DMPXCT,SYNERR,STCLR,OPTBL,MACTBL,SYMTBL,REFBIT,REFINC INTERN SRTTMP,FRDTMP,INBUF,INDEV,INDIR,LSTBUF,LSTDEV INTERN PPSAV,LPP,PPTEMP,FIRSTL,ERRSTS,CMDTRM,IOJFF,LOWLIM INTERN UPPLIM,SVLAB,LEVEL,BLKST,OFLAG,OFLAG1,OFLAG2 INTERNAL LINUM,CRBUF,VBUF,NLZF INTERN OFLAG3,BLKND,ENDCLR,VARMOD,VARNAM,X22,MRDFL INTERN SAVII,SAVE11,CRFSUB,FSTPNT STCLR: ;START BLT CLEAR HERE L1: BLOCK 1 ; [21] SAVE FOR LONG L2: BLOCK 1 ; [21] SYMBOL ROUTINES SVJFF: BLOCK 1 .WPL: BLOCK 1 ;NUMBER OF ENTRIES/LINE OF CREF (WPLTTY OR WPLLPT) WRITEE: BLOCK 1 ;INSTR TO XCT TO GET INTO THE WRITE ROUTINE WRITEX: BLOCK 1 ;INSTR TO XCT AT GET OUT OF THE WRITE ROUTINE AWRITE: BLOCK 1 ;ADDRESS OF WRITER (EITHER WRITE OR CPOPJ) M6X: BLOCK 1 ;INSTR TO XCT TO DECIDE WHETHER TO ENTER A SYMBOL ; IN THE SYMBOL TABLE M0XCT: BLOCK 1 ;INSTRUCTION TO XCT TO WRITE A LEADING TAB. DMPXCT: BLOCK 1 ;OUT LST, EXCEPT, FOR MTA OUTPUT: PUSHJ P,DMPOUT SYNERR: BLOCK 1 OPTBL: BLOCK HASH+1 ;OPCODE TABLE (EXTRA CELLS NEEDED FOR MERGE) MACTBL: BLOCK HASH+1 SYMTBL: BLOCK HASH+1 REFBIT: BLOCK 1 ;TEMP CELL FOR REFERENCE TYPE IN SRCH REFINC: BLOCK 1 ;TEMP CELL FOR REFERENCE TYPE IN SRCH SRTTMP: BLOCK 1 ;TEMP CELL FOR SORT FRDTMP: BLOCK 1 ;TEMP CELL FOR FREAD INBUF: BLOCK 3 INDEV: BLOCK 1 ;INPUT DEVICE (FOR ERR MESSAGES ONLY) INDIR: BLOCK 4 LSTBUF: BLOCK 3 LSTDEV: BLOCK 1 ;LIST DEVICE (FOR ERR MESSAGES ONLY) PPSAV: BLOCK 1 ;RESTORE P FROM HERE FOR "IMPROPER INPUT DATA" LPP: BLOCK 1 PPTEMP: BLOCK 1 FIRSTL: BLOCK 1 ;LINE # AFTER WHICH TO PRINT LISTING ERRSTS: BLOCK 1 ;HOLDS ERROR STATUS FOR MESSAGES CMDTRM: BLOCK 1 ;HOLS LAST CHARACTER IN COMMAND SCANNER IOJFF: BLOCK 1 ;HOLDS .JBFF BEFORE INPUT BUFFERS SETUP LOWLIM: BLOCK 1 ;LOWER LIMIT (STARTING LINE #) UPPLIM: BLOCK 1 ;UPPER LIMIT (ENDING LINE #) SVLAB: BLOCK 1 LEVEL: BLOCK 1 ;BLOCK LEVEL FOR COMBG. BLOCK 1 ;BLKST-1 IS CLOBBERD AT R0!! BLKST: BLOCK 1 OFLAG: BLOCK 1 OFLAG1: BLOCK 1 OFLAG2: BLOCK 1 OFLAG3: BLOCK 1 BLKND: BLOCK 1 CRBUF: BLOCK 3 ;CREF OUTPUT FILE BUFFER HEADER VBUF: BLOCK ^D13 ;PAGE HEADER BLOCK LINUM: Z ;LINE COUNT NLZF: Z ;FLAG = -1 IF DONT WANT TO OUTPUT LEADING ZEROES VARNAM: BLOCK 1 ;BUILD CREF VARIABLE NAME HERE VARMOD: BLOCK 1 ;-1 IF VARNAM IS A BEING MODIFIED OR DEFINED TYPE X22: BLOCK 1 ;POINTER TO VARNAM (7 BIT ASCII) MRDFL: BLOCK 1 ;MAT READ FLAG SAVII: OCT 1 ;OPEN BLOCK FOR CREF OUTPUT SAVE11: SIXBIT /DSK/ ;ALWAYS USE DSK XWD CRBUF, ;CRBUF IS BUFFER HEADER CRFSUB: Z ;-1 MEANS PROCESSING SUBSCRIPT FSTPNT: Z GOSBFL: Z ;-1 MEANS PROCESSING GOSUB CRFERR: Z ;-1 MEANS TO RETURN TO FAILER FROM EOLIN ENDCLR= .-1 TTYCRF: Z ;-1 MEANS WANT CREF ON TTY OTHERWISE LPT END