--- /dev/null
+TITLE BASIC V010\r
+SUBTTL PARAMETERS AND TABLE\r
+\r
+;***COPYRIGHT 1969, 1970, 1971, 1972, DIGITAL EQUIPMENT CORP., MAYNARD, MASS.***\r
+\r
+ JOBVER=137\r
+ LOC JOBVER\r
+ OCT 10\r
+\r
+IFNDEF PURESW,<PURESW==1>\r
+\r
+;CONDITIONAL ASSEMBLY PARAMETERS\r
+; THE VERSION OF BASIC SUPPLIED BY APPLIED LOGIC CORPORATION\r
+; IS ASSEMBLED WITH THE PARAMETERS BELOW SET TO -1. APPLIED\r
+; LOGIC CORPORATION HAS NOT NECESSARILY TESTED VERSIONS OF\r
+; BASIC ASSEMBLED OTHERWISE AND DOES NOT GUARANTEE TO\r
+; MAINTAIN ANY SUCH VERSIONS.\r
+\r
+FTRND=-1 ;-1 IF RANDOM FACILITY, ELSE 0\r
+FTMAT=-1 ;-1 IF MATRIX FACILITY, ELSE 0\r
+FTSTR=-1 ;-1 IF STRING FACILITY, ELSE 0\r
+\r
+IFE PURESW,< RELOC >\r
+IFN PURESW,< HISEG >\r
+\r
+;AC DEFINITIONS\r
+ ;PRINCIPAL USES:\r
+\r
+N=0 ;RUNTIME ACCUMULATOR REGISTER\r
+T=1 ;POINTER TO NXCH\r
+T1=2\r
+A=3 ;SEARCH ARGUMENT\r
+B=4 ;POINTER AFTER SEARCH\r
+C=5 ;XWD CHARACTER-FLAGS,CHAR\r
+D=6 ;BUILD INSTS HERE\r
+F=7 ;FLAGS\r
+E=10\r
+G=11\r
+R=12 ;POINTER TO ROLL BEING USED\r
+X1=13 ;)\r
+X2=14 ;)TEMP REGS\r
+Q=15 ;PUSHDOWN LIST FOR FNX ARGS.\r
+L=16\r
+LP=16\r
+P=17 ;PUSHDOWN LIST\r
+\r
+\f\r
+STAFLO:\r
+ Z XCHAN+60000(SIXBIT / CHA/)\r
+ Z XDATA+40000(SIXBIT / DAT/)\r
+ Z XDEF+40000(SIXBIT / DEF/)\r
+ Z XDIM+0(SIXBIT / DIM/)\r
+ Z XEND+0(SIXBIT / END/)\r
+ Z XFNEND+60000(SIXBIT / FNE/)\r
+ Z XFOR+20000(SIXBIT / FOR/)\r
+ Z XGOSUB+60000(SIXBIT / GOS/)\r
+ Z XGOTO+60000(SIXBIT / GOT/)\r
+ Z XIF+20000(SIXBIT / IF /)\r
+ Z XINPUT+60000(SIXBIT / INP/)\r
+ Z XLET+20000(SIXBIT / LET/)\r
+IFN FTMAT,<\r
+ Z XMAT+20000(SIXBIT / MAT/)\r
+>\r
+ Z XNEXT+60000(SIXBIT / NEX/)\r
+ Z XON+20000(SIXBIT / ON /)\r
+ Z XPRINT+60000(SIXBIT / PRI/)\r
+IFN FTRND,<\r
+ Z XRAN+60000(SIXBIT / RAN/)\r
+>\r
+ Z XREAD+60000(SIXBIT / REA/)\r
+ Z NXTST1+0(SIXBIT / REM/)\r
+ Z XREST+40000(SIXBIT / RES/)\r
+ Z XRETRN+60000(SIXBIT / RET/)\r
+ Z XSTOP+40000(SIXBIT / STO/)\r
+STACEI:\r
+\f;TABLE OF BASIC COMMANDS\r
+\r
+DEFINE YYY (A,B)<\r
+ EXP SIXBIT /A/ + 'A'ER + 'B'0000>\r
+\r
+CMDFLO: YYY DEL,4\r
+ YYY LEN,4\r
+ YYY LIS,4\r
+ YYY NEW\r
+ YYY OLD\r
+ YYY REN,4\r
+ YYY REP,4\r
+ YYY RES,4\r
+ YYY RUN\r
+ YYY SAV,4\r
+ YYY SCR,4\r
+ YYY SYS,4\r
+ YYY WEA,4\r
+CMDCEI:\r
+\f;CHARACTER TYPE TABLE.\r
+;FLAGS IN LEFT HALF OF CTTAB+<LETTER> FOR <LETTER> BELOW 100,\r
+;FLAGS IN RIGHT HALF OF CTTAB+<LETTER-100> OTHERWISE.\r
+\r
+DEFINE WWW (FL,VAL)<\r
+ XLIST\r
+FL=< Z 0,(VAL)>\r
+ LIST>\r
+\r
+WWW F.APOS,1B0 ; '\r
+WWW F.COMA,1B1 ; ,\r
+WWW F.CR,1B2 ; <RETURN, OR LF,VT,FFEED>\r
+WWW F.DIG,1B3 ; <NUMERAL>\r
+WWW F.DOLL,1B17\r
+WWW F.EQAL,1B4 ; =\r
+WWW F.ESC,1B5 ; <ESCAPE OR ALTMODE>\r
+WWW F.LCAS,1B6 ; <LOWER CASE LETTER>\r
+WWW F.LETT,1B7 ; <LOWER OR UPPER CASE LETTER>\r
+WWW F.STR,1B8 ; (\r
+WWW F.MINS,1B9 ; -\r
+WWW F.PER,1B10 ; .\r
+WWW F.PLUS,1B11 ; +\r
+WWW F.QUOT,1B12 ; "\r
+WWW F.RPRN,1B13 ; )\r
+WWW F.SLSH,1B14 ; /\r
+WWW F.STAR,1B15 ; *\r
+WWW F.SPTB,1B16 ; <SPACE OR TAB>\r
+\r
+F.NU=0 ;ASCII CODES THAT ARE TREATED AS NULLS.\r
+F.OTH=0 ;OTHER CHARACTERS ANALYSED BY BASIC WITHOUT THE USE OF FLAGS.\r
+\r
+F.TERM=F.CR+F.APOS ;EITHER TERMINATES THE ANALYZABLE PORTION OF A BASIC STATEMENT.\r
+\r
+\fCTTAB:\r
+ XWD F.NU, F.STR ;NULL , @\r
+ XWD F.STR, F.LETT ; , A\r
+ XWD F.STR, F.LETT ; , B\r
+ XWD F.STR, F.LETT ; , C\r
+ XWD F.STR, F.LETT ; , D\r
+ XWD F.STR, F.LETT ; , E\r
+ XWD F.STR, F.LETT ; , F\r
+ XWD F.STR, F.LETT ; , G\r
+ XWD F.STR, F.LETT ; , H\r
+ XWD F.SPTB, F.LETT ;TAB , I\r
+ XWD F.CR, F.LETT ;LF , J\r
+ XWD F.CR, F.LETT ;VER.TAB, K\r
+ XWD F.CR, F.LETT ;FFEED , L\r
+ XWD F.CR, F.LETT ;CR , M\r
+ XWD F.STR, F.LETT ; , N\r
+ XWD F.STR, F.LETT ; , O\r
+ XWD F.STR, F.LETT ; , P\r
+ XWD F.STR, F.LETT ; , Q\r
+ XWD F.STR, F.LETT ; , R\r
+ XWD F.STR, F.LETT ; , S\r
+ XWD F.STR, F.LETT ; , T\r
+ XWD F.STR, F.LETT ; , U\r
+ XWD F.STR, F.LETT ; , V\r
+ XWD F.STR, F.LETT ; , W\r
+ XWD F.STR, F.LETT ; , X\r
+ XWD F.STR, F.LETT ; , Y\r
+ XWD F.STR, F.LETT ; , Z\r
+ XWD F.ESC, F.STR ;ESC , [\r
+ XWD F.STR, F.STR ; , \\r
+ XWD F.STR, F.STR ; , ]\r
+ XWD F.STR, F.OTH ; , ^\r
+ XWD F.STR, F.OTH ; , _\r
+
\f XWD F.SPTB, F.STR ;SPACE , <ACCENT GRAVE>
\r+ XWD F.STR, F.LETT+F.LCAS ; ! , <LOWER CASE> A\r
+ XWD F.QUOT, F.LETT+F.LCAS ; " , <LOWER CASE> B\r
+ XWD F.STR, F.LETT+F.LCAS ; # , <LOWER CASE> C\r
+ XWD F.DOLL, F.LETT+F.LCAS ; $ , <LOWER CASE> D\r
+ XWD F.STR, F.LETT+F.LCAS ; % , <LOWER CASE> E\r
+ XWD F.OTH, F.LETT+F.LCAS ; & , <LOWER CASE> F\r
+ XWD F.APOS, F.LETT+F.LCAS ; ' , <LOWER CASE> G\r
+ XWD F.OTH, F.LETT+F.LCAS ; ( , <LOWER CASE> H\r
+ XWD F.RPRN, F.LETT+F.LCAS ; ) , <LOWER CASE> I\r
+ XWD F.STAR, F.LETT+F.LCAS ; * , <LOWER CASE> J\r
+ XWD F.PLUS, F.LETT+F.LCAS ; + , <LOWER CASE> K\r
+ XWD F.COMA, F.LETT+F.LCAS ; , , <LOWER CASE> L\r
+ XWD F.MINS, F.LETT+F.LCAS ; - , <LOWER CASE> M\r
+ XWD F.PER, F.LETT+F.LCAS ; . , <LOWER CASE> N\r
+ XWD F.SLSH, F.LETT+F.LCAS ; / , <LOWER CASE> O\r
+ XWD F.DIG, F.LETT+F.LCAS ; 0 , <LOWER CASE> P\r
+ XWD F.DIG, F.LETT+F.LCAS ; 1 , <LOWER CASE> Q\r
+ XWD F.DIG, F.LETT+F.LCAS ; 2 , <LOWER CASE> R\r
+ XWD F.DIG, F.LETT+F.LCAS ; 3 , <LOWER CASE> S\r
+ XWD F.DIG, F.LETT+F.LCAS ; 4 , <LOWER CASE> T\r
+ XWD F.DIG, F.LETT+F.LCAS ; 5 , <LOWER CASE> U\r
+ XWD F.DIG, F.LETT+F.LCAS ; 6 , <LOWER CASE> V\r
+ XWD F.DIG, F.LETT+F.LCAS ; 7 , <LOWER CASE> W\r
+ XWD F.DIG, F.LETT+F.LCAS ; 8 , <LOWER CASE> X\r
+ XWD F.DIG, F.LETT+F.LCAS ; 9 , <LOWER CASE> Y\r
+ XWD F.OTH, F.LETT+F.LCAS ; : , <LOWER CASE> Z\r
+ XWD F.OTH, F.STR ; ; , <LEFT BRACE>\r
+ XWD F.OTH, F.STR ; < , <VERTICAL BAR>\r
+ XWD F.EQAL, F.STR ; = , <RIGHT BRACE>\r
+ XWD F.OTH, F.STR ; > , <TILDE>\r
+ XWD F.STR, F.STR ; ? , <RUBOUT>\r
+\fDEFINE FAIL (A,AC)<\r
+ XLIST\r
+ XWD 001000+AC'00,[ASCIZ /A/]\r
+ LIST\r
+>\r
+\r
+%OPD=1 ;OPDEF UUO COUNTER\r
+DEFINE OPCNT (A)<\r
+%OPD=%OPD+1\r
+IFG %OPD-37,<PRINTX <TOO MANY UUO'S>>\r
+OPDEF A [<%OPD>B8]>\r
+ OPCNT (PRNM)\r
+ OPCNT (PRDL)\r
+ OPCNT (GOSUB)\r
+ OPCNT (ARFET1)\r
+ OPCNT (ARFET2)\r
+ OPCNT (ARSTO1)\r
+ OPCNT (ARSTO2)\r
+ OPCNT (ARSTN1)\r
+ OPCNT (ARSTN2)\r
+ OPCNT (DATA)\r
+ OPCNT (ADATA1)\r
+ OPCNT (ADATA2)\r
+ OPCNT (SDIM)\r
+IFN FTMAT,<\r
+ OPCNT (MATRD)\r
+ OPCNT (MATPR)\r
+ OPCNT (MATSCA)\r
+ OPCNT (MATCON)\r
+ OPCNT (MATIDN)\r
+ OPCNT (MATTRN)\r
+ OPCNT (MATINV)\r
+ OPCNT (MATADD)\r
+ OPCNT (MATSUB)\r
+ OPCNT (MATMPY)\r
+ OPCNT (MATZER)\r
+>\r
+ OPCNT (PRNTB)\r
+IFN FTSTR,<\r
+ OPCNT (STRUUO)\r
+ OPCNT (SVRADR)\r
+ OPCNT (PRSTR)\r
+>\r
+ OPCNT (DONFOR)\r
+ OPCNT (MATINP)\r
+\r
+MAXUUO=%OPD\r
+\r
+UUOHAN: PUSH P,UUOH ;RETURN ADDRS ON PUSH-DOWN LIST\r
+ LDB X1,[POINT 9,40,8]\r
+UUOTBL: JRST .(X1)\r
+\r
+ JRST FAILER\r
+ JRST PRNMER\r
+ JRST PRDLER\r
+ JRST GOSBER\r
+ JRST AFT1ER\r
+ JRST AFT2ER\r
+ JRST AST1ER\r
+ JRST AST2ER\r
+ JRST ASN1ER\r
+ JRST ASN2ER\r
+ JRST DATAER\r
+ JRST ADT1ER\r
+ JRST ADT2ER\r
+ JRST SDIMER\r
+IFN FTMAT,<\r
+ JRST MTRDER\r
+ JRST MTPRER\r
+ JRST MTSCER\r
+ JRST MTCNER\r
+ JRST MTIDER\r
+ JRST MTTNER\r
+ JRST MTIVER\r
+ JRST MTADER\r
+ JRST MTSBER\r
+ JRST MTMYER\r
+ JRST MTZRER\r
+>\r
+ JRST PRNTBR\r
+IFN FTSTR,<\r
+ JRST SUUOEX\r
+ JRST SAD1ER\r
+ JRST PRSTRR\r
+>\r
+ JRST FORCOM\r
+ JRST MATIN\r
+IFN FTSTR,<\r
+SUUOEX:\r
+ LDB X1,[POINT 4,40,12] ;STRING UUOS USE THE AC FIELD\r
+ CAILE X1,MASUUO ;AS AN EXTENSION OF THE OPCODE.\r
+ HALT .\r
+UUOSTR: JRST .(X1)\r
+ JRST GETSTR\r
+ JRST STRCHA\r
+ JRST IFSTR\r
+ JRST SDATAE\r
+ JRST GETVEC\r
+ JRST PUTVEC\r
+MASUUO=.-UUOSTR-1\r
+ OPDEF STRIN [STRUUO 1,] ;33040\r
+ OPDEF STRSTO [STRUUO 2,] ;33100\r
+ OPDEF STRIF [STRUUO 3,] ;33140\r
+ OPDEF STOCHA [STRUUO 4,] ;33200\r
+ OPDEF VECFET [STRUUO 5,] ;33240\r
+ OPDEF VECPUT [STRUUO 6,] ;33300\r
+>;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY\r
+\f;TABLE OF INTRINSIC FUNCTIONS\r
+\r
+IFNFLO:\r
+ Z ABSB+0(SIXBIT / ABS/)\r
+ Z ATANB+0(SIXBIT / ATN/)\r
+ Z COSB+0(SIXBIT / COS/)\r
+ Z COTB+0(SIXBIT / COT/)\r
+ Z DETB+40000(SIXBIT / DET/)\r
+ Z EXPB+0(SIXBIT / EXP/)\r
+ Z INTB+0(SIXBIT / INT/)\r
+ Z LOGB+0(SIXBIT / LOG/)\r
+ Z NUMB+40000(SIXBIT / NUM/)\r
+IFN FTRND,<\r
+ Z RANB+40000(SIXBIT / RND/)\r
+>\r
+ Z SGNB+0(SIXBIT / SGN/)\r
+ Z SINB+0(SIXBIT / SIN/)\r
+ Z SQRTB+0(SIXBIT / SQR/)\r
+ Z TANB+0(SIXBIT / TAN/)\r
+IFNCEI:\r
+\r
+\f;TABLE OF RELATIONS FOR IFSXLA\r
+\r
+DEFINE ZZZ. (X,Y)<\r
+OPDEF ZZZZ. [X]\r
+ ZZZZ. (Y)>\r
+RELFLO: ZZZ. 3435B11,CAML\r
+ ZZZ. 3436B11,CAME\r
+ ZZZ. 74B6,CAMLE\r
+ ZZZ. 3635B11,CAMG\r
+ ZZZ. 75B6,CAMN\r
+ ZZZ. 76B6,CAMGE\r
+RELCEI:\r
+\r
+BASIC: CALLI\r
+ MOVE P,PLIST\r
+ SETOM RENFLA\r
+ SKIPN ONCESW\r
+ JRST BASI1\r
+ SETZM ONCESW\r
+ HLRZ T,JOBSA\r
+ MOVEM T,FLTXT\r
+ MOVEM T,CETXT\r
+ MOVE T,JOBREL\r
+ MOVEM T,FLLIN\r
+ MOVEM T,CELIN\r
+ HRLM T,JOBSA\r
+ HRRZI T,REENTR\r
+ HRRM T,JOBREN\r
+ SETOM 174\r
+ JFOV .+1\r
+ JRST .+1\r
+ JFOV .+2\r
+ SETZM 174\r
+BASI1: PUSHJ P,TTYIN ;SET UP BUFFERS AND INIT TTY\r
+ SKIPE CURNAM\r
+ JRST UXIT\r
+ SETZM RUNFLA\r
+ASKNEW: PUSHJ P,INLMES\r
+ ASCIZ /\r
+NEW OR OLD--/\r
+FIXUP: OUTPUT\r
+ MOVEI X1,OVFLCM ;IGNORE OVFLOW DURING COMMANDS.\r
+ HRRM X1,JOBAPR\r
+ MOVEI X1,10 ;SETUP ARITH OVFLOW TRAP\r
+ CALL X1,[SIXBIT /APRENB/]\r
+ MOVEI X1,TXTROL\r
+ MOVEM X1,TOPSTG ;EDIT TIME. ONLY TXTROL IS STODGY.\r
+ ;OTHER ROLLS MOVE.\r
+ MOVE T,CELIN ;CLOBBER ALL COMPILE ROOLS WITH "CELIN"\r
+ MOVEI X1,LINROL ;PROTECT TXTROL +LINROL FROM CLOBBER:\r
+ PUSHJ P,CLOB\r
+ ;FALL INTO MAINLP\r
+;MAIN LOOP FOR EDITOR/MONITOR\r
+\r
+MAINLP: MOVE P,PLIST\r
+ PUSHJ P,LOCKOF ;TURN OFF REENTR LOCK\r
+ PUSHJ P,INLINE ;READ A LINE\r
+ PUSHJ P,GETNUM ;LOOK FOR SEQUENCE NO\r
+ JRST COMMAN ;NONE. GO INTERPRET COMMAND\r
+ SKIPN CURNAM ;MAKE SURE THERE IS A CURRENT FILE NAME\r
+ JRST ASKNEW\r
+\r
+;HERE, WE HAVE SEQUENCED LINE INPUT. NUMBER IS IN N,\r
+;POINTER TO FIRST CHAR AFTER NUMBER IS IN T\r
+\r
+ PUSHJ P,LOCKON\r
+ PUSHJ P,ERASE\r
+ PUSHJ P,INSERT\r
+ PUSHJ P,LOCKOF\r
+ JRST MAINLP\r
+\r
+;HERE ON COMMAND\r
+\r
+COMMAN: MOVEI R,CMDROL\r
+ TLNE C,F.TERM ;TEST FOR NULL COMMAND\r
+ JRST MAINLP\r
+ PUSHJ P,SCNLT1 ;SCAN COMMAND\r
+ PUSHJ P,SCNLT2\r
+ JRST COMM1 ;SECOND CHAR NOT A LETTER\r
+ PUSHJ P,SCNLT3\r
+ JRST COMM1 ;THIRD CHAR NOT A LETTER\r
+\r
+;NOW THE FIRST THREE LETTERS OF THE COMMAND ARE PACKED IN LH OF A.\r
+\r
+ PUSHJ P,SEARCH ;LOOK FOR COMMAND\r
+ JRST COMM1 ;NOT FOUND\r
+ HRRZ X1,(B)\r
+ SKIPE CURNAM\r
+ JRST COM1\r
+ CAIE X1,OLDER\r
+ CAIN X1,NEWER\r
+ JRST COM1\r
+ JRST ASKNEW\r
+COM1: TRZN X1,40000\r
+ JRST (X1)\r
+ PUSHJ P,QST\r
+ JRST COMM1\r
+ JRST 1(X1)\r
+\f\r
+;DELETE (DEL) ROUTINE\r
+DELER: ASCIZ /ETE/\r
+ TLNE C,F.TERM\r
+ JRST BADDEL\r
+ PUSHJ P,LIMITS\r
+ MOVE A,FRSTLN\r
+ MOVS B,LASTLN\r
+ CAIN B,1\r
+ MOVEM A,LASTLN\r
+ PUSHJ P,DELL1\r
+ JRST N,UXIT\r
+DELL1: MOVE A,FLLIN ;FIND FIRST LINE TO DELETE\r
+DELL2: CAML A,CELIN\r
+ POPJ P, ;TEHRE IS NONE\r
+ HLRZ N,(A) ;GET LINE NO\r
+ CAMLE N,LASTLN ;DONE?\r
+ POPJ P,\r
+ CAMGE N,FRSTLN\r
+ AOJA A,DELL2\r
+ PUSHJ P,LOCKON\r
+ PUSHJ P,ERASE\r
+ PUSHJ P,LOCKOF\r
+ JRST DELL1\r
+\r
+\f;WEAVE COMMAND\r
+WEAER: ASCIZ /VE/\r
+ SETZM BADGNN\r
+ PUSHJ P,FILNAM\r
+ JUMP N,WEAV\r
+ OPEN N,WEAVI\r
+ JRST NOGETD\r
+ LOOKUP FILDIR\r
+ JRST NOGETF\r
+GETT2: INBUF 1\r
+GETT1: PUSHJ P,INLINE+1\r
+ PUSHJ P,GETNUM\r
+ JRST BADGET\r
+ MOVEM N,BADGNN\r
+ PUSHJ P,LOCKON\r
+ PUSHJ P,ERASE\r
+ PUSHJ P,INSERT\r
+ PUSHJ P,LOCKOF\r
+ JRST GETT1\r
+\r
+;LENGTH OF PROGRAM IN CORE.\r
+\r
+LENER: ASCIZ /GTH/\r
+ PUSHJ P,LOCKON\r
+ PUSHJ P,PRESS\r
+ PUSHJ P,LOCKOF\r
+ MOVE T,CETXT\r
+ SUB T,FLTXT\r
+ IMULI T,5\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,INLMES\r
+ ASCIZ / CHARACTERS/\r
+ PUSHJ P,PCRLF\r
+ JRST N,FIXUP\r
+\r
+\f;ROUTINE TO LIST FILE\r
+\r
+LISER: ASCIZ /T/\r
+ SETZI F, ;ASSUME NO HEADINER DESIRED.\r
+ PUSHJ P,QSA\r
+ ASCIZ /NH/\r
+ SETOI F, ;HEADER IS DESIRED, OR CMD ERROR\r
+ PUSHJ P,LIMITS\r
+ JUMPE F,LIST1 ;SKIP HEADING-\r
+ PUSHJ P,INLMES ;NO, PRINT IT.\r
+ ASCIZ /\r
+\r
+/\r
+ PUSHJ P,LIST01 ;TYPE THE HEADING\r
+ PUSHJ P,INLMES ;AND A FEW BLANK LINES\r
+ ASCIZ /\r
+\r
+\r
+\r
+/\r
+ JRST N,LIST1\r
+LIST01: PUSH P,T ;SAVE POINTER TO INPUT LINE\r
+ PUSH P,C ;SAVE CURRENT CHAR.\r
+ HLRZ T,CURDEV\r
+ CAIN T,(SIXBIT /DSK/) ;PRINT DEVICE ONLY IF UNCOMMON.\r
+ JRST LIST02\r
+ HRLZ T,T\r
+ TRO T,320000\r
+ PUSHJ P,PRNSIX ;PRINT THE DEVICE NAME\r
+LIST02: MOVE T,CURNAM\r
+ PUSHJ P,PRNSIX\r
+ HLRZ T,CUREXT ;DONT PRINT EXT. UNLESS UNCOMMON\r
+ CAIN T,(SIXBIT /BAS/)\r
+ JRST LIST03\r
+ TLO T,16 ;INSERT SIXBIT "." BEFORE EXT\r
+ PUSHJ P,PRNSIX\r
+LIST03: PUSHJ P,TABOUT ;EXECUTE A FORMAT ","\r
+ CALL X2,[SIXBIT /TIMER/]\r
+ IDIVI X2,^D3600\r
+ IDIVI X2,^D60\r
+ MOVEI A,":" ;THE SEPARATION CHAR BETWEEN FIELDS.\r
+ PUSHJ P,PRDE2\r
+ PUSHJ P,TABOUT ;ANOTHER FORMAT ","\r
+ CALL X2,[SIXBIT /DATE/]\r
+ IDIVI X2,^D31\r
+ AOJ Q,\r
+ MOVE X1,X2\r
+ IDIVI X1,^D12\r
+ AOJ X2,\r
+ MOVEI A,57\r
+ ADDI X1,^D64\r
+ EXCH X1,X2\r
+ EXCH X2,Q\r
+ PUSHJ P,PRNS2\r
+ POP P,C\r
+ POP P,T\r
+ POPJ P,\r
+LIST1: MOVE A,FLLIN\r
+LIST2: CAML A,CELIN\r
+ JRST N,LIST3\r
+ HLRZ T,(A)\r
+ CAMG T,LASTLN\r
+ CAMGE T,FRSTLN\r
+ AOJA A,LIST2\r
+ PUSHJ P,PRTNUM\r
+LIST25: MOVE T,(A)\r
+ MOVEI D,15 ;QUOTE CHAR\r
+ PUSHJ P,PRINT\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ AOJA A,LIST2\r
+LIST3: CLOSE\r
+ JRST BASIC\r
+NEWER: SETZM OLDFLA ;FLAG WOULD BE -1 FOR "OLD" REQUEST.\r
+ PUSHJ P,INLMES\r
+ ASCIZ /NEW /\r
+ JRST NEWOLD\r
+OLDER: SETOM OLDFLA\r
+ PUSHJ P,INLMES\r
+ ASCIZ /OLD /\r
+NEWOLD: PUSHJ P,INLMES\r
+ ASCIZ /FILE NAME--/\r
+ OUTPUT\r
+ PUSHJ P,INLINE\r
+ PUSHJ P,FILNAM\r
+ JUMP NEWOL1\r
+ SKIPN OLDFLA\r
+ JRST NEWOL2\r
+ OPEN SPEC\r
+ JRST NOGETD\r
+ SKIPE OLDFLA\r
+ JRST NEWOL3\r
+ LOOKUP FILDIR\r
+ JRST NEWOL2\r
+NEWOL3: LOOKUP FILDIR\r
+ JRST NOGETF\r
+NEWOL2: MOVE C,[XWD F.CR,15]\r
+ PUSHJ P,LIMIT1\r
+ PUSHJ P,SCRER1\r
+ PUSHJ P,NAMOVE ;ACCEPT NEW CURRENT FILNAME\r
+ MOVE X1,NEWOL1\r
+ MOVEM X1,CURDEV\r
+ SKIPE OLDFLA\r
+ JRST GETT2 ;OLD FILE. FINISH BY GETTING IT.\r
+ JRST BASIC\r
+ ;ROUTINE TO CHANGE CURRENT NAME\r
+\r
+RENER: ASCIZ /AME/\r
+ TLNN C,F.TERM ;IS THERE A NAME TO RENAME TO?\r
+ JRST N,RENA1 ;YES\r
+ PUSHJ P,INLMES ;PROMPT USER FOR A NAME\r
+ ASCIZ /FILE NAME--/\r
+ OUTPUT\r
+ PUSHJ P,INLINE ;THERE BETTER BE A NAME NOW.\r
+RENA1: PUSHJ P,FILNAM ;REQUEST FOR NEW FILE\r
+ JUMP CURDEV ;SAVE DEVICE IN CURNAM\r
+ TLNN C,F.TERM\r
+ JRST COMM1\r
+ PUSHJ P,NAMOVE ;SET CURINFO FROM FILDIR\r
+ JRST UXIT\r
+ ;ROUTINE TO SAVE NEW COPY OR AN OLD FILE\r
+REPER: ASCIZ /LACE/\r
+ SETOM OLDFLA\r
+ JRST SAVFIL\r
+\f;ROUTINE TO RENUMBER THE BASIC PROGRAM THAT IS IN CORE.\r
+;THE COMMAND IS\r
+; RESEQUENCE NN,MM,LL\r
+;WHERE NN IS THE FIRST NUMBER AND LL IS THE STEP VALUE.\r
+;IF OMITTED, LL, OR BOTH NUMBERS=10\r
+\r
+;ALL LINE NUMBERS LESS THAN MM WILL NOT BE RESEQUENCED. MM MUST NOT\r
+;BE GREATER THAN NN\r
+\r
+;A NUMBER IS A LINE NUMBER IF:\r
+;IT IS THE FIRST ATOM ON A LINE.\r
+; IT FOLLOWS AN ATOM BEGINNING WITH THE LETTERS:\r
+; "GOS" OR "GOT" OR "THE"\r
+;ALSO, AFTER THE ATOM "GOTO" HAS BEEN IDENTIFIED, THE NUMBER\r
+\r
+;FOLLOWING A COMMA IS A LINE NUMBER.\r
+;REENTRY IS NOT ALLOWED DURING "RESEQUENCE".\r
+\r
+RESER: ASCIZ /EQUENCE/\r
+ PUSHJ P,LIMITS\r
+ MOVE LASTLN ;GET THE SECOND NUMBER(::=LOWEST)\r
+ HRRZM N,LOWEST\r
+ MOVEI N,^D10 ;IF FIRST ARG=0, ASSUME FIRST LINE=10\r
+ SKIPN FRSTLN\r
+ MOVEM N,FRSTLN\r
+ TLNN C,F.COMA ;IS THERE A THIRD ARG (THE INCREMENT)?\r
+ JRST RES1 ;NO. LET INCREMENT =^D10\r
+ PUSHJ P,NXCH\r
+ PUSHJ P,GETNUM\r
+ JRST COMM1\r
+RES1: MOVEM N,LASTLN\r
+ HRLZ A,LOWEST ;SEARCH FOR FIRST LINE TO CHANGE\r
+ MOVEI R,LINROL\r
+ PUSHJ P,SEARCH\r
+ JFCL\r
+ CAMN B,FLLIN ;RESEQ ALL LINES?\r
+ JRST SEQ0 ;YES\r
+ HLRZ N,-1(B) ;NO. MAKE SURE LINE ORDER WILL NOT CHANGE\r
+ CAML N,FRSTLN\r
+ JRST RESERR\r
+SEQ0: MOVN X2,B\r
+ ADD X2,CELIN ;THIS IS THE NUMBER OF LINES TO RESEQ\r
+ SUBI X2,1\r
+ IMUL X2,LASTLN\r
+ ADD X2,FRSTLN\r
+ CAILE X2,^D99999\r
+ JRST N,SEQOV\r
+ PUSHJ P,LOCKON ;DONT ALLOW REENTRY.\r
+ MOVE E,CELIN ;COMPUTE NUMBER OF LINES\r
+ SUB E,B\r
+ JUMPE E,UXIT ;NOTHING TO RENUMBER\r
+ MOVN LP,E\r
+ MOVSI LP,(LP)\r
+ SUB B,FLLIN\r
+ MOVEM B,LOWSTA\r
+ HRR LP,B\r
+ PUSH P,LP ;SAVE LP FOR SECOND LOOP.\r
+ HRL B,B\r
+ SUB LP,B\r
+\r
+;THE LOOP THAT COPIES EACH LINE FOLLOWS:\r
+SEQ2: MOVE D,[POINT 7,LINB0] ;BUILD EACH LINE IN LINB0. THEN RESINSERT IT.\r
+ MOVEM D,SEQPNT\r
+ HRRZ F,LP\r
+ ADD F,FLLIN\r
+ HRRZ T,(F)\r
+ HRLI T,440700 ;POINTER TO OLD LINE IS IN G\r
+ ;F USED AS A FLAG REGISTER FOR " ' ETC.\r
+;THE FLAGS ARE\r
+ REST.F=1 ;COPY THE REST (APOST SEEN)\r
+ TOQU.F=2 ;COPY TO QUOTE SIGN\r
+ COMM.F=4 ;LINE NUMBER FOLLOWS ANY COMMA\r
+ NUM.F=10 ;NEXT NUMBER IS LINE NUMBER\r
+\r
+\f;THE CHARACTER/ATOM LOOP:\r
+SEQ3: PUSHJ P,NXCHS ;GET NEXT CHAR, EVEN IF SPACE OR TAB\r
+SEQ31: TLNE C,F.CR\r
+ JRST SEQCR\r
+ TLNE C,F.QUOT ;TEST FOR QUOTE CHAR\r
+ TLCA F,TOQU.F ;REVERSE QUOTE SWITCH AND COPY THIS CHAR\r
+ TLNE F,TOQU.F\r
+ JRST SEQCPY\r
+ TLNE C,F.APOS\r
+ TLOA F,REST.F ;APOST SEEN, COPY REST\r
+ TLNE F,REST.F\r
+ JRST SEQCPY\r
+ MOVE G,T ;SAVE POINTER\r
+ TLNN F,NUM.F ;EXPECTING A LINE NUMBER?\r
+ JRST SEQ4 ;NO. LOOK FOR KEYW ATOMS\r
+ TLNN C,F.DIG\r
+ JRST SEQCPY\r
+ JRST SEQNUM\r
+SEQ4: TLNE F,COMM.F\r
+ TLNN C,F.COMA\r
+ JRST SEQ5\r
+ TLO F,NUM.F ;THIS COMMA IMPLIES NUMBER TO FOLLOW\r
+ JRST SEQCPY\r
+SEQ5: PUSHJ P,ALPHSX ;PUT NEXT ALL-LETTER ATOM IN A\r
+ MOVEI B,SEQTND-SEQTBL ;SET INDEX FOR TABLE OF KEYWORDS PRECEDIING LINE NUMBERS\r
+ MOVE T,G ;RESET CHAR POINTER TO START OF ATOM.\r
+ CAMN A,SEQTBL(B)\r
+ TLOA F,NUM.F+COMM.F ;WE FOUND A KEYBOARD\r
+ SOJGE B,.-2\r
+ LDB C,T\r
+SEQCPY: IDPB C,SEQPNT\r
+ JRST SEQ3\r
+\f\r
+SEQTBL: SIXBIT /GOSUB/\r
+ SIXBIT /GOTO/\r
+SEQTND: SIXBIT /THEN/\r
+\r
+SEQNUM: PUSH P,G ;SAVE POINTER IN CASE OF "GLOBAL" LINE NUMBER\r
+ PUSHJ P,GETNUM\r
+ HALT .\r
+ CAMGE N,LOWEST\r
+ JRST SEQT1 ;DONT RESEQ THIS NUMBER\r
+ MOVEI R,LINROL\r
+ HRLZ A,N\r
+ PUSHJ P,SEARCH\r
+ JRST SEQBAD\r
+ SUB B,FLLIN\r
+ SUB B,LOWSTA\r
+ IMUL B,LASTLN\r
+ ADD B,FRSTLN ;THIS IS THE NEW LINE NUMBER\r
+ MOVE X1,B\r
+ PUSHJ P,MAKNUM ;DEPOSITE THE NUMBER IN LINB0\r
+ POP P,X1 ;CLEAR PLIST A LITTLE\r
+ TLZ F,NUM.F\r
+ LDB C,T\r
+ PUSHJ P,NXCHD\r
+ JRST N,SEQ31\r
+SEQBAD: MOVE T,N\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,INLMES\r
+ ASCIZ / IN LINE /\r
+ HLRZ T,0(7)\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,PCRLF\r
+SEQT1: POP P,1\r
+ LDB C,1\r
+ TLZ F,10\r
+ JRST SEQCPY\r
+\r
+SEQCR: IDPB C,SEQPNT\r
+ HLRZ N,(F)\r
+ PUSHJ P,ERASE ;ERASE OLD LINE COPY\r
+ MOVE T1,SEQPNT ;POINT TO END OF LINE FOR NEWLIN\r
+ PUSHJ P,NEWLIN ;INSERT NEW ONE WITH OLD LINE NUMBER\r
+ AOBJN LP,SEQ2 ;DO NEXT LINE\r
+ POP P,LP\r
+ ADD LP,FLLIN\r
+ MOVE N,FRSTLN\r
+ HRLM N,(LP)\r
+ ADD N,LASTLN\r
+ AOBJN LP,.-2\r
+ JRST N,UXIT ;FINISHED. ALLOW REENTRY.\r
+\r
+SEQOV: PUSHJ P,INLMES\r
+ ASCIZ /COMMAND ERROR (LINE NUMBERS MAY NOT EXCEED 99999)\r
+/\r
+ JRST N,FIXUP\r
+\f;ROUTINE TO SAVE PROGRAM\r
+\r
+SAVER: ASCIZ /E/\r
+ SETZM OLDFLA ;SAVE "NEW" FILE ONLY\r
+SAVFIL: PUSHJ P,FILNAM\r
+SAVER0: JUMP SAVEX\r
+ PUSHJ P,LIMITS\r
+ OPEN SAVI\r
+ JRST NOGETD\r
+ PUSHJ P,LOCKON\r
+ SKIPE OLDFLA\r
+ JRST SAVE1\r
+ LOOKUP FILDIR\r
+ JRST SAVE2\r
+ JRST NOTNEW\r
+SAVE1: LOOKUP FILDIR\r
+ JRST NOGETF\r
+SAVE2: CLOSE\r
+ SETZM N,FILDIR+2\r
+ ENTER FILDIR\r
+ JRST NOSAVE\r
+ OUTBUF 1\r
+ JRST LIST1\r
+\f;ROUTINE TO CLEAR TXTROL.\r
+\r
+SCRER: ASCIZ /ATCH/\r
+ PUSH P,[EXP UXIT]\r
+SCRER1: MOVE X1,FLTXT ;WIPE OUT LINROL AND TXTROL\r
+ MOVEM X1,CETXT\r
+ MOVE X1,FLLIN\r
+ MOVEM X1,CELIN\r
+ POPJ P,\r
+\r
+;ROUTINE TO RETURN TO THE SYSTEM.\r
+\r
+SYSER: ASCIZ /TEM/\r
+ CALLI 12 ;EXIT\r
+\r
+\fSUBTTL COMMAND SUBROUTINES\r
+\r
+;ROUTINE TO PICK UP FILE NAME AND SET UP FOR DSK ACTION.\r
+;THE FLAG COPFLG IS EXPLAINED AT THE COPY ROUTINE COPER.\r
+\r
+\r
+FILNAM: POP P,B ;COPER ENTERS HERE, WITH COPFLG = -1.\r
+ PUSHJ P,FILNMO\r
+FILN7: PUSHJ P,ATOMSX\r
+ MOVEI Q,":"\r
+ CAIE Q,(C)\r
+ JRST N,FILN1\r
+ MOVEM A,@(B)\r
+ JRST N,FILN1A\r
+FILN1: TLNN C,F.PER ;PERIOD SEEN?\r
+ JRST N,FILN2\r
+ JUMPE A,COMM1\r
+ CAIE X2,FILDIR\r
+ JRST N,COMM1\r
+ MOVEM A,FILDIR\r
+ MOVEI X2,FILDIR+1\r
+FILN1A: PUSHJ P,NXCH\r
+ JRST N,FILN7\r
+FILN2: JUMPN A,FILN3\r
+ HRRZ A,B\r
+ CAIN A,SAVER0\r
+ CAIE X2,FILDIR\r
+ JRST N,COMM1\r
+ SKIPN A,CURNAM\r
+ JRST N,COMM1\r
+ MOVEM A,(X2)\r
+ HLLZ A,CUREXT\r
+ HLR A,CURDEV\r
+ PUSHJ P,FILNM1\r
+ CAIA\r
+FILN3: MOVEM A,(X2)\r
+ MOVEI A,DRMBUF\r
+ MOVEM A,JOBFF\r
+ JRST 1(B)\r
+\r
+;ROUTINE TO CONVERT NEXT ATOM TO SIXBIT\r
+\r
+ALPHSX: SKIPA D,[Z (F.LETT)]\r
+ATOMSX: HRLZI D,F.DIG+F.LETT\r
+ TLZ B,777777 ;SET LH OF A+1 TO 0\r
+ MOVEI A,0\r
+ MOVE X1,[POINT 6,A]\r
+ATOMS1: TDNN C,D\r
+ POPJ P,\r
+ PUSHJ P,SCNLTN ;PACK THIS LETTER INTO A.\r
+ JFCL ;SCNLTN HAS SKIP RETURN.\r
+ TLNE X1,770000\r
+ JRST N,ATOMS1\r
+ POPJ P,\r
+FILNMO: MOVEI A,(SIXBIT /DSK/)\r
+ HRLI A,(SIXBIT /BAS/)\r
+FILNM1: HRLZM A,@(B)\r
+ HLLZM A,FILDIR+1\r
+ MOVEI X2,FILDIR\r
+ POPJ P,\r
+\f\r
+NAMOVE: MOVE X1,FILDIR\r
+ MOVEM X1,CURNAM\r
+ MOVE X1,FILDIR+1\r
+ MOVEM X1,CUREXT\r
+ POPJ P,\r
+\r
+;ROUTINES TO SET LINE LIMITS\r
+LIMITS: TLNE C,F.TERM\r
+ JRST LIMIT1\r
+ PUSHJ P,QSA\r
+ ASCIZ /--/\r
+ JRST .+1\r
+ PUSHJ P,GETNUM\r
+LIMIT1: MOVEI N,0\r
+ MOVEM N,FRSTLN\r
+ TLNE C,F.TERM\r
+ JRST LIMIT2\r
+ TLNN C,F.COMA\r
+ JRST N,COMM1\r
+ PUSHJ P,NXCH\r
+ PUSHJ P,GETNUM\r
+LIMIT2: MOVSI N,1\r
+ MOVEM N,LASTLN\r
+ POPJ P,\r
+\r
+\f;A NONPRINTING ROUTINE SIMILAR TO PRTNUM:\r
+\r
+MAKNUM: IDIVI X1,^D10\r
+ JUMPE X1,MAKN1\r
+ PUSH P,X2\r
+ PUSHJ P,MAKNUM\r
+ POP P,X2\r
+MAKN1: MOVEI X2,60(X2)\r
+ IDPB X2,SEQPNT\r
+ POPJ P,\r
+;ROUTINE TO ERASE LINE. LINE NO IN N.\r
+\r
+ERASE: HRLZ A,N ;LOOK FOR LINE\r
+ MOVEI R,LINROL\r
+ PUSHJ P,SEARCH\r
+ POPJ P, ;NONE. GO TO INSERTION\r
+\r
+ MOVE D,(B) ;PICK UP LOC OF LINE\r
+ HRLI D,440700 ;MAKE BYTE POINTER\r
+ MOVEI T1,0 ;TO USE IN DEPOSITING\r
+ERAS1: ILDB C,D ;GET CHAR\r
+ DPB T1,D ;CLOBBER IT\r
+ CAIE C,15 ;CARRIAGE RET?\r
+ JRST ERAS1 ;NO. GO FOR MORE\r
+\r
+ SETOM PAKFLA ;MARK FACT THAT THERE IS A HOLE\r
+\r
+ MOVEI E,1 ;REMOVE ENTRY FROM LINE TABLE\r
+ JRST CLOSUP\r
+\r
+;HERE WE HAVE A LINE OF INPUT AND THERE IS NO EXISTING LINE\r
+\r
+INSERT: MOVE T1,[POINT 7,LINB0]\r
+ MOVE T,G ;RESTORE PNTR TO 1ST CHR\r
+INSE2: ILDB C,T ;GET NEXT CHAR\r
+ CAIN C,15 ;CHECK FOR CAR RET\r
+ JRST N,INSE4\r
+ IDPB C,T1\r
+ JRST N,INSE2\r
+\r
+INSE4: JUMPL T1,CPOPJ ;CR SEEN. DONE IF JUST DELETION\r
+ IDPB C,T1 ;STORE THE CR\r
+ MOVEI C,0 ;CLEAR REST OF WORK\r
+ TLNE T1,760000\r
+ JRST .-3\r
+ JRST N,NEWLIN\r
+\r
+;AT THIS POINT, N CONTAINS A LINE NUMBER AND LINB0 CONTAINS\r
+;A NON-EMPTY INSERTED LINE. T1 CONTAINS ADDRESS OF LAST\r
+;WORD OF THE LINE.\r
+\r
+NEWLIN: MOVEI T1,(T1) ;COMPUTE LINE LENGTH\r
+ SUBI T1,LINB0-1\r
+\r
+ ADD T1,CETXT ;COMPUTE NEW CEILING OF TEXT ROLL\r
+ CAMGE T1,FLLIN ;ROOM FOR LINE PLUS LINROL ENTRY?\r
+ JRST NEWL1 ;YES\r
+ SUB T1,CETXT ;ASK FOR MORE CORE\r
+ MOVE E,T1\r
+ ADDI E,1\r
+ PUSHJ P,PANIC\r
+ ADD T1,CETXT\r
+\r
+NEWL1: MOVE D,CETXT ;LOC OF NEW LINE\r
+ MOVE T,D ;CONSTRUCT BLT PNTR\r
+ HRLI T,LINB0\r
+ BLT T,-1(T1) ;MOVE THE LINE\r
+ MOVEM T1,CETXT ;STORE NEW CEILING\r
+\r
+\r
+;HERE, LINE IS IN PLACE, ITS LOC IN D, LINE NUMBER IN N.\r
+;MUST STILL PUT LINE NUMBER IN LINROL.\r
+\r
+NEWNBR: PUSH P,D ;*****JUST IN CASE*****\r
+ MOVEI R,LINROL\r
+ HRLZ A,N\r
+ PUSHJ P,SEARCH\r
+ JRST .+2\r
+ HALT . ;*****IMPOSSIBLE CONDITION*****\r
+\r
+ MOVEI E,1\r
+ PUSHJ P,OPENUP ;MAKE ROOM FOR IT\r
+ POP P,D ;*****OTHER HALF OF JUST IN CASE*****\r
+ HRRI A,(D) ;CONTRUCT LINROL ENTRY\r
+ MOVEM A,(B) ;STORE ENTRY\r
+ POPJ P, ;ALL DONE\r
+\r
+COMM1: PUSHJ P,INLMES\r
+ ASCIZ /WHAT?\r
+/\r
+COMM1A: SKIPE CURNAM\r
+ JRST FIXUP\r
+ JRST ASKNEW\r
+BADDEL: PUSHJ P,INLMES\r
+ ASCIZ /DELETE COMMAND MUST SPECIFY WHICH LINES TO DELETE\r
+/\r
+ JRST COMM1A\r
+NOSAVE: PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /NO ROOM IN DIRECTORY/\r
+ OUTPUT\r
+ JRST BASIC\r
+NOGETF: PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /FILE NOT SAVED/\r
+ OUTPUT\r
+ JRST BASIC\r
+TTYIN: MOVEI T,TTYBUF ;SET UP TTY BUFFS\r
+ MOVEM T,JOBFF\r
+ INIT 1\r
+ SIXBIT /TTY/\r
+ XWD TYO,TYI\r
+ HALT .-3\r
+ INBUF 1\r
+ OUTBUF 1\r
+ POPJ P,\r
+\r
+BADGET: MOVEI T,BADMSG\r
+ MOVE X1,[POINT 7,BADGNN]\r
+ MOVEM X1,SEQPNT\r
+ MOVE X1,BADGNN ;LAST GOOD LINE NUMBER\r
+ TLNN X1,-1 ;HAS IT BEEN CHANGED ALREADY?\r
+ PUSHJ P,MAKNUM ;NO, MAKE THE NUMBER\r
+ CALL T,[SIXBIT /DDTOUT/]\r
+ MOVEI T,CRLFMS\r
+ CALL T,[SIXBIT /DDTOUT/]\r
+ JRST GETT1\r
+\r
+NOGETD: PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /NO SUCH DEVICE/\r
+ OUTPUT\r
+ JRST BASIC\r
+NOTNEW: PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /DUPLICATE FILE NAME. REPLACE OR RENAME/\r
+ OUTPUT\r
+ JRST BASIC\r
+RESERR: PUSHJ P,INLMES\r
+ ASCIZ /COMMAND ERROR (YOU MAY NOT OVERWRITE LINES OR CHANGE THEIR ORDER)\r
+/\r
+ OUTPUT\r
+ JRST BASIC\r
+RUNER: MOVEI A,0\r
+ CAIA N,QSA ;IS IT RUNNH\r
+ ASCIZ /NH/\r
+ MOVEI A,1 ;NO, PRINT HEADING\r
+ TLNN C,F.TERM ;IS THERE A LINE NUMBER ARGUMENT?\r
+ JRST COMM1\r
+ JUMPE A,RUNNH ;SHALL WE PRINT THE HEADING?\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ PUSHJ P,LIST01 ;PRINT HEADING SANS <RETURN>\r
+ OUTPUT\r
+ PUSHJ P,INLMES\r
+ BYTE (7) 15,12,12\r
+RUNNH: PUSHJ P,LOCKON ;PROTECT REST OF COMPILATION\r
+ PUSHJ P,PRESS ;GUARANTEE SOURCE DOESN'T MOVE!!!\r
+ MOVEI X1,CODROL ;COMPILE TIME.\r
+ MOVEM X1,TOPSTG ;TXT,LIN,CODROLS ARE STODGY. OTHERS MOVE\r
+ MOVEI R,LINROL\r
+ PUSHJ P,SLIDRL ;SLIDE LINROL DOWN NEXT TO TXTROL.\r
+ JRST RUNER1\r
+\r
+SLIDRL: MOVE X2,CEIL(R)\r
+ HRRZ X1,CEIL-1(R) ;SLIDE ROLL DOWN NEXT TO LOWER ROLL\r
+ ADD X2,X1\r
+ HRL X1,FLOOR(R) ;SET UP BLT TO MOVE ROLL\r
+ SUB X2,FLOOR(R)\r
+ HRRZM X1,FLOOR(R) ;SET NEW ROLL FLOOR\r
+ BLT X1,(X2)\r
+ MOVEM X2,CEIL(R)\r
+ POPJ P,\r
+\r
+RUNER1: MOVEM X2,FLCOD\r
+ MOVEM X2,CECOD ;CODROL IS ALSO PACKED IN PLACE\r
+ MOVEI X1,CODROL ;PREPARE TO CLOBBER ALL ROLLS ABOVE CODROL\r
+ MOVE T,JOBREL ;USE THIS VALUE.\r
+ PUSHJ P,CLOB ;DO THE CLOBBERING.\r
+ MOVEI F,0 ;CLEAR COMPILATION FLAGS\r
+ MOVEI T,0 ;SET UP AC FOR RUNTIM.\r
+ CALL T,[SIXBIT /RUNTIM/] ;GETY TIME OF START.\r
+ MOVEM T,MTIME ;SAVE TIME AT START OF RUNER\r
+ MOVEM T,RUNFLA\r
+ SETZM N,DATAFF\r
+ SETOM N,TMPLOW\r
+ MOVEI F,REFROL ;CREATE A ROLL OF ZEROS\r
+ PUSHJ P,ZERROL\r
+\r
+;NOW MARK THIS ROLL TO SHOW WHAT PARTS OF THIS PROG ARE INSIDE OF FUNCTIONS.\r
+LUKDEF: MOVEI A,LUKDEF+1 ;SCAN FOR NEXT "DEF" STA\r
+ PUSHJ P,NXLINE ;PREPARE TO READ THE NEXT LINE\r
+ PUSHJ P,LUKD4\r
+ MOVEI X1,[ASCIZ/DEFFN/]\r
+ PUSHJ P,QST ;IS IT A "DEF" STA?\r
+ JRST N,LUKD3 ;NO. GO ON TO NEXT LINE\r
+\r
+ HRRZ B,C ;YES. SAVE FN NAME.\r
+\r
+ MOVEI A,LUKD2\r
+LUKD1: PUSHJ P,NXCH ;NOW LOOK FOR EQUAL SIGN\r
+ TLNE C,F.TERM\r
+ JRST N,LUKD3 ;NO EQUAL. ITS A MULTILINE DEF.\r
+ TLNN C,F.EQAL\r
+ JRST N,LUKD1 ;TRY NEXT CHAR.\r
+ JRST N,LUKD3-1 ;ITS A ONE LINE DEF. IGNORE IT.\r
+\r
+LUKD2: MOVEI A,LUKD2+2 ;MARK EVERY LINE OF TIS MULTILINE FNT.\r
+ ROT B,-7 ;PUT FUNCTION NAME IN FIRST CHAR POISTION\r
+ PUSHJ P,NXLINE\r
+ MOVEM B,(G) ;NOW THIS LINE CONTAINS THE NAME OF ITS FN.\r
+ PUSHJ P,LUKD4\r
+ MOVEI X1,[ASCIZ /FNEND/]\r
+ PUSHJ P,QST ;END OF THE FN?\r
+ CAIA\r
+ MOVEI A,LUKDEF+1 ;YES. SCAN FOR NEXT DEF.\r
+\r
+LUKD3: AOBJN L,(A) ;GET NEXT LINE, IF THERE IS ONE\r
+ JRST RUNER2\r
+LUKD4: POP P,D\r
+ TLNE C,F.TERM\r
+ JRST LUKD5\r
+ PUSHJ P,QSA\r
+ ASCIZ /REM/\r
+ JRST (D)\r
+LUKD5: AOS (G)\r
+ JRST LUKD3\r
+\r
+;FINISHED MARKING FUN LINES. NOW SET UP A CLEAR LADROL...\r
+RUNER2: MOVEI F,LADROL\r
+ PUSHJ P,ZERROL\r
+ JRST EACHLN\r
+\r
+;ROUTINE TO MAKE A ROLL OF ZEROS =IN LNTH TO LINROL\r
+ZERROL: MOVE R,F\r
+ MOVE E,CELIN ;COMPUTE LENGTH OF ROLL\r
+ SUB E,FLLIN\r
+ JUMPE E,NOEND ;NOTHING TO DO\r
+\r
+ MOVN L,E ;SAVE FOR LINE CNTR.\r
+ MOVSI L,(L)\r
+ PUSHJ P,BUMPRL ;ADD TO (EMPTY) ROLL\r
+ MOVE T,FLOOR(F) ;CLEAR IT TO 0S\r
+ SETZM (T)\r
+ HRL T,T\r
+ ADDI T,1\r
+ MOVE T1,CEIL(F)\r
+ CAILE T1,(T) ;SUPPRESS BLT IF ONLY 1 LINE\r
+ BLT T,-1(T1)\r
+ POPJ P,\r
+\f;SO FAR, WE HAVE SET UP LADROL FOR ADDRESSES & CHAINS FOR LABLES\r
+;ALSO, L IS A WORD TO AOBJN & COUNT THROUGH LINES.\r
+;BEGIN COMPILATION OPERATIONS FOR EACH LINE\r
+\r
+EACHLN: MOVE P,PLIST ;FIX P LIST IN CASE LAST INST FAILED\r
+ PUSHJ P,LOCKOF ;CHECK REENTER REQUEST\r
+ PUSHJ P,LOCKON\r
+ MOVE X1,TMPLOW\r
+ MOVEM X1,TMPPNT ;NO UNPROTECTED TEMPORARIES USED YET.\r
+ SETZM N,LETSW\r
+ SETZM N,REGPNT\r
+ SETZM N,PSHPNT\r
+ SETOM N,IFFLAG\r
+ SKIPE N,FUNAME\r
+ JRST EACHL2\r
+ MOVE X1,FLARG\r
+ MOVEM X1,CEARG\r
+EACHL2: PUSHJ P,NXLINE ;SET UP POINTER TO THIS LINE.\r
+ MOVSI A,(SIXBIT /REM/) ;PREPARE FOR COMMENT\r
+ TLNE C,F.TERM ;NULL STATEMENT?\r
+ JRST EACHL1 ;YES. ELIDED "REM" (FIRST CHAR WAS A APOSTROPHE)\r
+ PUSHJ P,SCNLT1 ;SCAN FIRST LTR\r
+ CAIE C,"("\r
+ TLNE C,F.EQAL+F.DIG+F.DOLL ;ELIDED LETTER?\r
+ JRST ELILET ;YES. POSSIBLE ASSUMED "LET"\r
+ PUSHJ P,SCNLT2 ;SCAN SECOND LETTER.\r
+ JRST ILLINS ;SECOND CHAR WAS NOT A LETTER.\r
+ MOVS X1,A\r
+ CAIE X1,(SIXBIT /IF/)\r
+ CAIN X1,(SIXBIT /ON/)\r
+ JRST EACHL1\r
+ CAIE X1,(SIXBIT /FN/) ;ELIDED LET FNX= ?\r
+ JRST EACHL3 ;NO.\r
+ PUSHJ P,SCNLT3\r
+ JRST N,ILLINS\r
+ TLNE C,F.EQAL ;IS FOURTH CHAR AN '=' SIGN?\r
+ JRST ELILET ;YES, ELIDED STATEMENT\r
+ JRST EACHL1 ;NO, BETTER BE FNEND.\r
+\r
+EACHL3: PUSHJ P,SCNLT3 ;ASSEMBLE THIRD LETTER OF STATEMENT IN A\r
+ JRST ILLINS ;THIRD CHAR WAS NOT A LETTER\r
+ JRST EACHL1\r
+\r
+ELILET: MOVSI A,(SIXBIT /LET/) ;ASSUME A "LET" STATMENT.\r
+ MOVS T,D ;GO BACK TO THE FIRST LETTER.\r
+ HRLI T,440700\r
+ PUSHJ P,NXCHK\r
+\r
+;HERE, FIRST 3 LTRS OF VERB (SIXBIT) ARE IN A. USE TBL LOOKUP AND DISPATCH.\r
+\r
+EACHL1: MOVEI R,STAROL\r
+ PUSHJ P,SEARCH ;LOOK IN STATEMENT TYPE TABLE\r
+ JRST ILLINS ;NO SUCH, GO BITCH\r
+ HRRZ A,(B) ;FOUND.\r
+\r
+ MOVE Q,CECOD ;PUT REL ADDRS IN LADROL\r
+ SUB Q,FLCOD\r
+ MOVE X2,FLLAD\r
+ ADDI X2,(L)\r
+ HRLM Q,(X2)\r
+ HRLI D,(MOVEI L,)\r
+ TRZE A,20000 ;EXECUTABLE?\r
+ PUSHJ P,BUILDI\r
+\r
+ MOVE X1,A\r
+ TRZN X1,40000 ;MORE TO COMMAND?\r
+ SOJA X1,EACHL5 ;NO. JUST DISPATCH\r
+ PUSHJ P,QST ;CHECK REST OF COMMAND\r
+ JRST ILLINS\r
+\r
+EACHL5: TLNE C,1000\r
+ FAIL <ILLEGAL CHARACTER>\r
+ JRST 1(X1)\r
+;HERE ON END OF STATEMENT XLATION\r
+\r
+NXTSTA: TLNN C,F.TERM\r
+ JRST GRONK\r
+\r
+\r
+;ENTER HERE FROM ERROR ROUTINE\r
+\r
+NXTST1: AOBJN LP,EACHLN\r
+NOEND: PUSHJ P,INLMES\r
+ ASCIZ /\r
+NO END INSTRUCTION\r
+/\r
+\r
+UXIT: SETZM RUNFLA\r
+ SKIPE MTIME\r
+ PUSHJ P,PTIME\r
+ PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+READY\r
+/\r
+ JRST N,FIXUP\r
+\fSUBTTL PROGRAM "LOADER"\r
+;HERE AFTER END STATEMENT\r
+\r
+LINKAG: MOVEI R,CONROL ;SLIDE RUNTIME ROLLS DOWN INTO PLACE.\r
+ PUSHJ P,SLIDRL\r
+ CAIGE R,TMPROL\r
+ AOJA R,.-2 ;SLIDE NEXT ROLL\r
+ MOVEM X2,VARFRE ;FIRST FREE LOC IS CEIL OF TMPROL.\r
+\r
+ MOVE E,CETMP ;CHECK ARRAY REQUIREMENTS\r
+ MOVE T,FLARA\r
+ JRST LK2A\r
+\r
+LK1: HLRZ X1,(T) ;KNOW SIZE?\r
+ JUMPN X1,LK2 ;YES, JUMP\r
+ MOVSI X2,^D11 ;(11,1) IS STANDARD DIM.\r
+ AOJ X2,\r
+ MOVEI X1,^D11\r
+ MOVE Q,1(T)\r
+ CAMGE T,FLSVR ;DEFAULT SIZE OF STRING VECTORS IS (11,1)\r
+ AOJE Q,.+2 ;IMPLICIT 2-DIM ARRAY?\r
+ JRST N,.+3\r
+ HRRI X2,^D11\r
+ MOVEI X1,^D121\r
+ MOVEM X2,1(T)\r
+ HRLM X1,(T) ;STORE SIZE\r
+LK2: ADD E,X1 ;ADD LENGTH TO IT\r
+ ADDI T,2 ;ON TO NEXT ENTRY\r
+ CAMG T,FLSVR ;IS THIS ONE A STRING VECTOR?\r
+ JRST LK2A ;NO.\r
+ HLRZ X2,-1(T) ;LOOK AT FIRST DIMENSION\r
+ SOJLE X2,LK2A ;IS IT 1(AND THUS A VECTOR)?\r
+ HRRZ X2,-1(T) ;NO. LOOK AT SECOND DIMENSION\r
+ SOJLE X2,LK2A ;IS IT 1(AND THUS A VECTOR)?\r
+ SETZM RUNFLA ;NO. FATAL ERROR.\r
+ PUSHJ P,INLMES\r
+ ASCIZ /STRING VECTOR IS 2-DIM ARRAY\r
+/\r
+LK2A: CAMN T,FLSVR ;BEGINNING OF SVRROL SCAN?\r
+ MOVEM E,SVRBOT ;YES, REMEMBER BOTTOM OF VECTOR POINTERS\r
+ CAMGE T,CESVR\r
+ JRST LK1\r
+\r
+ SETOM VPAKFL ;DONT TRY TO PRESS VARAIBLE SPACE NOW!\r
+ SUB E,CESVR ;WE NEED THIS MANY LOCS\r
+ PUSHJ P,VCHCK1\r
+ ADD E,CETMP ;CALCULATE TOP OF ARRAY SPACE.\r
+ MOVEM E,SVRTOP ;SAVE IT.\r
+ MOVEM E,VARFRE ;THIS IS ALSO FIRST FREE WORD.\r
+\r
+ MOVE T,FLFCL\r
+ MOVEI R,FCNROL\r
+LINK0A: CAML T,CEFCL\r
+ JRST LINK0C ;NO MORE FCN CALLS\r
+ HLLZ A,(T) ;LOOK UP FUNCTION\r
+ PUSHJ P,SEARCH\r
+ JRST LINK0B ;UNDEFINED\r
+ MOVE A,(B) ;DEFINED. GET ADDRESS.\r
+ HRLM A,(T)\r
+ AOJA T,LINK0A\r
+\fLINK0B: SETZM RUNFLA\r
+ PUSHJ P,INLMES\r
+ ASCIZ /UNDEFINED FUNCTION -- FN/\r
+ LDB C,[POINT 7,A,6]\r
+ ADDI C,40\r
+ PUSHJ P,OUCH\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ AOJA T,LINK0A\r
+LINK0C: MOVE B,FLFOR ;UNSAT FORS?\r
+ CAML B,CEFOR\r
+ JRST LINK0D\r
+ MOVEI T,[ASCIZ /FOR WITHOUT NEXT/]\r
+ MOVE L,(B) ;GET POINTER TO LINE NUMBER\r
+ PUSHJ P,FAILR ;PRINT ERROR MSG\r
+ ADDI B,5 ;MORE UNSAT FORS?\r
+ JRST LINK0C+1\r
+LINK0D: SKIPG DATAFF\r
+ JRST LINK0E\r
+ PUSHJ P,INLMES\r
+ ASCIZ /NO DATA/\r
+ SETZM RUNFLA\r
+LINK0E: SKIPN RUNFLA ;GO INTO EXECUTION?\r
+ JRST UXIT ;NO\r
+\r
+ MOVE C,FLCOD\r
+\r
+;CODE ROLL IS IN PLACE. C CONTAINS ITS FLOOR\r
+\r
+ MOVE T,FLFCL ;LINK FCN CALLS\r
+ MOVE T1,CEFCL\r
+ MOVE A,FLCOD\r
+ MOVEI B,0\r
+ PUSHJ P,LINKUP\r
+\r
+ MOVE T,FLARA ;LINK ARRAY REFS\r
+ MOVE T1,CESVR\r
+ MOVE A,T\r
+ MOVEI B,2\r
+ PUSHJ P,LINKUP\r
+\r
+ MOVE T,FLARA ;STORE ARRAY ADDRESSES IN APAROL\r
+ MOVE G,CETMP\r
+ JRST N,LINK1D\r
+LINK1C: HLRZ X1,(T) ;GET ARRAY LENGTH\r
+ HRRM G,(T) ;STORE ABS ADDRS\r
+ ADD G,X1 ;COMPUTE ADDRS OF NEXT ARRAY\r
+ ADDI T,2 ;GO TO NEXT ENTRY\r
+LINK1D: CAMGE T,T1\r
+ JRST N,LINK1C\r
+\r
+LINK1: MOVE T,FLCAD ;LINK CONST REFS\r
+ MOVE T1,CECAD\r
+ MOVE A,FLCON\r
+ MOVEI B,1\r
+ PUSHJ P,LINKUP\r
+\r
+LINK2: MOVE T,FLPTM ;LINK TEMPORARY REFS (PERM AND TEMP)\r
+ MOVE T1,CETMP\r
+ MOVE A,T\r
+ MOVEI B,1\r
+ PUSHJ P,LINKUP\r
+\r
+LINK3: MOVE T,FLLAD ;LINK GOTO DESTINATIONS\r
+ MOVE T1,CELAD\r
+ MOVE A,FLCOD\r
+ MOVEI B,0\r
+ PUSHJ P,LINKUP\r
+\r
+LINK4: MOVE T,FLSCA ;LINK SCALARS\r
+ MOVE T1,CEVSP\r
+ MOVE A,T\r
+ MOVEI B,1\r
+ PUSHJ P,LINKUP\r
+\r
+LINK6: MOVE T,FLGSB ;LINK GOSUB REFS\r
+ MOVE T1,CEGSB\r
+ MOVE A,T\r
+ MOVEI B,1\r
+ PUSHJ P,LINKUP\r
+ MOVE T,FLGSB\r
+LINK7: CAML T,T1 ;PUT SUBRTN ADDRSES IN GSBROL\r
+ JRST N,LINK8\r
+ HLRZ X1,(T)\r
+ ADD X1,FLLAD\r
+ HLRZ X1,(X1)\r
+ ADD X1,C\r
+ MOVEM X1,(T)\r
+ AOJA T,LINK7\r
+\r
+LINK8: MOVE T,FLNXT ;LINK REVERSE REFS IN FORS\r
+ MOVE T1,CENXT\r
+ MOVE A,FLCOD\r
+ MOVEI B,0\r
+ PUSHJ P,LINKUP\r
+\r
+ MOVE T,FLSAD ;LINK POINTERS TO LITROL\r
+ MOVE T1,CESAD\r
+ MOVE A,FLLIT\r
+ MOVEI B,1\r
+ PUSHJ P,LINKUP\r
+\r
+LINKZ: MOVE X1,FLSCA ;ZERO OUT SCALARS AND STRING VARS\r
+ MOVE X2,CEVSP\r
+ PUSHJ P,BLTZER\r
+ MOVE X1,CETMP ;ZERO OUT ARRAY ELEMENTS AND STRING VECTORS.\r
+ MOVE X2,SVRTOP\r
+ PUSHJ P,BLTZER\r
+\r
+ SETZM N,FMTPNT\r
+ SETZM N,FCNLNK\r
+ PUSHJ P,RESTOR\r
+ MOVEI R,0\r
+ PUSHJ P,PCRLF\r
+ PUSHJ P,PCRLF\r
+ SETZM N,INPFLA\r
+ SETZM N,TABVAL\r
+ SETOM N,NUMRES\r
+ SETZB N,STRFCN\r
+IFN FTRND,<\r
+ PUSHJ P,WRANB\r
+>\r
+ MOVEI X1,OVTRAP\r
+ HRRM X1,JOBAPR\r
+ PUSHJ P,LOCKOF\r
+ JRST N,@FLCOD\r
+\r
+;SUBROUTINE TO LINK ROLL ENTRIES\r
+\r
+;CALL WITH A=ORG OF VALUE ROLL, B=INCREMENT (0 IF EXPLICIT REL LOC)\r
+;T=FLOOR OF SRC ROLL, T1=CEIL OF SRC ROLL\r
+\r
+\r
+LINKUP: MOVE X2,A\r
+ MOVSI X1,C\r
+\r
+LNKP1: CAML T,T1 ;FINISHED ROLL?\r
+ POPJ P,\r
+ HRRZ Q,(T) ;FIRST LOC IN CHAIN\r
+ JUMPN B,.+3 ;EXPLICIT ADDRS?\r
+ HLRZ X2,(T) ;YES. COMPUTE IT\r
+ ADD X2,C\r
+ JUMPE Q,LNKP3 ;SPECIAL CASE--CHAIN VOID\r
+\r
+LNKP2: HRR X1,Q ;ONE LINK IN CHAIN\r
+ HRRZ Q,@X1\r
+ HRRM X2,@X1\r
+ JUMPN Q,LNKP2\r
+\r
+LNKP3: JUMPN B,.+2 ;EXPLICT ADDRS?\r
+ AOJA T,LNKP1 ;YES, JUST BUMP ROLL PNTR\r
+ ADD T,B ;NO, ADD EXPLICIT INCREMENT\r
+ ADD X2,B ; (ALSO TO DEST ROLL)\r
+ JRST N,LNKP1\r
+\r
+BLTZER: HRL X1,X1 ;ZERO OUT CORE\r
+ SETZM N,(X1)\r
+ AOJ X1,\r
+ BLT X1,-1(X2)\r
+ POPJ P,\r
+\f\r
+IFN FTSTR,<\r
+;CHANGE STATEMENT\r
+\r
+; CHANGE <VECTOR> TO <STRING>\r
+; OR\r
+;CHANGE <STRING> TO <VECTOR>\r
+\r
+;COMPILES A FETCH AND PUT WHICH INTERFACE WITH THE "PUTSTR" ROUTINE\r
+>\r
+\r
+XCHAN: ASCIZ /NGE/ ;CHANGE?\r
+ HRLI F,1\r
+ TLNE C,40\r
+ JRST XCHAN1\r
+ PUSHJ P,VECTOR\r
+ CAIN A,4\r
+ JRST GRONK\r
+ JUMPE A,.+3\r
+ PUSHJ P,FLET2\r
+ JRST XCHAN3\r
+ MOVSI D,(VECFET)\r
+ PUSHJ P,BUILDA\r
+ PUSHJ P,QSF\r
+ ASCIZ /TO/\r
+ PUSHJ P,FORMLB\r
+ MOVSI D,(STRSTO)\r
+XCHAN2: SKIPE N,IFFLAG\r
+ JRST ILFORM\r
+ PUSHJ P,BUILDA\r
+ JRST NXTSTA\r
+XCHAN1: PUSHJ P,FORMLB\r
+XCHAN3: PUSHJ P,FLET3\r
+ PUSHJ P,QSF\r
+ ASCIZ /TO/\r
+ PUSHJ P,VECTOR\r
+ MOVSI D,(VECPUT)\r
+ JRST XCHAN2\r
+\f;DATA STATEMENT\r
+\r
+;<DATA STA>::= DATA <DEC NBR!STRING> [,<DEC NBR!STRING>...]\r
+\r
+;NOTE: A DATA STRING ::= " <ANY CHARS EXCEPT CR,LF> "\r
+; OR ::= <A LETTER><ANY CHARS EXCEPT COMMA OR APOST,CR,LF>\r
+\r
+;NO CODE IS GENERATED FOR A DATA STATEMENT\r
+;RATHER, THE DATA STATEMENT IN THE SOURCE\r
+;TEXT ARE REREAD AT RUN TIME.\r
+\r
+XDATA: ASCIZ /A/\r
+ SKIPL DATAFF ;ALREADY SEEN DATA?\r
+ MOVEM L,DATAFF ;NO. REMEMBER WHERE FIRST ONE IS\r
+ PUSHJ P,DATCHK\r
+ FAIL <DATA NOT IN CORRECT FORM>\r
+ JRST NXTSTA\r
+\r
+;SUBROUTINE TO CHECK DATA LINE\r
+;ALSO CALLED AT RUN TIME TO CHECK INPUT LINE\r
+;(NOTE.. <RETURN> NOT CHECKED AFTER INPUT LINE)\r
+\r
+\r
+DATCHK: TLNN C,F.LETT+F.QUOT ;LETTER OR QUOT SIGN FIRST\r
+ JRST DATCH2 ;NO, EVALUATE NUMBER\r
+ PUSH P,[DATCH3] ;YES, ASSUME STRING AND SKIP OVER\r
+ JRST N,SKIPDA\r
+DATCH2: PUSHJ P,EVANUM\r
+DATCH3: POPJ P,\r
+ CAIE C,"&" ;IF "&", ASSUME MATINPUT TERM\r
+ TLNE C,F.TERM ;MORE?\r
+ JRST CPOPJ1 ;NO. RETURN\r
+ TLNN C,F.COMA ;DID FIELD END CORRECTLY?\r
+ POPJ P, ;NO ERROR\r
+ PUSHJ P,NXCH ;YES. SKIP COMMA\r
+ JRST N,DATCHK\r
+\f;DEF STATEMENT\r
+\r
+;<DEF STA> ::= DEF FN<LETTER>(<ARGUMENT>) = <EXPRESSION>\r
+\r
+;GENERATED CODE IS:\r
+; JRST <A> ;JUMP AROUND DEF\r
+; XWD 0,0 ;CONTROL WORD\r
+; MOVEM N,(B) ;SAVE ARGUMENT IN TEMPORARY\r
+; ...\r
+; (EVALUATE EXPRESSION)\r
+; JRST RETURN ;GO TO RETURN SUBROUTINE\r
+;<A>: ... ;INLINE CODING CONTINUES...\r
+\r
+;SEE GOSUB STATEMENT FOR USE OF CONTROL WORD.\r
+\r
+;DURING EXPRESSION EVALUATION, LOCATION\r
+;FUNARG CONTAINS ASCII REPRESENTATION OF ARGUMENT NAME.\r
+;ROUTINES CALLED BY FORMLN CHECK FOR USE OF ARGUMENT AND RETURN POINTER\r
+;TO FIRST WORD ON TEMPORARY ROLL.\r
+\r
+;PRIOR TO GEN OF FIRST EXPRESSION EVALUATION, THE "REAL" TEMPORARY\r
+;ROLL IS SAVED ON "STMROL" AND AN EMPTY "TEMROL" IS CREATED.\r
+;AFTERWARDS, THE NEW "TEMROL" ENTRIES ARE ADDED TO THE PERMANENT\r
+;TEMPORARY ROLL "PTMROL" AND "TEMROL" IS RESTORED.\r
+;THUS EACH DEFINED FUNCTION HAS ITS OWN SET OF TEMPORARIES\r
+;AND CANNOT CONFLICT WITH TEMPORARIES USED BY THE EXPRESSION\r
+;BEING EVALUATED AT THE POINT OF THE CALL.\r
+\r
+;NOTE. SPECIAL CASE: CHECK FOR FUNCTION DEF AS LAST LINE OF PROGRAM\r
+;SUPPRESSES GEN OF "JRST" INSTR. COMPILATION WILL FAIL\r
+;("NO END STATEMENT"); HOWEVER THE WORD AFTER LADROL WOULD BE\r
+;CLOBBERED IF "JRST" WERE GENNED.\r
+\r
+XDEF: ASCIZ /FN/ ;HANDLE THE FN PART AUTOMATICALLY\r
+ SKIPE FUNAME ;ARE WE IN MIDST OF MULTI-LINE DEF?\r
+ FAIL <NESTED DEF>\r
+ MOVSI D,(JFCL) ;MAKE SURE NOT FIRST WRD OF CODE\r
+ MOVE X1,CECOD\r
+ CAMG X1,FLCOD\r
+ PUSHJ P,BUILDI\r
+ TLNN C,F.LETT ;MAKE SURE LETTER FOLLOWS\r
+ JRST GRONK\r
+ PUSHJ P,SCNLT1 ;SCAN FCN NAME.\r
+ PUSH P,A ;SAVE FCN NAME WITH COUNT OF ZERO ARGUMENTS\r
+ MOVEM A,FUNAME ; FN'NAME IN BODY OF FUNCTION\r
+\f;ADD FUNCTION NAME TO FCNROL\r
+\r
+ MOVEI R,FCNROL ;LOOK FOR FNC NAME IN FCNROL\r
+ PUSHJ P,SEARCH\r
+ JRST .+2\r
+ FAIL <FUNCTION DEFINED TWICE>\r
+ MOVEI E,1 ;ADD TO FCNROL\r
+ PUSHJ P,OPENUP\r
+ ADD A,CECOD ;CONSTRUCT PNTR TO CONTROL WORD\r
+ SUB A,FLCOD ;STORE IN FCNROL ENTRY.\r
+ ADDI A,1\r
+ MOVEM A,(B)\r
+\r
+ MOVE B,L ;GET JRST DESTINATION\r
+ AOBJP B,.+1 ;DONT GEN JRST IF LAST LINE OF SOURCE.\r
+ MOVSI D,(JRST)\r
+ PUSHJ P,BUILDI ;GEN JRST INSTR.\r
+ MOVEM B,FUNSTA ;REMEMBER WHERE THIS JRST IS\r
+ MOVEI D,0 ;BUILD ZERO CONTROL WORD\r
+ PUSHJ P,BUILDI\r
+\r
+;SCAN FOR ARGUMENT NAME.\r
+\r
+ CAIE C,"(" ;ANY ARGUMENTS?\r
+ JRST XDEF4 ;NO\r
+\r
+XDEF2: PUSHJ P,NXCHK ;SKIP "("\r
+ PUSHJ P,SCNLT1 ;ASSEMBLE ARGUMENT NAME\r
+ TLNN C,F.DIG\r
+ JRST .+3\r
+ DPB C,[POINT 7,A,13]\r
+ PUSHJ P,NXCHK\r
+\r
+ MOVEI R,ARGROL ;NOW ADD THIS NAME TO THE ARGUMENT LIST\r
+ MOVE B,FLARG ;NOW CHECK ARGROL, FOR TWO IDENTICAL ARGS\r
+XDEF2C: CAML B,CEARG\r
+ JRST N,XDEF2D\r
+ CAMN A,(B)\r
+ JRST GRONK\r
+ AOJA B,XDEF2C\r
+\r
+XDEF2D: MOVEI E,1 ;ADD NEW ARG TO ROLL\r
+ PUSHJ P,OPENUP\r
+ MOVEM A,(B)\r
+ AOS (P) ;COUNT THE ARGUMENT\r
+ TLNE C,F.COMA ;ANY MORE ARGS?\r
+ JRST XDEF2 ;YES\r
+\r
+ TLNN C,F.RPRN ;FOLLOWING PARENTHESIS?\r
+ JRST GRONK ;NO.\r
+ PUSHJ P,NXCHK ;YES. SKIP IT.\r
+XDEF4: PUSHJ P,ARGCHK ;CHECK FOR RIGHT NUMBER OF ARGUMENTS\r
+;GEN CODE TO EVALUATE EXPRESSION.\r
+\r
+ MOVE X1,FLTMP ;SAVE TEMP ROLL AS STMROL\r
+ MOVEM X1,FLSTM\r
+ MOVEM X1,CETMP ;AND EMPTY TMPROL\r
+ MOVE X1,TMPLOW ;SAVE TEMP POINTER\r
+ MOVEM X1,FUNLOW\r
+ SETOM TMPLOW\r
+ SETOM TMPPNT\r
+ TLNN C,F.EQAL ;MULTI LINE FN?\r
+ JRST N,XDEFM ;YES\r
+ PUSHJ P,NXCHK ;NO. SKIP EQUAL SIGN\r
+ SETZM N,FUNAME ;SIGNAL THAT THIS IS NOT A MULTI-LINE FN\r
+\r
+ PUSHJ P,FORMLN ;GET THE EXPRESSION\r
+ PUSHJ P,EIRGNP\r
+\r
+;NOW BUILD AN INSTRUCTION THAT WILL TELL RETURN HOW MANY ARGS TO POP\r
+;OFF THE PUSH LIST\r
+\r
+ POP P,B ;ARGCHK PUT THE ADDRESS OF A CONSTANT IN HERE\r
+XDEFE: MOVSI D,(MOVE T,)\r
+ PUSHJ P,BUILDA\r
+ MOVE X2,CETMP ;RESTORE TMPROL, SAVE TEMPORARIES FOR FNC\r
+ MOVE Q,CESTM\r
+ MOVEM X2,CEPTM\r
+ MOVEM X2,FLTMP\r
+ MOVEM Q,CETMP\r
+ MOVEM Q,FLSTM\r
+\r
+ HRRE X1,FUNLOW ;RESTORE TMPLOW\r
+ MOVEM X1,TMPLOW\r
+ HRRZ X1,FUNSTA ;-1(X1) IS LOC OF JRST AROUND FUNCTION\r
+ ADD X1,FLCOD\r
+ HRRZ X2,CECOD ;JRST TO THE NEXT INST TO BE CODED\r
+ ADDI X2,1\r
+ HRRM X2,(X1)\r
+ MOVE D,[JRST N,FRETRN]\r
+ JRST N,XRET1 ;USE RETURN CODE TO BUILD INST\r
+\r
+XDEFM: POP P,X1 ;MULTI-LINE DEF. SAVE THE ARGCOUNT PARAMETER FOR FNEND\r
+ HRLM X1,FUNSTA\r
+ MOVE X1,CEFOR ;SAVE NUMBER OF ACTIVE FORS\r
+ SUB X1,FLFOR ;FOR A CHECK OF FORS HALF IN DEF\r
+ HRLM X1,FUNLOW\r
+ JRST NXTSTA\r
+\f;DIM STATEMENT\r
+;<DIM STA> ::= DIM <LETTER>[$](<NUMBER>[,<NUMBER>])[,<LETTER>[$](<NUMBER>[,<NUMBER>])...]\r
+\r
+;FOR EACH ARRAY, HAVE ONE-WORD ENTRY IN VARROL\r
+;WHICH POINTS TO THREE-WORD ENTRY IN ARAROL\r
+;WHOSE FORMAT IS:\r
+; (<LENGTH OF ARRAY>)<PNTR>\r
+; (<LEFT DIM>+1)<RIGHT DIM>+1\r
+;THE THIRD WORD IS < 0 IF THE MATRIX IS SET EQUAL TO ITS OWN TRN,\r
+;>0 IF THIS IS THE FAKE MATRIX USED FOR TMP STORAGE DURING MATA=\r
+;TRN(A), OTHERWISE IT IS 0.\r
+\r
+;DURING COMPILATION, <PNTR> IS CHAIN OF REFERENCES.\r
+;DURING EXECUTION, <PNTR> IS ADDRS OF FIRST WORD.\r
+\r
+XDIM: SETZI F, ;ALLOW STRING VECTORS.\r
+ PUSHJ P,ARRAY ;REGISTER ARRAY NAME\r
+ CAIE A,5 ;STRING VECTOR? ELSE..\r
+ JUMPN A,GRONK ;NON-0 RESULT FLAG-SYNTAX ERROR.\r
+ CAIE C,"(" ;CHECK OPENING PAREN\r
+ JRST GRONK\r
+ ADD B,FLOOR(F) ;COMPUTE LOC OF ROLL ENTRY\r
+ SKIPLE 1(B) ;DIMENSION FLAG SHOULD BE 0 OR -1 OR -2\r
+ FAIL <VARIABLE DIMENSIONED TWICE>\r
+ PUSHJ P,NXCHK ;SKIP PARENTHESIS\r
+ PUSHJ P,GETNU ;FIRST DEMENSION\r
+ JRST GRONK ;NOT A NUMBER\r
+ HRRZ D,N ;SAVE FIRST DIM\r
+ AOBJN D,.+1 ;D::= XWD <FIRST DIM+1>,1\r
+ MOVEM D,1(B) ;STORE IN ARAROL (IN CASE 1 DIM)\r
+ MOVEI N,1 ;IN CASE ONE DIMENSION\r
+ TLNN C,F.COMA ;TWO DIMS?\r
+ JRST N,XDIM1 ;NO\r
+ PUSHJ P,NXCHK ;YES. SKIP COMMA.\r
+ JUMPN A,GRONK ;STRING VECTOR HAS TWO DIMS?\r
+ PUSHJ P,GETNU ;GET SECOND DIM\r
+ JRST GRONK ;NOT A NUMBER\r
+ ADDI N,1\r
+ HRL D,N ;NOW D HAS XWD <COLS+1>,<ROWS+1>\r
+ MOVSM D,1(B) ;STORE IN ROLL SWAPPED\r
+XDIM1: IMULI N,(D) ;COMPUTE LENGTH OF ARRAY\r
+ HRLM N,0(B) ;STORE IN ROLL\r
+\r
+ TLNN C,F.RPRN ;CHECK CLOSING PAREN\r
+ JRST GRONK\r
+ PUSHJ P,NXCHK ;LOOK FOR COMMA\r
+ TLNN C,F.COMA\r
+ JRST NXTSTA ;NO. DONE WITH THIS STATEMENT.\r
+ PUSHJ P,NXCHK ;SKIP THE COMMA.\r
+ JRST XDIM\r
+\f;END STATEMENT\r
+\r
+;<END STA> ::= END\r
+\r
+XEND: MOVE X1,FLLIN ;CHECK THAT IT IS LAST STA\r
+ ADDI X1,1(L)\r
+ CAME X1,CELIN\r
+ FAIL <END IS NOT LAST>\r
+\r
+ MOVE D,[JRST UXIT] ;COMPILE TERMINAL EXIT\r
+ PUSHJ P,BUILDI\r
+ JRST LINKAG ;GO FINISH UP AND EXECUTE\r
+\f;FOR STATEMENT\r
+\r
+;CALCULATE INITIAL, STEP, AND FINAL VALUES\r
+;\r
+;SET INDUCTION VARIABLE TO INITIAL VALUE\r
+;AND JUMP TO END IF IND VAR > FINAL\r
+;INCREMENTING IS HANDLED AT CORRESPONDING NEXT.\r
+\r
+;FIVE WORD ENTRY PLACED ON FORROL FOR USE\r
+;BY CORRESPONDING NEXT STATEMENT:\r
+\r
+; CURRENT VALUE OF L (FOR "FOR WITHOUT NEXT" MESSAGE)\r
+;<REL. ADRS IN CODROL OF JUST TO END OF-NEXT>\r
+; <POINTER TO INDUCTION VARIABLE>\r
+; <POINTER TO INCREMENT>\r
+; <CURRENT VALUE OF TMPLOW>\r
+\r
+\r
+XFOR: TLNN C,F.LETT ;MAKE SURE VARIABLE IS FIRST.\r
+ JRST GRONK\r
+ MOVE A,L ;SAVE L FOR POSSIBLE ERROR MSG\r
+ MOVEI R,FORROL\r
+ PUSHJ P,RPUSH\r
+ PUSHJ P,REGLTR ;REGISTER ON SCAROL\r
+ CAIN A,1 ;BETTER BE SCALAR\r
+ TLNN C,F.EQAL ;BETTER HAVE EQUAL\r
+ JRST GRONK\r
+ PUSHJ P,NXCHK ;SKIP EQUAL SIGN.\r
+ PUSH P,B ;SAVE THE VARIABLE POINTER\r
+ PUSHJ P,FORMLN ;GEN THE INITIAL VALUE\r
+ PUSHJ P,EIRGNP\r
+ MOVSI D,(MOVEM N,) ;GEN STORE INITIAL IN VARIABLE\r
+ MOVE B,(P)\r
+ PUSHJ P,BUILDA\r
+ PUSHJ P,QSF ;LOOK FOR "TO"\r
+ ASCIZ /TO/\r
+ PUSHJ P,FORMLN ;GEN THE UPPER BOUND.\r
+ PUSHJ P,GPOSGE ;PERMANENT\r
+ PUSHJ P,SIPGEN ;TEMPORARY.\r
+ PUSH P,B ;REMEMBER WHERE IT IS\r
+ TLNN C,F.TERM ;IS THERE A STEP CLAUSE?\r
+ JRST XFOR2 ;LOOK FOR EXPLICIT "STEP"\r
+ MOVE T,[POINT 7,[BYTE (35)"STEP1"(7)15]]\r
+ PUSHJ P,NXCHK ;GET "S" IN CASE OF CR ;IMPLICIT "STEP1"\r
+XFOR2: PUSHJ P,QSF ;LOOK FOR "STEP"\r
+ ASCIZ /STEP/\r
+\r
+ PUSHJ P,FORMLN ;XLATE AND GEN INCREMENT\r
+ PUSHJ P,SIPGEN ;SAVE STEP\r
+ EXCH B,0(P) ;EXCH WITH TOP OF ROL\r
+ PUSH P,B ;SAVE LOC OF UPPER BOUND\r
+ MOVE B,-2(P) ;GET INDUCTION VAR IN REG\r
+ PUSHJ P,EIRGEN\r
+ MOVE B,-1(P)\r
+ HLRZ X1,B\r
+ ANDI X1,377777\r
+ CAIN X1,31\r
+ JRST XFOR3\r
+ MOVSI D,(DONFOR)\r
+ PUSHJ P,BUILDA\r
+XFOR3: MOVE X1,-1(P)\r
+ POP P,B ;BUILD COMPARE INSTR (IT\r
+ MOVSI D,(CAMLE N,) ;DOESN'T MATTER WHAT IT\r
+ SKIPGE N,X1 ;IS IF DONFOR IS THERE).\r
+ MOVSI D,(CAMGE)\r
+ PUSHJ P,BUILDA\r
+ MOVSI D,(JRST) ;DUMMY JRST INSTRUCTION\r
+ PUSHJ P,BUILDI\r
+\r
+ MOVE A,CECOD\r
+ SUB A,FLCOD ;SAVE LOC FOR NEXT'S JRST\r
+ SKIPE N,RUNFLA ;WHAT JRST ACUTALLY\r
+ MOVEI A,-2(A) ;NO. DONT ALLOW SPACE FOR IT.\r
+ MOVEI R,FORROL\r
+ PUSHJ P,RPUSH\r
+ POP P,A\r
+ EXCH A,(P)\r
+ PUSHJ P,RPUSH ;SAVE INDUCTION VARIABLE\r
+ EXCH A,(P) ;GET INCREMENT\r
+ PUSHJ P,RPUSH\r
+ POP P,B ;GET POINTER TO INDUCTION VARIABLE.\r
+ MOVSI D,(MOVEM N,) ;BUILD THE STORE THAT WILL BE USED\r
+ PUSHJ P,BUILDA ;BY NEXT.\r
+\r
+ MOVEI R,FORROL\r
+ MOVE A,TMPLOW ;SAVE THIS LEVEL OF PROTECTION TO BE RESTORED\r
+ PUSHJ P,RPUSH\r
+ MOVE A,TMPPNT ;PROTECT TEMPS USED BY THIS "FOR"\r
+ MOVEM A,TMPLOW ;IN THE RANGE OF THE FOR.\r
+ JRST N,NXTSTA\r
+\f;FNEND STATEMENT\r
+\r
+;<FNEND STA> ::= FNEND\r
+\r
+XFNEND: ASCIZ /ND/\r
+ SKIPN A,FUNAME ;MUST FOLLOW A MULTI-LINE FN DEF\r
+ FAIL <FNEND BEFORE DEF>\r
+ SETZM FUNAME ;SIGNAL END OF FN\r
+ TLO A,(177B13) ;ASSEMBLE THE SCALAR NAME OF THE RESULT\r
+ PUSHJ P,SCAREG ;REGISTER IT AS A SCALAR\r
+ PUSHJ P,EIRGNP ;GET THE RESULT IN REG\r
+ HLRZ B,FUNSTA ;RECOVER THE ADDRESS OF THE ARGUMENT COUNT\r
+ HRLI B,CADROL\r
+ HLRZ X1,FUNLOW ;THIS IS # OF WDS IN FORROL AT START OF DEF\r
+ ADD X1,FLFOR\r
+ CAME X1,CEFOR ;ARE ALL NEXTS INSIDE OF DEF COMPLETE?\r
+ FAIL <FNEND BEFORE NEXT>\r
+ JRST XDEFE\r
+\f\r
+;GOSUB STATEMENT XLATE\r
+\r
+XGOSUB: ASCIZ /UB/\r
+ PUSHJ P,GETNUM ;READ STATEMENT NUMBER\r
+ JRST GRONK\r
+ HRLZ A,N\r
+ MOVEI R,LINROL ;LOOK UP LINE NO\r
+ PUSHJ P,SEARCH\r
+ FAIL <UNDEFINED LINE NUMBER >,1\r
+ SUB B,FLLIN ;SUCCESS. SAVE REL LOC IN LINROL\r
+ HRLZ A,B\r
+ MOVEI R,GSBROL\r
+ PUSHJ P,SEARCH\r
+ JRST N,.+2\r
+ JRST N,XGOS1\r
+ MOVEI E,1\r
+ PUSHJ P,OPENUP\r
+ MOVEM A,(B)\r
+XGOS1: SUB B,FLGSB\r
+ HRLI B,GSBROL\r
+ MOVSI D,(GOSUB)\r
+ PUSHJ P,BUILDA\r
+ JRST N,NXTSTA\r
+\r
+\r
+;GOTO STATEMENT\r
+\r
+\r
+XGOTO: ASCIZ /O/\r
+XGOFIN: PUSH P,[Z NXTSTA] ;BUILD GOTO AND END STA\r
+XGOFR: PUSHJ P,GETNUM ;BUILD GOTO AND RETURN\r
+ FAIL <ILLEGAL LINE REFERENCE >\r
+ HRLZ A,N ;LOOK FOR DESTINATION\r
+ MOVEI R,LINROL\r
+ PUSHJ P,SEARCH\r
+ FAIL <UNDEFINED LINE NUMBER >,1\r
+ SUB B,FLLIN ;NOW CHECK FOR JUMP INTO/OUTOF FUNCTION\r
+ MOVE X1,FLREF\r
+ ADD X1,B\r
+ MOVE X1,(X1)\r
+ CAME X1,FUNAME ;BOTH MUST BE ZERO OR SAME FUNCTION\r
+ FAIL <ILLEGAL LINE REFERENCE >,1\r
+ HRLI B,LADROL\r
+ MOVSI D,(JRST)\r
+ PUSHJ P,BUILDA ;BUILD INSTR\r
+ POPJ P,\r
+\f;IF STATEMENT\r
+\r
+;<IF STA>::=IF <NUM FORMULA> <RELATION> <NUM FORMULA> THEN <LINE NUMBER>\r
+; OR\r
+; ::= IF <STRING FORMULA><RELATION><STRING FORMULA> THEN <LINE NUMBER>\r
+\r
+\r
+;RELATION IS LOOKED UP IN TABLE (RELROL)\r
+;WHICH RETURNS INSTRUCTION TO BE EXECUTED\r
+;IF ONE OF THE EXPRESSIONS BEING COMPARED IS\r
+;IN THE REG, THAT ONE WILL BE COMPARED AGAINST\r
+;THE OTHER IN MEMORY. IF NECESSARY, THE\r
+;INSTRUCTION IS CHANGED TO ITS CONTRAPOSITIVE\r
+;BY FUDGING BITS IN THE OP CODE\r
+\r
+;IF STATEMENT\r
+\r
+XIF: PUSHJ P,FORMLB ;LEFT SIDE, MY BE A STRING\r
+ PUSHJ P,GPOSGE ;SAVE TYPE.\r
+ PUSHJ P,PUSHPR ;MAKE SURE IT IS POSITIVE\r
+ PUSHJ P,SCNLT1 ;SAVE IT\r
+ MOVEI X1,">"\r
+ CAIE X1,(C) ;NEXT CHAR ">"?\r
+ TLNE C,F.EQAL ;OR "="?\r
+ PUSHJ P,SCN2 ;PUT TWO CHAR RELATION IN A(SIXBIT)\r
+ JFCL\r
+ MOVEI R,RELROL ;RELATION TABLE\r
+ PUSHJ P,SEARCH\r
+ FAIL <ILLEGAL RELATION>\r
+ HRLZ D,(B) ;SAVE RELATION INSTR\r
+ PUSH P,D\r
+ PUSHJ P,FORMLB ;RIGHT SIDE, MAY ALSO BE A STRING\r
+ SKIPN IFFLAG\r
+ FAIL <MIXED STRINGS AND NUMBERS>\r
+ PUSHJ P,GPOSGE\r
+ TLNN B,ROLMSK ;IS RIGHT SIDE IN REG?\r
+ JRST IFSX4 ;YES, LEAVE IT\r
+ PUSHJ P,EXCHG ;NO. SWAP WITH LEFT SIDE.\r
+ MOVE D,(P) ;FUDGE INSTRUCTION FOR CONTRAPOSITIVE RELATION\r
+ TLNE D,1000 ;(EQUAL, NOT EQUAL DON'T CHANGE.)\r
+ TLC D,6000 ;(OTHERS DO).\r
+ MOVEM D,(P)\r
+\r
+IFSX4:\r
+IFN FTSTR,<\r
+ SKIPL IFFLAG ;NUMERIC COMPARE?\r
+ JRST IFSX6 ;NO, STRING.\r
+>\r
+ PUSHJ P,EIRGNP ;MOVE TO REG\r
+ PUSHJ P,POPPR ;GET OTHER SIDE BACK\r
+ POP P,D ;GET STASHED OP CODE\r
+ PUSHJ P,BUILDA ;BUILD COMPARE INSTRUCTION\r
+IFSX5: PUSHJ P,THENGO ;LOOK FOR "THEN" OR "GOTO"\r
+ JRST N,XGOFIN ;USE GOTO CODE TO GEN JRST INSTR\r
+\r
+IFN FTSTR,<\r
+IFSX6: PUSHJ P,FLET3\r
+ PUSHJ P,POPPR ;GET OTHER ONE BACK\r
+ MOVSI D,(STRIF) ;STRING COMPARE UUO\r
+ PUSHJ P,BUILDA ;COMPARE UUO WITH OTHER STRING ADDRESS\r
+ POP P,D\r
+ PUSHJ P,BUILDI ;BUILD THE RELATION\r
+ JRST N,IFSX5 ;FINISH UP (THE OTHER STR POINTER WILL BE IN N)\r
+>;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY\r
+\f;INPUT STATEMENT\r
+\r
+;<INPUT STA> ::= INPUT (<SCALAR> ! <ARRAY REF>)[,(<SCALAR>!<ARRAY REF>)...]\r
+\r
+\r
+XINPUT: ASCIZ /UT/\r
+ MOVE D,[PUSHJ P,DOINPT]\r
+XINP0: PUSHJ P,BUILDI ;CONTRUCT SETUP INSTR\r
+XINP1: TLNN C,F.LETT ;CHECK THAT LETTER IS NEXT.\r
+ JRST GRONK\r
+ SETZI F, ;STRINGS MAY BE INPUT\r
+ PUSHJ P,REGLTR ;GET VARIABLE\r
+ JUMPE A,XINP2\r
+ CAIG A,4 ;STRING VARIABLE?\r
+ JRST XINP1A ;NO\r
+IFN FTSTR,<\r
+ CAIG A,6 ;VARIABLE?\r
+ JRST XINP6 ;YES\r
+>\r
+\r
+ JRST ILFORM ;NO, ATTEMPT TO BOMB A LITERAL\r
+\r
+XINP1A: CAILE A,1 ;ONLY ARRAY AND SCALAR ALLOWED\r
+ JRST ILVAR\r
+ MOVSI D,13000\r
+ PUSHJ P,BUILDA\r
+ JRST N,XINP3\r
+XINP2: PUSH P,B ;SAVE VARIABLE POINTER\r
+ PUSHJ P,XARG ;XLATE ARGS\r
+ MOVSI D,14000\r
+ JUMPE B,XINP2A\r
+ HRRZ X1,(P) ;GET ADDRESS OF VARIABLE 2-WD BLOCK\r
+ ADD X1,FLARA\r
+ SKIPN 1(X1) ;MARK 2-DIM\r
+ SETOM 1(X1)\r
+ MOVSI D,15000\r
+XINP2A: EXCH B,(P) ;SAVE NO OF ARGS, GET VARIABLE\r
+ PUSHJ P,BUILDA ;BUILD DATA INSTR\r
+ POP P,B ;GET NO OF ARGS\r
+ PUSHJ P,GENARG\r
+\r
+XINP3: TLNN C,F.COMA ;MORE?\r
+ JRST NXTSTA ;NO\r
+ PUSHJ P,NXCHK ;YES. SKIP COMA\r
+ JRST XINP1\r
+IFN FTSTR,<\r
+XINP6: PUSHJ P,FLET2 ;STRING. FINISH REGISTERING\r
+ MOVSI D,33200\r
+ PUSHJ P,BUILDA ;BUILD, WITH ADDRESS\r
+ JRST XINP3\r
+>\r
+\f;LET STATEMENT\r
+\r
+XLET: TLNN C,2000\r
+ JRST GRONK\r
+ SETZI F,\r
+ SETOM LETSW ;LOOK FOR A LHS.\r
+XLET0B: PUSHJ P,FORMLB\r
+ SKIPGE LETSW ;FAIL IF THIS FORMULA IS NOT A VARIABLE\r
+ TLNN C,220000\r
+ JRST XLET0A\r
+ SKIPL IFFLAG\r
+ JRST XLET3\r
+ PUSH P,[EXP 1] ;FLAG ON PLIST. IF THE LHS IS A SCALER,\r
+ PUSH P,B ;PUT THE FLAG AND AC B ON PLIST HERE.\r
+XLET0: PUSHJ P,NXCHK ;SKIP EQUAL SIGN.\r
+ SOS LETSW ;COUNT THIS LHS, AND\r
+ JRST XLET0B ;LOOK FOR ANOTHER.\r
+XLET0A: MOVMS LETSW ;FINISHED SCANNING\r
+ SOSG LETSW\r
+ JRST GRONK\r
+ SKIPL E,IFFLAG ;STRING LET STA?\r
+ JRST XLET3A ;YES.\r
+\r
+ PUSHJ P,EIRGEN ;NO, GET RESULT IN REG\r
+ MOVEM B,TEMP1 ;SAVE THE NEGATIVE RESULT CHECK\r
+XLET1: MOVE D,[MOVEM N, (MOVNM N,)]\r
+ SKIPG -1(P) ;FLAGS ON PLIST ARE --\r
+ MOVE D,[ARSTO1 N, (ARSTN1 N,)] ; 0 FOR LIST\r
+ SKIPL -1(P) ; 1 FOR SCALAR\r
+ JRST XLET2 ; -1 FOR TABLE.\r
+ MOVE D,[ARSTO2 N, (ARSTN2 N,)]\r
+ MOVE X1,(P) ;DEFAULT ARRAY SIZE (10,10)\r
+ ADD X1,FLARA\r
+ SKIPN 1(X1)\r
+ SETOM 1(X1)\r
+XLET2: SKIPGE TEMP1 ;CHECK FOR NEGATIVE RESULT\r
+ MOVS D,D ;NEGATIVE. GET CORRECT INSTR.\r
+ POP P,B ;RESTORE RESULT PNTR\r
+ PUSHJ P,BUILDA ;BUILD STORE INSTR\r
+ POP P,B ;CHECK TRASH FROM PUSHLIST.\r
+ JUMPG B,XLET2B ;ARRAY REF?\r
+ PUSHJ P,GENARG ;YES. GEN ARGS FIRST.\r
+XLET2B: SOSLE LETSW\r
+ JRST XLET1 ;THERE IS ANOTHER LHS.\r
+ JRST NXTSTA\r
+\r
+XLET3: PUSHJ P,PUSHPR\r
+ JRST N,XLET0\r
+XLET3A: CAME E,LETSW\r
+ FAIL <MIXED STRINGS AND NUMBERS>\r
+XLET4: PUSH P,B\r
+ PUSHJ P,FLET3\r
+ PUSHJ P,POPPR\r
+ MOVSI D,(STRSTO) ;BUILD THE STRING MOVE INSTRUCTION.\r
+ PUSHJ P,BUILDA\r
+ POP P,B\r
+ SOSLE LETSW\r
+ JRST XLET4 ;THERE IS ANOTHER LHS.\r
+ JRST NXTSTA\r
+\fIFN FTMAT,<\r
+;MAT STATEMENT\r
+\r
+;MAT STATEMENTS DIVIDE INTO A NUMBER OF DIFFERENT\r
+;STATEMENTS (MAT READ, ...) THESE POSSIBILITIES ARE TESTED\r
+;ONE AT A TIME BY CALLS TO QSA.\r
+\r
+;<MAT READ STA> ::= MAT READ <LETTER>[(<EXP>,<EXP>)] [,<LETTER>[(<EXP>,<EXP>...]]\r
+\r
+XMAT: HLLI F, ;ALLOW STRINGS FOR READ,PRINT,PRINT\r
+ PUSHJ P,QSA ;MAT READ?\r
+ ASCIZ /READ/\r
+ JRST XMAT2 ;NO. GO TRY MAT PRINT\r
+XMAT1: PUSHJ P,ARRAY ;GET ARRAY NAME\r
+ CAIE A,5 ;STRING VECTOR?\r
+ JUMPN A,GRONK\r
+ MOVSI D,(MATRD)\r
+ SKIPL DATAFF ;DATA SEEN?\r
+ HLLOS DATAFF ;NO. SET NO DATA FLAG\r
+ PUSHJ P,XMACOM ;GO CHECK DIMENSIONS AND BUILD UUO.\r
+ TLNN C,F.COMA ;IS THERE ANOTHER ARRAY TO READ?\r
+ JRST NXTSTA ;NO.\r
+ PUSHJ P,NXCHK ;YES. SKIP COMMA\r
+ TLNE C,F.TERM ;END OF ARRAY LIST?\r
+ JRST N,NXTSTA ;YES.\r
+ JRST N,XMAT1\r
+\r
+;<MAT PRINT STA>::= MAT PRINT <LETTER>[(<EXP>,<EXP>)] [[;!,] <LETTER>[(<EXP>,<EXP>)...]\r
+\r
+XMAT2: PUSHJ P,QSA ;MAT PRINT?\r
+ ASCIZ /PRINT/\r
+ JRST N,XMAT3 ;NO. MUST HAVE VARIABLE NAME.\r
+XMAT2A: PUSHJ P,ARRAY ;REGISTER NAME\r
+ CAIE A,5 ;STRING VECTOR?\r
+ JUMPN A,GRONK\r
+ MOVSI D,(MATPR)\r
+ PUSHJ P,CHKFMT\r
+ TLNN D,140\r
+ JRST GRONK ;FAIL IF ILLEGAL\r
+ PUSHJ P,XMACOM ;GO CHECK DIMENSIONS AND BUILD UUO\r
+ TLNE C,F.TERM ;IS FORMAT CHAR FOLLOWED BY END OF STA?\r
+ JRST NXTSTA ;YES.\r
+ JRST XMAT2A\r
+\r
+;<MAT SCALE STA> ::= MAT <LETTER>=(<EXPRESSION>)*<LETTER>\r
+\r
+XMAT3: PUSH P,[Z NXTSTA] ;ALL REMAINING MAT STATEMENTS MAY HAVE\r
+ ;ONE OPERAND, BUT NOT A LIST OF THEM.\r
+ PUSHJ P,QSA\r
+ ASCIZ /INPUT/\r
+ JRST XMAT3A\r
+ PUSHJ P,VECTOR ;REGISTER VECTOR NAME\r
+ CAIE A,5 ;STRING VECTOR?\r
+ JUMPN A,GRONK ;OR NUMBER VECTOR?\r
+ MOVSI D,(MATINP) ;YES. BUILD MAT INPUT\r
+ JRST BUILDA\r
+\r
+\r
+XMAT3A: HRLI F,-1 ;REMAINING MATOPS CANT HAVE STRINGS.\r
+ PUSHJ P,ARRAY ;REGISTER THE VARIABLE\r
+ JUMPN A,GRONK ;CHECK FOR ILLEGAL ARRAY NAME.\r
+ TLNN C,F.EQAL ; CHECK FOR EQUAL SIGN.\r
+ JRST GRONK\r
+ PUSHJ P,NXCHK ;SKIP EQUAL.\r
+ CAIE C,"(" ;SCALAR MULTIPLE?\r
+ JRST XMAT4 ;NO\r
+ PUSHJ P,NXCHK ;SKIP PARENTHESIS\r
+ PUSH P,B\r
+ PUSHJ P,FORMLN ;YES. GEN MULTIPLE\r
+ PUSHJ P,EIRGNP\r
+ PUSHJ P,QSF ;SKIP MULTIPLY SING\r
+ ASCIZ /)*/\r
+ PUSH P,[MATSCA] ;GET OP CODE.\r
+ JRST N,XMAT9A\r
+\f;<MAT SETUP STA> ::= MAT ZER!CON!IDN <LETTER>[(<EXPRESSION>,<EXPRESSION>)]\r
+\r
+XMAT4: PUSHJ P,QSA ;MAT ZER?\r
+ ASCIZ /ZER/\r
+ JRST XMAT5 ;NO.\r
+ MOVSI D,(MATZER) ;YES.\r
+ JRST XMACOM\r
+\r
+XMAT5: PUSHJ P,QSA ;MAT CON?\r
+ ASCIZ /CON/\r
+ JRST XMAT6\r
+ MOVSI D,(MATCON) ;YES.\r
+ JRST XMACOM\r
+\r
+XMAT6: PUSHJ P,QSA ;MAT IDN?\r
+ ASCIZ /IDN/\r
+ JRST XMAT7 ;NO\r
+ MOVSI D,(MATIDN) ;YES.\r
+\r
+;COMMON GEN FOR MAT ZER,CON,IDN,REA\r
+\r
+XMACOM: CAIE C,"(" ;EXPLICIT DIMENSIONS?\r
+ JRST XMAT9D ;NO.\r
+ PUSH P,B ;SAVE B,D.\r
+ PUSH P,D\r
+ PUSHJ P,XARG ;TRANSLATE ARGUMENTS\r
+ PUSH P,B ;SAVE COUNT OF ARGUMENTS\r
+ MOVE B,-2(P) ;GET BACK THE REGISTERY OF THE ARRAY.\r
+ MOVSI D,(SDIM) ;BUILD SDIM INSTR.\r
+ PUSHJ P,BUILDA\r
+ POP P,B ;GET THE ARGUMENT COUNT.\r
+ JUMPN B,XMACO1 ;ONE ARG OR TWO?\r
+ MOVE D,[JUMP T1,ONCESW] ;ONE. FAKE DIMENSIONS OF (0,N)\r
+ PUSHJ P,BUILDI\r
+ SETZI B,\r
+\r
+XMACO1: PUSHJ P,GENARG ;GEN ARGS\r
+ JRST XMAT9C ;RESTORE AC,S AND BUILD\r
+\r
+;<MAT FCN STA> ::= MAT<LETTER> = INV!TRN (<LETTER>)\r
+\r
+XMAT7: PUSHJ P,QSA ;MAT INV?\r
+ ASCIZ /INV(/\r
+ JRST XMAT8 ;NO\r
+ MOVSI D,(MATINV) ;YES. GET OP CODE.\r
+ JRST XMITCM\r
+\r
+XMAT8: PUSHJ P,QSA ;MAT TRN?\r
+ ASCIZ /TRN(/\r
+ JRST XMAT9 ;NO.\r
+ MOVSI D,(MATTRN) ;YES. GET OP CODE\r
+XMITCM: PUSH P,B ;FINISH MAT INV,TRN.\r
+ PUSH P,D\r
+ PUSHJ P,ARRAY\r
+ JUMPN A,GRONK\r
+ PUSHJ P,QSF\r
+ ASCIZ /)/\r
+ JRST XMAT9B\r
+\f;<MAT OPERATOR STA>::=MAT <LETTER>=<LETTER>+!-!*<LETTER>\r
+\r
+XMAT9: PUSH P,B ;SAVE RESULT LOCATION\r
+ PUSHJ P,ARRAY\r
+ JUMPN A,GRONK\r
+ MOVEI D,0 ;LETTER FOLLOWED BY OPERATOR\r
+ TLNN C,F.PLUS+F.MINS+F.STAR\r
+ JRST N,XMAT10 ;NO OPERATOR. MUST BE MAT COPY\r
+ TLNN C,F.MINS+F.STAR\r
+ MOVSI D,(MATADD)\r
+ TLNN C,F.PLUS+F.STAR\r
+ MOVSI D,(MATSUB)\r
+ TLNN C,F.PLUS+F.MINS\r
+ MOVSI D,(MATMPY)\r
+ PUSH P,D ;SAVE OPERATION\r
+ PUSHJ P,NXCHK ;SKIP OPERATOR\r
+ MOVSI D,(MOVEI T,) ;GEN T:= ADRS OF FIRST ARRAY\r
+\r
+ PUSHJ P,BUILDA ;ENTER HERE FROM SCALAR MULTIPLE\r
+\r
+XMAT9A: PUSHJ P,ARRAY ;SECOND ARRAY\r
+ JUMPN A,GRONK ;NOT ARRAY NAME\r
+\r
+;ENTER HERE FROM MAT INV, TRN\r
+\r
+XMAT9B: MOVSI D,(MOVEI T1,)\r
+ PUSHJ P,BUILDA\r
+XMAT9C: POP P,D\r
+ POP P,B\r
+XMAT9D: PUSHJ P,BUILDA\r
+ POPJ P, ;RETURN TO NXTSTA (OR TO PROCESS NEXT ITEM IN PRINT,READ, OR INPUT LIST.)\r
+\r
+XMAT10: PUSH P,B ;FOR MAT COPY, FAKE MAT B=(1)*A\r
+ MOVE D,[MOVSI N,(1.0)];PUT CONSTANT 1.0 IN REG FOR SCALE\r
+ PUSHJ P,BUILDI ;BUILD INSTR TO GET SCAL FACTOR\r
+ POP P,B ;GET SOURCE MAT BACK\r
+ PUSH P,[MATSCA]\r
+ JRST N,XMAT9B\r
+>;ASSEMBLE ABOVE IF INCLUDING MATRIX FACILITY\r
+\f;;NEXT STATEMENT\r
+\r
+;<NEXT STA> ::= NEXT <SCALAR>\r
+\r
+;EXPECT TO FIND 5-WORD ENTRY ON TOP OF FORROL\r
+;DISCRIBING INDUCTION VARIABLE AND LOOP ADDRESS\r
+\r
+;WORD IS PUSHED ON NXTROL OF FOLLOWING FORM:\r
+; (<REL ADRS OF TOP OF LOOP>) <REL ADRS OF JRST TO IT>\r
+;THIS WORD USED TO FIX UP REFERENCE AT END OF\r
+;COMPILATION\r
+XNEXT: ASCIZ /T/\r
+ PUSHJ P,REGLTR\r
+ CAIE A,1 ;BETTER BE SCALAR\r
+ JRST GRONK\r
+ MOVE X1,CEFOR ;UNSAT FOR?\r
+ CAMG X1,FLFOR\r
+ FAIL <NEXT WITHOUT FOR>\r
+ CAME B,-3(X1) ;CHECK INDUCTION VARIABLE\r
+ FAIL <NEXT WITHOUT FOR>\r
+\r
+ PUSHJ P,POPFOR\r
+ MOVEM B,TMPLOW ;RESTORE PREVIOUS LEVEL OF TEMPORARY PROTECTION.\r
+ MOVEM B,TMPPNT ;BECAUSE THIS IS THE END OF THE "FOR" RANGE .\r
+ PUSHJ P,POPFOR ;GEN INCREMENT TO REG\r
+ PUSHJ P,EIRGEN\r
+ PUSHJ P,POPFOR ;FADR TO INDUCTION VAR\r
+ MOVSI D,(FADR)\r
+ PUSHJ P,BUILDA\r
+ PUSHJ P,POPFOR ;GET LOC OF RETURN\r
+\r
+ MOVEI X1,1(B) ;ADD TO ADDRESS CHAIN OF NEXT WORD\r
+ ADD X1,FLCOD\r
+ MOVE X2,L\r
+ AOBJP X2,XNEX2 ;DONT LINK IF LAST STATEMENT!\r
+ ADD X2,FLLAD\r
+ MOVE Q,(X2)\r
+ HRRM Q,(X1)\r
+ MOVEI Q,1(B)\r
+ HRRM Q,(X2)\r
+\r
+XNEX2: MOVSI A,(B) ;ADD WORD TO NXTROL FOR LINKAGE\r
+ MOVEI R,NXTROL\r
+ PUSHJ P,RPUSH\r
+ SUB B,FLNXT\r
+ HRLI B,NXTROL\r
+ MOVSI D,(JRST) ;BUILD JRST INSTR\r
+ PUSHJ P,BUILDA\r
+ PUSHJ P,POPFOR ;POP OFF THE SAVED VALUE OF L\r
+ JRST NXTSTA\r
+\f;SUBR TO POP TOP OF FORROL. USED ONLY BY XNEXT.\r
+\r
+\r
+POPFOR: SOS X1,CEFOR ;POP TOP OF FORROL\r
+ MOVE B,(X1)\r
+ POPJ P,\r
+\r
+\r
+\f;ON STATEMENT\r
+\r
+;<ON STA> ::= ON <EXPRESSION> GOTO!THEN <STA NUMBER> [,<STA NUMBER>...]\r
+\r
+;CREATES A CALL TO A RUNTIME ROUTINE THAT CHECKS THE RANGE OF THE ARGUMENT\r
+;AND RETURNS TO THE APPROPRIATE JRST:\r
+; JSP A,XCTON\r
+; Z (ADDRESS OF NEXT STATEMENT)\r
+; <NEST OF>\r
+; <GOTO'S >\r
+\r
+\r
+XON: PUSHJ P,FORMLN ;EVALUTE INDEX\r
+ PUSHJ P,EIRGNP ;GET IN REG\r
+ MOVE D,[JSP Q,XCTON]\r
+ PUSHJ P,BUILDI ;BUILD THE RUNTIME CALL\r
+ SETZI D, ;BUILD ADDRESS OF NEXT STATEMENT\r
+ MOVE B,L\r
+ AOBJP B,.+3 ;DONT BUILD IF LAST STATEMENT\r
+ HRLI B,LADROL\r
+ PUSHJ P,BUILDA\r
+ PUSHJ P,THENGO ;TEST FOR "THEN" OR "GOTO"\r
+\r
+XON1: PUSHJ P,XGOFR ;BUILD A JRST TO THE NEXT NAMED STATMENT\r
+ TLNN C,F.COMA ;MORE?\r
+ JRST N,NXTSTA ;NO\r
+ PUSHJ P,NXCHK ;YES. SKIP COMMA\r
+ JRST N,XON1 ;PROCESS NEXT LINE NUMBER\r
+\f;PRINT STATEMENTS CAUSES DATA TO BE OUTPUT TO THE DISK OR TTY.\r
+\r
+XPRINT: ASCIZ /NT/\r
+ TLNE C,F.TERM\r
+ JRST N,XPCRLF\r
+XPRI1: SETOM IFFLAG\r
+ TLNE C,40\r
+ JRST N,XPRTA2\r
+ PUSHJ P,QSA\r
+ ASCIZ /TAB/ ;TAB FIELD?\r
+ CAIA ;NO, ASSUME EXPRESSION OR DELIMENTER.\r
+ JRST XPRTAB ;YES, DO THE TAB\r
+ TLNE C,F.COMA\r
+ JRST N,XPRI2\r
+ PUSHJ P,FORMLB\r
+ SKIPL N,IFFLAG\r
+ JRST N,PRNDEL\r
+ PUSHJ P,GPOSNX\r
+ MOVSI D,(PRNM) ;SET UP OP CODE\r
+ PUSHJ P,CHKFMT ;SET FORMAT CODE\r
+ PUSHJ P,BUILDA ;GEN PRINT UUO\r
+ JRST XPRFIN\r
+XPRI2: MOVE D,[PRNTB ONCESW]\r
+ JRST XPRTA1\r
+\r
+;PRINT TAB\r
+\r
+XPRTAB: PUSHJ P,FORMLN ;EVALUATE TAB SUBEXPRESSION\r
+ PUSHJ P,EIRGNP ;MOVE IT INTO REG\r
+ MOVSI D,(PRNTB) ;CALL THE TAB INTERPRETER\r
+XPRTA1: PUSHJ P,CHKFMT\r
+ PUSHJ P,BUILDI ;YES, BUILD THE INST.\r
+ JRST XPRFIN\r
+XPRTA2: PUSH P,T\r
+ PUSHJ P,QSKIP\r
+ JRST GRONK\r
+ MOVSI D,3000\r
+ PUSHJ P,CHKFMT\r
+ PUSHJ P,BUILDI\r
+ POP P,D\r
+ PUSHJ P,BUILDI\r
+XPRFIN: TLNE C,F.TERM ;CR AT END OF LINE?\r
+ JRST NXTSTA\r
+ JRST XPRI1\r
+\r
+;HERE FOR PRINT WITH NO ARGUMENTS. GEN CARRIAGE RETURN.\r
+\r
+XPCRLF: MOVE D,[PUSHJ P,PCRLF]\r
+ PUSHJ P,BUILDI\r
+ JRST NXTSTA\r
+\r
+;CHECK FORMAT CHAR (PRINT AND MAT PRINT)\r
+\r
+CHKFMT: TLNE C,F.TERM\r
+ TLO D,40 ;CR ... AC = 1\r
+ CAIN C,";" ;SC ... AC = 2\r
+ TLO D,100 ;CMA ... AC = 3\r
+ TLNE C,F.COMA ;<PA> ... AC = 4\r
+ TLO D,140\r
+ TLNN D,140 ;WAS THERE A FMT CHAR?\r
+ TLO D,100 ;NO. ASSUME ";"\r
+ CAIE C,";"\r
+ TLNE C,F.COMA ;SKIP FMT CHAR IF THERE WAS ONE.\r
+ JRST NXCHK ;YES. SKIP\r
+ POPJ P,\r
+\r
+PRNDEL: MOVSI D,(PRSTR)\r
+ PUSHJ P,CHKFMT\r
+ PUSHJ P,BUILDA\r
+ JRST XPRFIN\r
+\f;RANDOM IZE STATEMENT\r
+\r
+IFN FTRND,<\r
+XRAN: ASCIZ /DOM/\r
+ PUSHJ P,QSA\r
+ ASCIZ /IZE/\r
+ JFCL\r
+ TLNN C,F.TERM\r
+ JRST N,ILLINS\r
+ MOVE D,[PUSHJ P,RANDER]\r
+ PUSHJ P,BUILDI ;BUILD CALL TO RUTIME RANDOMIZER\r
+ JRST N,NXTSTA\r
+>;ASSEMBLE ABOVE IF INCLUDING RANDOM FACILITY\r
+\r
+\r
+;READ STATEMENT\r
+\r
+\r
+XREAD: ASCIZ /D/\r
+ SKIPL DATAFF ;DATA SEEN YET?\r
+ HLLOS DATAFF ;NO. SET NO DATA FLAG\r
+ MOVE D,[PUSHJ P,DOREAD]\r
+ JRST XINP0 ;GO FINISH WITH INPUT CODE\r
+\r
+\f;RESTORE STATEMENTS.\r
+\r
+\r
+XREST: ASCIZ /TORE/\r
+ MOVE D,[PUSHJ P,RESTON]\r
+ TLNN C,F.STAR+F.DOLL\r
+ SOJA D,XRES1\r
+ TLNE C,F.DOLL ;RESTORE ONLY STIRNGS?\r
+ ADDI D,1\r
+ PUSHJ P,NXCHK ;SKIP $ OR *\r
+XRES1: PUSHJ P,BUILDI\r
+ JRST NXTSTA\r
+\f\r
+\r
+;RETURN STATEMENT XLATE\r
+\r
+\r
+XRETRN: ASCIZ /URN/\r
+ MOVE D,[JRST RETURN]\r
+XRET1: PUSHJ P,BUILDI ;XDEFS ENTERS HERE TO COMPLETE A FN DEF.\r
+ JRST N,NXTSTA\r
+\r
+\r
+\r
+;STOP STATEMENT\r
+\r
+XSTOP: ASCIZ /P/\r
+ MOVE D,[JRST UXIT]\r
+ PUSHJ P,BUILDI\r
+ JRST NXTSTA\r
+\f;GEN CODE TO EVALUATE FORMULA\r
+;POINTER TO (POSSIBLY NEGATIVE) RESULT RETURNED IN B\r
+\r
+;THIS LOOP HANDLES SUMS OF TERMS, CALLS TERM TO HANDLE PRODUCTS\r
+;AND SO ON\r
+;THE ENTRY POINT FORMLN REGARDS ONLY NUMERIC FORMULAS AS LEGAL.\r
+;THE ENTRY POINT FORMLS REGARDS ONLY STRING FORMULAS AS LEGAL.\r
+;THE ENTRY POINT FORMLB WILL ACCEPT EITHER A STRING OR A NUMERIC FORMULA.\r
+;THE ENTRY POINT FORMLU EXPECTS THE LEGALITY TO BE DEFINED EXTERNALLY.\r
+\r
+FORMLB: SETZI F,\r
+ TLNE C,40\r
+ JRST N,REGSL1\r
+ TLNN C,2000\r
+FORMLN: SETOI F,\r
+ PUSHJ P,TERM ;GET FIRST TERM\r
+\r
+;ENTER HERE FOR MORE SUMMANDS\r
+\r
+FORM1: TLNN C,F.PLUS+F.MINS\r
+ POPJ P,\r
+ MOVMS N,LETSW ;THIS CANT BE LH(LET)\r
+ TLO F,777777\r
+ PUSHJ P,PUSHPR ;PART RESLT TO SEXROL\r
+ PUSHJ P,TERM ;GET SECOND TERM\r
+ TLNE B,ROLMSK ;IS SECOND TERM IN REG?\r
+ PUSHJ P,EXCHG ;NO. LETS DO FIRST TERM FIRST\r
+ PUSHJ P,EIRGEN ;FIRST SUMMAND TO REG\r
+ PUSH P,B ;SAVE SIGN INFORMATION\r
+ PUSHJ P,POPPR ;GET SECOND SUMMAND\r
+ SKIPGE (P) ;IS CONTENT OR REG NEGATIVE?\r
+ TLC B,MINFLG ;YES, NEGATE SECOND SUMMAND\r
+ MOVSI D,(FADR N,) ;FETCH INSTRUCTION\r
+ PUSHJ P,BUILDS ;BUILD ADD OR SUB INSTR\r
+ POP P,B ;REG PNTR WITH SIGN\r
+ AND B,[XWD MINFLG,0]\r
+ JRST FORM1\r
+\f;LOOP TO GEN CODE FOR MULTIPLY AND DIVIDE\r
+;CALLS FACTOR TO HANDLE EXPRESSIONS INVOLVING ONLY INFIX OPS AND "^"\r
+\r
+\r
+TERM: PUSHJ P,FACTOR\r
+\r
+;ENTER HERE FOR MORE FACTORS\r
+\r
+TERM1: TLNN C,F.STAR+F.SLSH ;MUL OR DIV FOLLOWS?\r
+ POPJ P, ;NO, DONE WITH TERM.\r
+ MOVMS LETSW ;THIS CANT BE LH(LET)\r
+ TLO F,777777\r
+ HRRZS 0(P) ;SET MUL FLAG.\r
+ TLNN C,F.STAR ;IS IT MULTIPLY?\r
+ HRROS 0(P) ;NO. SET DIV FLAG\r
+ PUSHJ P,NXCHK ;SKIP OVER CONNECTIVE\r
+ PUSHJ P,PUSHPR ;STASH PARTIAL RESULT ON SEXROL\r
+ PUSHJ P,FACTOR ;GET NEXT FACTOR\r
+ SKIPGE (P) ;IS SECOND FACTOR A DIVISOR?\r
+ PUSHJ P,SITGEN ;YES. IT CANNOT STAY IN REG.\r
+ TLNE B,ROLMSK ;IS SECOND FACTOR IN REG?\r
+ PUSHJ P,EXCHG ;NO. LETS GET FIRST FACTOR\r
+ MOVE X1,CESEX ;PEEK AT DIVISOR OR SECOND FACTOR.\r
+ MOVE X2,-1(X1)\r
+ TLZE X2,MINFLG ;IS IT MINUS?\r
+ TLC B,MINFLG ;YES. CHANGE SIGNS OF BOTH.\r
+ MOVEM X2,-1(X1) ;NOW DIVISOR OR SECOND FACTOR IS PLUS.\r
+ PUSHJ P,EIRGEN ;GEN FIRST FACTOR OR DIVIDEND\r
+ PUSH P,B ;SAVE SIGN INFORMATION\r
+ PUSHJ P,POPPR ;GET SECOND OPERAND\r
+ MOVSI D,(FMPR N,) ;GET CORRECT INSTRUCTION\r
+ SKIPGE -1(P)\r
+ MOVSI D,(FDVR N,)\r
+ PUSHJ P,BUILDA ;BUILD MUL OR DIV INSTR\r
+ POP P,B ;REG PNTR WITH SIGN\r
+ JRST N,TERM1 ;GO LOOK FOR MORE FACTORS\r
+\f;GEN CODE FOR ATOMIC FORMULAS, EXPONENTIATION, AND INFIX SIGNS\r
+;SIGN IS STASHED IN LH OF PUSH-DOWN LIST WORD WITH RETURN ADDRS\r
+;EXPLICIT SIGN IS NOT USED UNTIL AFTER EXPONENTIATION\r
+;IS CHECKED FOR.\r
+\r
+\r
+FACTOR: PUSH P,C ;STASH SIGN IN PUSH LIST.\r
+ TLNE C,F.MINS\r
+ TLC C,F.PLUS+F.MINS ;YES. PRETEND IT WAS PLUS CALLING ATOM.\r
+\r
+ PUSHJ P,ATOM ;GEN FIRST ATOM\r
+\r
+FACT2A: CAIE C,"^" ;EXPONENT FOLLOWS?\r
+ JRST SNOEXI ;NO. GO NOTE SIGN AND RETURN.\r
+ MOVMS LETSW ;THIS CANT BE LH(LET)\r
+ PUSHJ P,NXCHK ;YES. SKIP EXPONENTIATION SIGN\r
+ PUSHJ P,PUSHPR ;STASH BASE ON SEXROL\r
+ PUSHJ P,ATOM ;GEN THE EXPONENT\r
+ PUSHJ P,EXCHG ;EXCHANGE BASE AND EXPONENT\r
+ PUSHJ P,EIRGNP ;GET POSITIVE BASE IN REG\r
+ PUSHJ P,POPPR ;GET EXPONENT IN AC1\r
+ MOVSI D,(MOVE 1,)\r
+ PUSHJ P,BUILDS\r
+ MOVE D,[PUSHJ P,EXP3.0]\r
+ PUSHJ P,BUILDI ;BUILD CALL TO EXPONENTIATION ROUTINE\r
+ MOVEI B,0 ;ANSWER LANDS IN REG\r
+ JRST FACT2A\r
+\r
+;SIGN NOTE AND EXIT\r
+;COMPLEMENT SIGN IF "-" AND APPROPRIATE FLAGS ON PD LIST.\r
+;THEN RETURN FROM SUBROUTINE.\r
+\r
+SNOEXI: POP P,X1\r
+ TLNE X1,F.MINS ;IS SAVED SIGN MINUS?\r
+ TLC B,MINFLG ;YES. COMPLEMENT\r
+ POPJ P,\r
+\f;GEN CODE FOR SIGNED ATOM.\r
+\r
+ATOM: PUSH P,C ;SAVE SIGN INFO.\r
+ TLNE C,F.PLUS+F.MINS\r
+ PUSHJ P,NXCHK ;YES. SKIP SIGN\r
+ TLNE C,F.LETT ;LETTER?\r
+ JRST FLETTR ;YES. VARIABLE OR FCN CALL.\r
+ TLNE C,F.DIG+F.PER ;NUMERAL OR DECIMAL POINT?\r
+ JRST FNUMBR ;YES. LITERAL OCCURRENCE OF NUMBER\r
+ CAIE C,F.SLSH+F.QUOT ;STR CONSTANT.\r
+ JRST ILFORM ;NO. ILLEGAL FORMULA\r
+\r
+ PUSHJ P,NXCHK ;SUBEXPR IN PARENS. SKIP PAREN\r
+ PUSHJ P,FORMLN ;GEN THE SUBEXPRESSION\r
+ TLNN C,F.RPRN ;BETTER HAVE MATCHING PAREN\r
+ JRST ILFORM ;NO. GRONK.\r
+ PUSHJ P,NXCHK ;SKIP PARENTHESIS\r
+ JRST N,SNOEXI ;GO TEST SIGN AND RETURN\r
+\r
+FNUMBR: PUSHJ P,EVANUM ;EVALUATE NUMBER (IN N)\r
+ FAIL <ILLEGAL CONSTANT>\r
+ MOVE X1,0(P) ;GET SIGN FLAG\r
+ CAIE C,"^" ;EXPONENT FOLLOWS?\r
+ TLNN X1,F.MINS ;OR IS IT PLUS ANYWAY?\r
+ JRST FNUM1 ;YES. DONT FUDGE SIGN\r
+ MOVN N,N ;NEGATE NUMBER\r
+ SETZM 0(P) ;AND CLEAR SIGN INFO.\r
+\r
+FNUM1: MOVE B,FLCON ;SEARCH CONSTANT ROLL\r
+FNUM2: CAML B,CECON ;(UNSORTED--CANT USE SEARCH)\r
+ JRST FNUM3 ;NOT FOUND\r
+ CAME N,(B) ;THIS ONE?\r
+ AOJA B,FNUM2 ;NO. GO TO NEXT.\r
+ SUB B,FLCON ;FOUND. CALC REL ADDRESS IN CONROL\r
+ JRST FNUM4\r
+\r
+FNUM3: MOVEI R,CONROL ;PUSH ON CONROL\r
+ MOVE A,N\r
+ PUSHJ P,RPUSH\r
+ MOVEI R,CADROL ;PUT ADDRS ON CONST ADDRS ROLL\r
+ MOVEI A,0\r
+ PUSHJ P,RPUSH\r
+ SUB B,FLCAD ;GET REL ADDRS\r
+\r
+FNUM4: HRLI B,CADROL ;MAKE POINTER\r
+ JRST N,SNOEXI ;GO LOOK AT SIGN AND RETURN\r
+\r
+NNUM: PUSH P,[EXP 1] ;REGISTER THE CONSTANT IN "N"\r
+ JRST N,FNUM1\r
+\f;XLATE AND GEN ATOMIC FORMULA BEGINNING WITH LETTER\r
+\r
+FLETTR: PUSHJ P,REGLTR\r
+FLET1: CAILE A,4\r
+ AOS IFFLAG\r
+ JRST .+1(A)\r
+ JRST XARFET ;ARRAY REF\r
+ JRST SNOEXI ;SCALAR. JUST RETURN\r
+ JRST XINFCN ;INTRINSIC FCN\r
+ JRST XDFFCN ;DEFINED FCN\r
+ JRST ILVAR\r
+IFN FTSTR,<\r
+ JRST XARFET\r
+ JRST XINF3+1\r
+ JRST XINF3\r
+>\r
+FLET2: PUSH P,[EXP 1] ;PUSH AN IMPLICIT PLUS SIGN ON PLIST\r
+ JRST FLET1 ;FINISH REGISTERING VARIABLE.\r
+\r
+FLET3: SKIPGE IFFLAG\r
+ POPJ P,\r
+ MOVSI D,33040\r
+ JRST N,BUILDA\r
+\r
+XARFET: PUSH P,B\r
+ PUSH P,F\r
+ PUSHJ P,REGFRE ;FREE REG\r
+ PUSHJ P,XARG\r
+ POP P,F\r
+ SKIPGE IFFLAG\r
+ SKIPL LETSW ;IS IT LH OF ARRAY-LET?\r
+ JRST XARF1\r
+ TLNN C,220000 ;IS IT DEFINITELY LH OF ARRAY-LET?\r
+ JRST XARF1 ;NO.\r
+\r
+ POP P,X1\r
+ SUB P,[XWD 6,6] ;ADJUST THE PUSHLIST TO ESC FORMLS\r
+ PUSH P,B ;SAVE THE ARGUMENT FLAG\r
+ PUSH P,X1 ;SAVE THE ARRAY POIUNTER\r
+ JRST N,XLET0\r
+\r
+XARF1: PUSH P,B\r
+ MOVSI D,(ARFET1)\r
+IFN FTSTR,<\r
+ SKIPL IFFLAG ;STR VECTOR?\r
+ MOVSI D,(SVRADR) ;YES. FETCH STRING POINTER ADDRESS.\r
+>\r
+ JUMPE B,XARFFN\r
+ SKIPL IFFLAG\r
+ FAIL <STRING VECTOR HAS 2 DIMS>\r
+ MOVSI D,(ARFET2)\r
+ MOVE X1,-1(P) ;MARK DOUBLE ARRAY\r
+ ADD X1,FLOOR(F)\r
+ SKIPN 1(X1)\r
+ SETOM 1(X1)\r
+XARFFN: POP P,B\r
+ EXCH B,0(P)\r
+ PUSHJ P,BUILDA\r
+ POP P,B\r
+ PUSHJ P,GENARG\r
+ MOVEI B,0 ;REG POINTER\r
+ SKIPL IFFLAG ;STRING VECTORS?\r
+ PUSHJ P,SITGEN ;YES,SAVE ADDRESS POINTER\r
+ JRST N,SNOEXI\r
+\f;GEN FUNCTION CALLS\r
+\r
+XDFFCN: PUSH P,D ;SAVE FCN NAME\r
+ PUSHJ P,REGFRE ;SAVE ANY SUBEXPRESSION\r
+ PUSHJ P,PUSHPR ;SAVE FUNCTION LOCATION\r
+ CAIE C,"(" ;ANY ARGS?\r
+ JRST N,XDFF2 ;NO\r
+ SETZM PSHPNT ;INITIALIZE COUNT OF PUSH INSTS GENNED\r
+XDFF1: PUSHJ P,NXCHK\r
+ PUSHJ P,FORMLN ;GEN THE ARGUMENT IN REG\r
+ PUSHJ P,GPOSGE\r
+ MOVSI D,(PUSH P,) ;BUILD ARGUMENT PUSH\r
+ PUSHJ P,BUILDA\r
+ AOS PSHPNT ;COUNT THE PUSH\r
+ AOS (P) ;ALSO SAVE THE COUNT FOR CHECK OF ARGS\r
+ TLNE C,F.COMA ;MORE ARGS?\r
+ JRST XDFF1 ;YES\r
+\r
+ TLNN C,F.RPRN ;CHECK FOR MATCHING PAREN\r
+ JRST GRONK\r
+ SETZM PSHPNT ;RESET THE PUSH COUNT AGAIN\r
+ PUSHJ P,NXCHK ;SKIP PAREN\r
+\r
+XDFF2: PUSHJ P,ARGCHK ;CHECK FOR RIGHT NUMBER OF ARGUMENTS\r
+ POP P,X1 ;GET RID OF POINTER TO ARG# CONSTANT\r
+ PUSHJ P,POPPR ;GET BACK FUNCTION LOC\r
+ MOVSI D,(GOSUB)\r
+ PUSHJ P,BUILDA ;GEN THE CALL\r
+ MOVEI B,0 ;ANSWER IS IN REG\r
+ JRST SNOEXI\r
+\r
+;ROUTINE TO CHECK NUMBER OF ARGUMENTS AND CREATE A CONSTANT TO POP THEM\r
+;OFF THE PUSH LIST. CALLED WITH XWD FCNAME,# OF ARGS\r
+;AT LOCATION -1(P) RETURNS WITH A POINTER TO CONSTANT\r
+;AT THAT LOCATION.\r
+\r
+ARGCHK: HRRZ N,-1(P)\r
+ HRL N,N ;N NOW CONTAINS THE CONSTANT TO SUBTRACT FROM P\r
+ PUSHJ P,NNUM ;REGISTER THIS CONSTANT\r
+ MOVE N,-1(P) ;GET FCN NAME\r
+ MOVEM B,-1(P) ;SAVE ADDREESS OF CONSTANT\r
+ HRR N,B ;ASSEMBLER FADROL ENTRY...\r
+ HLLZ A,N ;SETUP SEARCH ARGUMENT\r
+ MOVEI R,FADROL ; XWD FCNAME,CONSTANT ADDRESS\r
+ PUSHJ P,SEARCH\r
+ JRST ARGCH1 ;FIRST TIME FCN SEEN. PUT ENTRY IN ROLL\r
+ CAME N,0(B) ;FCN SEEN BEFORE. SAVE NUMBER OF ARGS.\r
+ FAIL <INCORRECT NUMBER OF ARGUMENTS>\r
+ POPJ P,\r
+\r
+ARGCH1: MOVEI E,1 ;ADD FCN REF TO FADROL\r
+ PUSHJ P,OPENUP\r
+ MOVEM N,(B)\r
+ POPJ P,\r
+\r
+;INTRINSIC FUNCTION GENERATOR.\r
+XINFCN: PUSH P,B ;SAVE FCN LOC\r
+ PUSHJ P,REGFRE ;PROTECT ANY PARTIAL RESULTS\r
+ CAIN C,50\r
+ JRST N,XINF1\r
+ TRNN B,40000\r
+ FAIL <INCORRECT NUMBER OF ARGUMENTS>\r
+ JRST N,XINF2\r
+XINF1: PUSHJ P,NXCHK\r
+ PUSHJ P,FORMLN\r
+ PUSHJ P,EIRGNP\r
+ PUSHJ P,XARG1+1\r
+XINF2: POP P,D\r
+ TRZ D,40000\r
+ HRLI D,260740\r
+ PUSHJ P,BUILDI\r
+ MOVEI B,0\r
+ JRST SNOEXI\r
+XINF3: PUSH P,[EXP 1]\r
+ JRST SNOEXI\r
+\f;ROUTINE TO XLATE ARGUMENTS\r
+;RETURNS WITH ARGS ON SEXROL. B IS O IF ONE ARG, -1 IF TWO.\r
+\r
+XARG: PUSHJ P,NXCHK ;SAVE PARENTHESIS.\r
+ PUSH P,LETSW ;SAVE LETSW WHILE TRANSL ARGS\r
+ MOVMS LETSW ;THE COMMA FOLLOWING AN ARG IS NOT LH(LET)!\r
+ PUSHJ P,FORMLN\r
+ PUSHJ P,GPOSNX\r
+ PUSHJ P,SITGEN\r
+ PUSHJ P,PUSHPR\r
+ MOVEI B,0\r
+ TLNN C,F.COMA ;COMMA FOLLOWS?\r
+ JRST N,XARG1 ;NO. ONE ARG.\r
+ PUSHJ P,NXCHK ;YES GEN AND SAVE SECOND ARG\r
+ PUSHJ P,FORMLN\r
+ PUSHJ P,GPOSNX\r
+ PUSHJ P,SITGEN\r
+ PUSHJ P,PUSHPR\r
+ MOVNI B,1 ;DBL ARG FLAG\r
+XARG1: POP P,LETSW ;RESTORE LETSW\r
+ TLNN C,F.RPRN ;MUST HAVE PARENTHESIS\r
+ JRST N,ILFORM\r
+ JRST N,NXCHK ;IT DOES. SKIP RPAREN AND RETURN.\r
+\r
+;ROUTINE TO GEN ARGUMENTS\r
+\r
+GENARG: JUMPE B,GENAFN ;ONE OR TWO ARGS?\r
+ PUSHJ P,POPPR ;TWO\r
+ PUSHJ P,EXCHG\r
+ PUSHJ P,GENAF1\r
+\r
+GENAFN: PUSHJ P,POPPR\r
+GENAF1: MOVSI D,(JUMP 2,)\r
+ JRST N,BUILDA\r
+\f;ROUTINE TO ANALYZE NEXT ELEMENT\r
+;CALL: PUSHJ P,REGLTR\r
+;RETURNS ROLL PNTR IN B, CODE IN A\r
+;CODE IS: 0-ARRAY, 1-SCALAR, 2-INTRINSIC FCN, 3-DEFINED FCN, 4-FAIL\r
+; 5-STRING VECTOR, 6-STRING VARIABLE, 7-STRING LITERAL.\r
+\r
+REGLTR: PUSHJ P,SCNLT1 ;LTR TO A, LEFT JUST 7 BIT\r
+ HRRI F,SCAROL ;ASSUME SCALAR\r
+ TLNE C,F.LETT ;ANOTHER LETTER?\r
+ JRST REGFCN ;YES. GO LOOK FOR FCN REF\r
+ TLNN C,F.DIG ;DIGIT FOLLOWS?\r
+ JRST REGARY ;NO, GO CHECK FOR ARRAY\r
+ DPB C,[POINT 7,A,13];ADD DIGIT TO NAME\r
+ PUSHJ P,NXCHK ;GO ON TO NEXT CHAR\r
+IFN FTSTR,<\r
+ TLNE C,F.DOLL ;STRING VARIABLE?\r
+ JRST REGSTR ;YES. REGISTER IT.\r
+>\r
+\r
+;RETURN HERE IF REGARY SAYS NOT ARRAY\r
+;RETURN HERE IF REGFCN SAYS FOLLOWED BY KEYWORD.\r
+\r
+REGL1: TLNE A,17 ;IS THIS A SCALAR?\r
+ JRST REGL1A ;NO. DON'T LOOK FOR FCN ARGUMENT\r
+ MOVE B,FLARG ;IS THIS A FN ARG?\r
+ CAML B,CEARG ;SEARCH UNORDERED ARGROL\r
+ JRST REGL1A ;NOT A FN ARG\r
+ CAME A,(B)\r
+ AOJA B,.-3 ;TRY NEXT ROLL ENTRY.\r
+\r
+ JRST FARGRF ;YES\r
+REGL1A: MOVEI R,VARROL ;NO. SCALAR\r
+ PUSHJ P,SEARCH ;IN VARIABLE ROLL?\r
+ JRST N,REGL2 ;NO\r
+\r
+ HRRZ D,(B) ;YES. GET PNTR TO SCAROL\r
+ JRST REGL3\r
+\r
+REGL2: MOVEI E,1 ;ADD TO SCALAR ROLL OR VSPROL\r
+ PUSHJ P,OPENUP\r
+ ADD A,CEIL(F) ;COMPUTE PNTR TO ROLL\r
+ SUB A,FLOOR(F)\r
+ HRRZ D,A ;SAVE ROLL POINTER\r
+ MOVEM A,(B)\r
+ MOVEI R,(F) ;PUT NULL ENTRY ON ROLL\r
+ MOVEI A,0\r
+ PUSHJ P,RPUSH\r
+\r
+; B ::= REL LOC OF ROLL ENTRY\r
+\r
+REGL3: MOVE B,D ;B ::= REL LOC OF ROLL ENTRY\r
+ TLO B,(F) ;MAKE ROLL POINTER AND SKIP\r
+ JRST REGSCA\r
+\r
+;COME HERE ON REF TO FCN ROL\r
+\r
+;CALCULATE ADDRESS OF THIS FUNCTION ARGUMENT.\r
+FARGRF: SUB B,CEARG ;NOW ADDRESS IS -NN FOR FIRST ARG, -1 FOR NNTH ARG, ETC.\r
+ HRLI B,PSHROL\r
+\r
+REGSCA: MOVEI A,1 ;CODE SAYS SCALAR\r
+ POPJ P, ;RETURN\r
+\r
+SCAREG: MOVEI F,SCAROL ;REGISTER THE CONTENTS OF A AS SCALAR\r
+ JRST REGL1A\r
+REGARY: CAIE C,"("\r
+ TLNE C,F.DOLL ;ARRAY OR POSSIBLE SRVECTOR REF?\r
+ CAIA\r
+ JRST REGL1\r
+ TLNE C,F.DOLL\r
+ JRST REGSTR\r
+REGA0: HRRI F,ARAROL ;NUMERICAL ARRAY GOES ON ARAROL\r
+\r
+REGA1: TLO A,1 ;MAKE ARRAY NAME DIFFERENT FROM SCALAR\r
+ MOVEI R,VARROL ;LOOK FOR VARIABLE NAME\r
+ PUSHJ P,SEARCH\r
+ JRST N,REGA2 ;NOT ALREADY USED\r
+ HRRZ D,(B) ;GET POINTER TO ARAROL\r
+ JRST N,REGA3\r
+\r
+REGA2: MOVEI E,1 ;ADD NEW ARRAY NAME TO VARIABLE ROLL\r
+ PUSHJ P,OPENUP\r
+ ADD A,CEIL(F) ;COMPUTE ARRAY OR STRING VECTOR ROLL POINTER\r
+ SUB A,FLOOR(F)\r
+ IORI A,400000 ;SET ARRAY FLAG\r
+ MOVEM A,(B)\r
+ HRRZ D,A ;SAVE ARAROL POINTER\r
+ MOVEI R,(F) ;THREE ZEROS ON ARAROL (NULL ENTRY)\r
+ MOVEI A,0\r
+ PUSHJ P,RPUSH\r
+ PUSHJ P,RPUSH\r
+\r
+REGA3: MOVE B,D ;RECONSTRUCT PNTR\r
+ ANDI B,377777 ;B := REL ADDRS IN ARRAY ROLL\r
+ HRLI B,(F) ;B := POINTER TO ENTRY ON ROLL\r
+ MOVEI A,0 ;ARRAY CODE\r
+ POPJ P,\r
+\r
+\r
+;SUBROUTINE TO REGISTER ARRAY NAME.\r
+;(USED BY DIM,MAT)\r
+\r
+ARRAY: HRRI F,ARAROL ;ASSUME ITS NOT A STRING\r
+ TLNN C,F.LETT\r
+ JRST REGFAL\r
+ PUSHJ P,SCNLT1 ;NAME TO A\r
+ TLNE C,F.DOLL ;STRING VECTOR?\r
+ JRST N,ARRAY2 ;YES, HANDLE DIFFERENTLY\r
+ PUSHJ P,REGA0\r
+ARRAY1: MOVE X1,B ;FINISH REGISTERING\r
+ ADD X1,FLOOR(F)\r
+ SKIPN 1(X1)\r
+ SETOM 1(X1)\r
+ POPJ P,\r
+\r
+ARRAY2: PUSHJ P,NXCHK\r
+ CAIN C,50\r
+ JRST N,ARRAY3\r
+ TLNE F,1\r
+ JRST REGSTR\r
+ARRAY3: PUSHJ P,REGSVR ;REGISTER STRING VECTOR\r
+ JRST ARRAY1 ;SET DEFAULT, IF NECESSARY\r
+\r
+VECTOR: PUSHJ P,ARRAY ;REGISTER VECTOR\r
+ CAIE A,5 ;WAS A STRING REGISTERED?\r
+ JUMPN A,CPOPJ ;WAS AN ARRAY REGISTERED?\r
+ MOVE X2,1(X1)\r
+ JUMPG X2,.+4 ;EXPLICIT DIMENSION?\r
+ MOVNI X2,777776 ;NO. CALL IT A VECTOR OF UNKNONW DIM.\r
+ MOVEM X2,1(X1)\r
+ POPJ P,\r
+ JUMPLE X2,CPOPJ\r
+ TLNE X2,777776 ;IS THIS A ROW VECTOR?\r
+ TRNN X2,777776 ;OR A COLUMN VECTOR?\r
+ POPJ P, ;YES.\r
+ FAIL <USE VECTOR, NOT ARRAY,>\r
+\r
+IFN FTSTR,<\r
+REGSTR: JUMPL F,GRONK\r
+ TLO A,10 ;MAKE STRING NAME DIFFERENT FROM OTHER NAMES.\r
+ HRRI F,VSPROL ;POINT WILL GO ON VARIABLE SPACE ROLL\r
+ TLNE C,F.DOLL ;SKIP DOLLAR SIGN?\r
+ PUSHJ P,NXCHK ;SKIP DOLLAR SIGN\r
+ CAIN C,"(" ;IS IT A STRING VECTOR?\r
+ JRST REGSVR ;YES.\r
+ PUSHJ P,REGL1 ;FIX VARIABLE TYPE CODE.\r
+ JRST REGS1\r
+\r
+REGSL1: MOVEI R,11\r
+ AOS IFFLAG\r
+ MOVE A,1\r
+ PUSHJ P,RPUSH\r
+ MOVEI R,SADROL ;MOVE LITROL ADDRESS ON STR-LIT-ADR ROLL\r
+ MOVEI A,0\r
+ PUSHJ P,RPUSH\r
+ SUB B,FLSAD ;GET REL ADRESS\r
+ HRLI B,SADROL ;SET UP POINTER.\r
+ PUSHJ P,QSKIP\r
+ JRST GRONK\r
+ JRST XINF3\r
+\f>\r
+\r
+QSKIP: PUSHJ P,NXCH ;SKIP TO NEXT QUOTE CHAR.\r
+ TLNE C,F.CR ;TERMINAL QUOTE MISSING?\r
+ POPJ P, ;YES\r
+ TLNN C,F.QUOT ;END OF STRING?\r
+ JRST QSKIP ;NO, GO ON.\r
+ PUSHJ P,NXCH ;YES. GET NEXT CHAR AND RETURN.\r
+ JRST CPOPJ1\r
+\r
+IFN FTSTR,<\r
+REGSVR: HRRI F,SVRROL ;REGISTER STRING VECTOR\r
+ TLO A,11 ;MAKE NAME DIFFERENT FROM THE OTHERS\r
+ TLNE C,F.DOLL ;DOLLAR SIGN?\r
+ PUSHJ P,NXCHK ;YES, SKIP IT\r
+\r
+ PUSHJ P,REGA1 ;REGISTER AS AN ARRAY\r
+\r
+REGS1: CAIE A,4 ;DID REGISTRATION FAIL?\r
+ ADDI A,5 ;NO. FIX TYPE CODE.\r
+ POPJ P,\r
+>\r
+\r
+;NOTE: IF THE SAME VARIABLE NAME IS USED AS A SCALAR, ARRAY,\r
+; STRING VECTOR, AND STRING, IT WILL BE DISTINGUISHED IN "VARROL"\r
+; BY THE FOLLOWING 4-BIT ENDINGS:\r
+; SCALAR 0; ARRAY 1; STRING 10; STRING VECTOR 11.\r
+\f;TABLE OF MIDSTATEMENT KEYWORDS:\r
+\r
+KWTBL: ASCII /GOTO/\r
+ ASCII /STEP/\r
+ ASCII /THEN/\r
+ ASCII /TO/\r
+ Z\r
+\r
+;REGISTER FUNCTION NAME\r
+;FIRST LETTER HAS BEEN SCANNED\r
+\r
+;IT IS POSSIBLE THAT WE HAVE SCANNED A ONE-LETTER VARIABLE NAME\r
+;FOLLOWED BY ONE OF THE KEYWORDS "TO" , "THEN", OR "STEP".\r
+;FIRST WE LOOK AHEAD TO SEE IF THIS IS SO;\r
+;IF IT IS WE GO BACK TO SCALAR CODE.\r
+\r
+REGFCN: PUSH P,C ;SAVE T,C AROUND LOOK-AHEAD.\r
+ PUSH P,T\r
+ MOVEI X1,KWTBL ;TBL OF KEYWORDS\r
+\r
+REGF1: PUSHJ P,QST ;TEST THIS KEYWORD.\r
+ JRST N,REGF2\r
+ POP P,T\r
+ POP P,C\r
+ JRST REGL1\r
+\r
+REGF2: MOVEI X1,1(X1) ;NOT CURRENT KEYWORD\r
+ MOVE T,(P) ;RESTORE POINTERS DESTROYED BY QST\r
+ MOVE C,-1(P)\r
+ SKIPE (X1) ;MORE TO TEST?\r
+ JRST REGF1 ;YES\r
+ POP P,T ;NO, NOT KEYWORD.\r
+ POP P,C\r
+;HAVE DETERMINED THAT WE MUST BE SCANNING A FUNCTION NAME\r
+;IF SYNTAX IS LEGAL.\r
+\r
+;WE SCAN THE SECOND LETTER AND CHECK FOR\r
+;INTRINSIC OR DEFINED FUNCTION.\r
+\r
+\r
+ PUSHJ P,SCNLT2\r
+ JRST REGFAL ;NOT A LETTER\r
+ CAMN A,[SIXBIT /FN/] ;DEFINED FUNCTION?\r
+ JRST REGDFN ;YES. GO REGISTER DEFINED NAME.\r
+\r
+ PUSHJ P,SCNLT3\r
+ JRST REGFAL\r
+ MOVEI R,4\r
+ PUSHJ P,SEARCH\r
+ JRST REGFAL\r
+ MOVMS LETSW ;CAN'T BE LH(LET)\r
+ HRRZ B,(B)\r
+ MOVEI A,2 ;INTRINSIC FCN CODE.\r
+ POPJ P, ;RETURN "XINFNC" DOES ITS OWN ")" CHECK.\r
+\f;HERE TO REGISTER DEFINED FUNCTION NAME\r
+;THE "FN" HAS ALREADY BEEN SCANNED\r
+\r
+;SCAN IDENTIFYING LETTER AND PUTTING ENTRY IN\r
+;FUNCTION CALL ROLL\r
+\r
+REGDFN: PUSHJ P,SCNLT1 ;PUT FUNCTION NAME IN A\r
+ CAMN A,FUNAME ;IS THIS THE NAME OF THE CURRENT MULTI-LINE FN?\r
+ JRST REGFNA ;YES. REGISTER IT AS A SCALAR.\r
+ MOVE D,A ;NO, REAL FUNCTION CALL. SAVE NAME FOR ARGCHK\r
+ MOVEI R,FCLROL ;FUNCTION CALL ROLL\r
+ PUSHJ P,SEARCH ;USED THIS ONE YET?\r
+ JRST .+2\r
+ JRST REGFC1 ;ALREADY SEEN A REF\r
+ MOVEI E,1\r
+ PUSHJ P,OPENUP\r
+ MOVEM A,(B)\r
+ PUSHJ P,REGFC1 ;SET B UP FOR KLUDGE TEST\r
+ MOVE X1,FLSEX ;FIX UP SAVED FCN REFS\r
+REGFC0: CAML X1,CESEX ;KLUDGE!!!\r
+ JRST N,REGFC1+1\r
+ HLRZ X2,(X1) ;GET THE ROLL NUMBER\r
+ CAIN X2,FCLROL ;FCLROL?\r
+ CAMLE B,(X1) ;YES. IS SEXREF NOW WRONG?\r
+ AOJA X1,REGFC0\r
+ AOS (X1) ;YES. CORRECT IT\r
+ AOJA X1,REGFC0\r
+\r
+REGFC1: SUB B,FLFCL\r
+ HRLI B,FCLROL\r
+ MOVEI A,3 ;DEFINED FCN CODE\r
+ POPJ P, ;DON'T CHECK FOR () YET\r
+\r
+CHKPRN: CAIE C,"("\r
+REGFAL: MOVEI A,4 ;FAIL IF NO PAREN\r
+ POPJ P,\r
+\r
+REGFNA: TLO A,(177B13) ;CREATE SPECIAL NAME FOR CURRENT FUNCTION\r
+ JRST N,SCAREG ;REGISTER IT AS A SCALAR\r
+\f SUBTTL SUBROUTINES USED BY GEN ROUTINES\r
+\r
+;PUSHPR - PUSH PARTIAL RESULT ON SEXROL\r
+\r
+PUSHPR: MOVEI R,SEXROL\r
+ MOVE A,B ;SAVE POINTER IN A\r
+ PUSHJ P,RPUSH\r
+ SUB B,FLSEX ;MAKE POINTER\r
+ TLNN A,ROLMSK ;IS IT A POINTER TO REG?\r
+ HRROM B,REGPNT ;YES, SET POINTER FOR SITGEN TO USE\r
+ POPJ P,\r
+\r
+;POPPR - POP PARTIAL RESULT FROM SEXROL\r
+\r
+POPPR: MOVEI R,SEXROL\r
+ MOVE B,CESEX\r
+ SUBI B,1 ;COMPUTE ADDRS OF TOP OF SEXROL\r
+ PUSH P,(B) ;SAVE THE CONTENT\r
+ MOVEI E,1\r
+ PUSHJ P,CLOSUP\r
+ POP P,B ;POPPED POINTER TO B\r
+POPPFN: TLNN B,ROLMSK ;POINTER TO REG?\r
+ SETZM REGPNT ;YES. CLEAR MEMORY\r
+ POPJ P,\r
+;EXCHG - EXCHANGE CURRENT PNTR WITH TOP OF SEXROL\r
+\r
+EXCHG: MOVE X1,CESEX\r
+ MOVEI X2,-1(X1) ;FIX PNTR IF REG SAVED\r
+ SUB X2,FLSEX\r
+ TLNN B,ROLMSK\r
+ HRROM X2,REGPNT\r
+ EXCH B,-1(X1)\r
+ JRST POPPFN ;GO FIX PNTR IF REG POPPED\r
+\r
+;REGFRE - GUARANTEE THAT NO PART RESULT IS IN REG\r
+\r
+REGFRE: SKIPN REGPNT ;SUBEXP IN THE REG?\r
+ POPJ P, ;NO\r
+ MOVE X1,FLSEX ;YES. COMPUTE WHERE\r
+ ADD X1,REGPNT\r
+ EXCH B,(X1) ;GET THE POINTER, SAVE CURR PNTR\r
+ PUSHJ P,SITGEN ;STORE IN TEMP\r
+ MOVE X1,FLSEX ;RECOMPUTE LOC IN SEXROL\r
+ ADD X1,REGPNT\r
+ EXCH B,(X1)\r
+ SETZM REGPNT ;CLOBBER REGPNT SINCE REG IS EMPTY\r
+ POPJ P,\r
+\f;GPOSGE - GUARANTEE POSITIVE GEN\r
+\r
+GPOSGE: JUMPGE B,CPOPJ ;RETURN IF ALREADY POSITIVE\r
+ ;FALL INTO EIRGEN\r
+\r
+;EIRGEN - EXP IN REG GEN\r
+\r
+EIRGEN: TLNN B,ROLMSK ;ALREADY IN REG?\r
+ POPJ P, ;DO NOTHING\r
+ERGNFN: PUSHJ P,REGFRE ;FREE UP REG\r
+ MOVSI D,(MOVE N,) ;GET MOVE INSTR\r
+ PUSHJ P,BUILDS ;BUILD MOVE INSTR\r
+ MOVEI B,0 ;POSITIVE REG POINTER\r
+ POPJ P,\r
+\r
+;EIRGNP - EXP IN REG GEN POSITIVE\r
+\r
+EIRGNP: JUMPGE B,EIRGEN ;POSITIVE?\r
+ TLNE B,ROLMSK ;NO. IN REG?\r
+ JRST ERGNFN ;NO. GO MOVE\r
+ MOVSI D,(MOVN N,) ;YES,NEGATIVE N\r
+ PUSHJ P,BUILDI\r
+ MOVEI B,0 ;POSITIVE REG PNTR\r
+ POPJ P,\r
+\r
+;SIPGEN - STORE IN PERMANENT TEM GEN\r
+\r
+SIPGEN: MOVEI R,PTMROL\r
+ JRST SITGN1\r
+\r
+;SITGEN - STORE IN TEMP GEN\r
+\r
+SITGEN: MOVEI R,TMPROL\r
+SITGN1: TLNE B,ROLMSK ;IS EXPR IN REG?\r
+ POPJ P, ;NO. DONT DO ANYTHING\r
+ MOVEI A,0 ;PREPARE ZERO TO PUSH ON ROLL\r
+ MOVSI D,(MOVEM N,) ;GET CORRECT INSTR\r
+ JUMPGE B,.+2\r
+ MOVSI D,(MOVNM N,)\r
+ CAIE R,TMPROL ;STORE ON TMPROL?\r
+ JRST N,SITG2 ;NO. USE PTMROL\r
+ AOS B,TMPPNT ;WHICH TEMP TO USE?\r
+ MOVE X1,FLTMP\r
+ ADD X1,B\r
+ CAML X1,CETMP ;NEED MORE TMP SPACE?\r
+ PUSHJ P,RPUSH ;YES. PUSH Z ZERO ONTO TMPROL\r
+ MOVE B,TMPPNT ;CONSTRUCT TMP ROLL POINTER\r
+SITG1: HRLI B,(R)\r
+ PUSH P,B ;SAVE ADRESS POINTER\r
+ PUSHJ P,BUILDA ;BUILD STORE INSTR\r
+ POP P,B ;RECONSTRUCT POINTER\r
+ POPJ P,\r
+\r
+SITG2: PUSHJ P,RPUSH ;PUSH A ZERO ONTO PTMROL\r
+ SUB B,FLPTM\r
+ JRST SITG1 ;FINISH CONSTRUCTING ADRESS POINTER\r
+;GPOSNX - GUARANTEE POSITIVE AND UNINDEXED GEN\r
+\r
+GPOSNX: TLNE B,400000+PSHROL ;NEGATIVE OR INDEXED BY (P)?\r
+ PUSHJ P,EIRGNP ;YES. FORCE INTO REG\r
+ POPJ P,\r
+\fBUILDP: TLO D,P ;INSTRUCTION IS INDEXED BY PLIST POINTER\r
+ SUB B,PSHPNT ;ADJUST THE ADDRESS FOR ANY PUSH INSTS GENNED BY\r
+ HRR D,B ; A CURRENT FN CALL\r
+\r
+;ROUTINE TO ADD CODE TO CODROL.\r
+;A WORD IS ASSUMED IN D\r
+;RETURN REL ADDRS IN B\r
+\r
+BUILDI: SKIPN RUNFLA ;ARE WE GOING TO RUN?\r
+ POPJ P, ;NO. DONT GEN CODE\r
+ MOVEI E,1\r
+ MOVEI R,CODROL\r
+ PUSHJ P,BUMPRL\r
+ MOVEM D,(B)\r
+ SUB B,FLCOD\r
+ POPJ P,\r
+\r
+\r
+;BUILD SIGNED INSTRUCTION WITH ADDRESS\r
+;CHECK SIGN IN B AND CHANGE UP CODE BITS\r
+\r
+BUILDS: JUMPGE B,BUILDA ;POSITIVE?\r
+ TLC D,10000 ;NO. CHANGE MOVE TO MOVN, ETC.\r
+ ;FALL INTO BUILDA\r
+\r
+;BUILDA - BUILD INSTRUCTION WITH LINKED ADDRESS\r
+;INSTRUCTION SKELETON IS IN D, ADDRESS POINTER IS IN B\r
+\r
+BUILDA: SKIPN RUNFLA ;ARE WE GOING TO RUN?\r
+ POPJ P, ;NO. DONT BUILD\r
+ TLZE B,PSHROL ;SPECIAL TEST FOR ROLL WITH ABSOLUTE ADDRESS\r
+ JRST BUILDP ;YES. PSHROL. DO BUILDI INDEXED BY (Q)\r
+ JUMPE B,BUILDI ;ITEM IS IN REG . USE ADDRESS ZERO\r
+\r
+ PUSH P,B ;SAVE THE POINTER\r
+ PUSHJ P,BUILDI ;ADD INSTR WITH 0 ADDRS TO CODE\r
+ MOVE X1,CECOD ;LOC+1 OF THE INSTR\r
+ POP P,X2 ;COMPUTE ADDRS LOCATION\r
+ LDB R,[POINT 17,X2,17]\r
+ ADD X2,FLOOR(R)\r
+ MOVE Q,(X2) ;GET NEXT ADDRS IN CHAIN\r
+ HRRM Q,-1(X1) ;STORE IT IN THE INSTR\r
+ SUB X1,FLCOD\r
+ SUBI X1,1\r
+ HRRM X1,(X2) ;STORE CURR ADDRS IN ROLL PNTD TO\r
+ POPJ P,\r
+\f SUBTTL UTILITY SUBROUTINES\r
+;SUBROUTINES FOR GENERAL ROLL MANIPULATION\r
+\r
+CLOSUP: MOVN X1,E ;COMPUTE NEW END OF ROLL\r
+ ADDB X1,CEIL(R) ;AND STORE IT\r
+ MOVE X2,B ;CONSTRUCT BLT WORD\r
+ ADD X2,E\r
+ MOVS X2,X2\r
+ HRR X2,B\r
+ BLT X2,-1(X1) ;MOVE DOWN TOP OF ROLL\r
+ POPJ P,\r
+\r
+CLOB: MOVEI T1,COMTOP ;ROUTINE TO CLOBBER ALL MOVEABLE ROLLS.\r
+ MOVEM T,FLOOR(T1)\r
+ MOVEM T,CEIL(T1)\r
+ CAILE T1,1(X1) ;DO NOT CLOBBER ROLLS <=(X1)\r
+ SOJA T1,CLOB+1\r
+ POPJ P,\r
+\r
+\r
+\r
+OPEN2: MOVE X2,E ;IS THERE ROOM ABOVE THIS STODGY ROLL?\r
+ ADD X2,CEIL(R) ;THE NEW CEILING\r
+ CAMLE X2,FLOOR+1(R)\r
+ JRST N,OPENU0 ;NO ROOM, PACK OTHER ROLLS UP\r
+ ADDM E,CEIL(R) ;THERE IS ROOM, INCREMENT CEILING\r
+ POPJ P,\r
+\r
+OPENU0: SUB B,FLOOR(R)\r
+ PUSHJ P,PANIC\r
+ ADD B,FLOOR(R)\r
+\r
+OPENUP: CAMG R,TOPSTG ;OPEN UP THE TOP STODGY ROLL?\r
+ JRST N,OPEN2 ;YES. OPEN UPWARDS, NOT DOWN\r
+ MOVN X2,E\r
+ MOVE Q,TOPSTG ;DO NOT MOVE STODGY ROLLS\r
+ ADD X2,FLOOR+1(Q)\r
+ CAMGE X2,CEIL+0(Q)\r
+ JRST N,OPENU0 ;NEED MORE ROOM\r
+ HRL X2,FLOOR+1(Q) ;CONTRUCT BLT WORD\r
+ SUB B,E ;FIRST WORD OF GAP\r
+ BLT X2,-1(B) ;MOVE ROLLS DOWN\r
+\r
+ MOVEI X1,1(Q) ;ADJUST POINTERS FOR ROLLS JUST BLT'D\r
+ MOVN X2,E\r
+OPEN1: ADDM X2,FLOOR(X1)\r
+ CAML X1,R\r
+ POPJ P,\r
+ ADDM X2,CEIL(X1)\r
+ AOJA X1,OPEN1\r
+\r
+\r
+;RPUSH - PUSH A ON TOP OF DESIGNATED ROLL\r
+\r
+RPUSH: MOVEI E,1\r
+ PUSHJ P,BUMPRL ;MAKE ROOM\r
+ MOVEM A,(B) ;STORE WORD\r
+ POPJ P,\r
+\r
+;ROUTINE TO ADD TO END OF ROLL\r
+;E CONTAINS SIZE, R CONTAINS ROLL NUMBER\r
+\r
+BUMPRL: MOVE B,CEIL(R)\r
+ ADD B,E\r
+ CAIE R,ROLTOP\r
+ SKIPA X1,FLOOR+1(R)\r
+ HRRZ X1,JOBREL\r
+ CAMLE B,X1\r
+ JRST N,BUMP1\r
+ EXCH B,CEIL(R)\r
+ POPJ P,\r
+BUMP1: MOVE B,CEIL(R)\r
+ CAIE R,CODROL\r
+ CAIN R,SEXROL\r
+ JRST N,.+2\r
+ JRST N,OPENUP\r
+ ADDI E,^D10 ;***EXTRA 10 LOCS\r
+ PUSHJ P,OPENUP\r
+ MOVNI X1,^D10 ;TAKE BACK THE 10 LOCS\r
+ ADDM X1,CEIL(R)\r
+ POPJ P,\r
+\r
+\r
+;BINARY SEARCH OF SORTED ROLL\r
+;CALL WITH KEY IN A\r
+;RETURN IN B ADDRS OF FIRST\r
+;ENTRY NOT LESS THAN KEY\r
+;SKIP RETURN IF LEFT SIDES EQUAL\r
+\r
+SEARCH: MOVE B,FLOOR(R)\r
+ SKIPA X1,CEIL(R)\r
+SEAR1: MOVEI B,1(X2)\r
+ CAIGE B,(X1)\r
+ JRST SEAR2\r
+ CAML B,CEIL(R)\r
+ POPJ P,\r
+ JRST SEAR3\r
+\r
+SEAR2: MOVEI X2,@X1\r
+ ADD X2,B\r
+ ASH X2,-1\r
+ CAMLE A,(X2)\r
+ JRST SEAR1\r
+ HRRI X1,0(X2)\r
+ CAIGE B,0(X1)\r
+ JRST SEAR2\r
+\r
+SEAR3: HLLZ Q,(B)\r
+ CAMN Q,A\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+\f;ROUTINE TO QSA FOR "THEN" OR "GOTO" (USED IN "IF", "ON" STATEMENTS)\r
+THENGO: PUSHJ P,QSA\r
+ ASCIZ /THEN/\r
+ CAIA\r
+ POPJ P,\r
+ PUSHJ P,QSA\r
+ ASCIZ /GOTO/\r
+ FAIL <ILLEGAL FORMAT>\r
+ POPJ P,\r
+\r
+;COMMON SUBROUTINE RETURNS\r
+\r
+CPOPJ1: AOS (P)\r
+CPOPJ: POPJ P,\r
+\r
+;ERROR RETURNS\r
+\r
+ILFORM: FAIL <ILLEGAL FORMULA>\r
+ILVAR: FAIL <ILLEGAL VARIABLE>\r
+GRONK: FAIL <ILLEGAL FORMAT>\r
+ILLINS: FAIL <ILLEGAL INSTRUCTION>\r
+\r
+\r
+;COMPILATION ERROR\r
+\r
+\r
+FAILER: SKIPN RUNFLA ;IS THIS THE FIRST ERROR IN COMPILATION?\r
+ JRST FAIL0 ;NO.\r
+ PUSHJ P,INLMES ;YES. SETUP <CRLF> TO FOLLOW HEADING.\r
+ ASCIZ /\r
+/\r
+FAIL0: PUSHJ P,FAIL1\r
+ JRST NXTST1\r
+FAIL1: MOVE T,40\r
+FAILR: MOVEI D,0\r
+ PUSHJ P,PRINT\r
+ LDB X1,[POINT 4,40,12] ;IS AC FIELD NONZERO?\r
+ JUMPE X1,FAIL2\r
+ MOVE T,N ;ATTACH NUMBER IN 'N' TO MSG\r
+ PUSHJ P,PRTNUM\r
+FAIL2: PUSHJ P,INLMES\r
+ ASCIZ / IN /\r
+ MOVE T,L\r
+ ADD T,FLLIN\r
+ HLRZ T,(T)\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ SETZM RUNFLA\r
+ POPJ P,\r
+\r
+;ROUTINES TO ALLOW AND DELAY REENTRY.\r
+;LOCKON TEMPORARILY PREVENTS REENTRY\r
+;LOCKOF ALLOWS REENTRY AND REENTERS IF THERE IS A STANDING REQUEST\r
+;REENTR MAKES A REENTRY OR MAKES A REQUEST AND CONTINUES\r
+\r
+LOCKON: SKIPGE RENFLA\r
+ SETZM RENFLA ;TURN ON REENETER PROTECT\r
+ POPJ P,\r
+LOCKOF: SKIPLE RENFLA\r
+ JRST BASIC ;ACT ON OLD REENTER REQUEST\r
+ SETOM RENFLA ;ALLOW REENTER\r
+ POPJ P,\r
+REENTR: SKIPGE RENFLA\r
+ JRST BASIC\r
+ AOS RENFLA\r
+ JRST 2,@JOBOPC\r
+\f;ROUTINE TO READ CHARACTER, SKIPPING BLANKS\r
+;CALL: MOVE T,<POINTER TO CHAR BEFORE FIRST>\r
+; PUSHJ P,NXCH\r
+; ... RETURN, C:= (<FLAGS>)CHARACTER\r
+\r
+NXCHS: ILDB C,T ;DOESNT SKIP TAB OR BLANK\r
+NXCHD: CAIE C," "\r
+ CAIN C,11\r
+ POPJ P,\r
+ CAIA ;SKIP INTO NXCH\r
+NXCH: ILDB C,T ;FETCH NEXT CHARACTER\r
+ HLL C,CTTAB(5)\r
+ TRNE C,100\r
+ HRL C,CTTAB-100(5)\r
+ TLNE C,F.SPTB ;SPACE OR TAB?\r
+ JRST N,NXCH ;YES. IGNORE\r
+ POPJ P,\r
+;GET NEXT CHAR, BUT CHECK FOR ILLEGAL CHARS (CHARS THAT COULD ONLY BE IN A STRING)\r
+NXCHK: PUSHJ P,NXCH\r
+ TLNE C,F.STR\r
+ FAIL <ILLEGAL CHARACTER>\r
+ POPJ P,\r
+\r
+;SCAN INITIAL LETTER, LETTER IS PLACED LEFT\r
+;JUSTIFIED IN A, 7-BIT ASCII.\r
+\r
+SCNLT1: HRRZ A,C\r
+ ROT A,-7\r
+ JRST NXCH\r
+\r
+;SCAN SECOND LETTER, NON-SKIP RETURN IF NOT LETTER.\r
+;MAKE 7-BIT LETTER LEFT JUST IN A\r
+;INTO 6-BIT. THAN PUT 6-BIT CURRENT LETTER IN A.\r
+\r
+SCNLT2: TLNN C,F.LETT\r
+ POPJ P,\r
+SCN2: TLNN A,400000 ;ENTER HERE TO PROCESS NON-LETTER CHARS\r
+ TLZA A,200000\r
+ TLO A,200000\r
+ LSH A,1\r
+ MOVE X1,[POINT 6,A,5]\r
+ JRST SCNLTN\r
+\r
+;ENTER HERE TO SCAN SECOND CHAR EVEN IF BOTH ARE NOT LETTERS.\r
+\r
+\r
+;SCAN THIRD LETTER, NON-SKIP IF NOT LETTER.\r
+;PUT 6-BIT LETTER TO 3RD 6-BIT FIELD IN A.\r
+\r
+SCNLT3: TLNN C,F.LETT\r
+ POPJ P,0\r
+ MOVE X1,[POINT 6,A,11]\r
+\r
+;NOW PUT 6-BIT LETTER INTO A, ADJUSTING LOWER CASE, INCREMENTING POINTER.\r
+\r
+SCNLTN: TLNN C,F.LCAS\r
+ TRC C,40\r
+ IDPB C,X1\r
+ AOS (P)\r
+ JRST NXCH\r
+\f;QUOTE SCAN AND TEST\r
+;CALL WITH PATTERN ADDRS IN X1\r
+;SKIP IF EQUAL. C,T UPDATED TO LAST CHAR SCANNED.\r
+QST: HRLI X1,440700 ;MAKE BYTE PNTR TO PATTERN\r
+QST1: ILDB X2,X1 ;GET PATTERN CHAR\r
+ JUMPE X2,CPOPJ1 ;DONE ON NULL\r
+ SUBI X2,(C)\r
+ JUMPE X2,.+4 ;DO CHARACTERS MATCH?\r
+ TLNE C,F.LCAS ;NO. LOWER CASE LETTER?\r
+ CAME X2,[ EXP -40] ;YES. SAME LETTER OF ALPHABET?\r
+ JRST QST2 ;NO. MATCH FAILS\r
+ PUSHJ P,NXCH\r
+ JRST QST1\r
+QST2: ILDB X2,X1 ;ON FAIL\r
+ JUMPN X2,.-1 ;SKIP TO NULL\r
+ POPJ P,\r
+\r
+\r
+;QUOTE SCAN OR FAIL\r
+;CALL WITH INLINE PATTERN\r
+;GO TO GRONK IF NO MATCH\r
+\r
+QSF: POP P,X1\r
+ PUSHJ P,QST\r
+ JRST GRONK\r
+ JRST 1(X1)\r
+\r
+;QUOTE SCAN WITH ANSWER\r
+;CALL WITH INLINE PATTERN\r
+;SKIP ON SUCCESS ;ON FAIL, RETURN WITH C,T RESTORED\r
+\r
+QSA: POP P,X1 ;GET PATTERN ADDRESS\r
+ PUSH P,C ;SAVE C,T\r
+ PUSH P,T\r
+ PUSHJ P,QST ;SAVE STRING\r
+ JRST .+2\r
+ JRST QSA1 ;MATCH\r
+ POP P,T ;NO MATCH. BACK UP\r
+ POP P,C\r
+ JRST 1(X1)\r
+\r
+QSA1: POP P,14\r
+ POP P,14\r
+ JRST 2(X1)\r
+\r
+;ROUTINE TO READ NEXT INTEGER FROM SCANNED LINE\r
+;CALL: MOVE T,POINTER TO FIRST CHAR\r
+; PUSHJ P,GETNUM\r
+; ... FAIL RETURN\r
+; ... SUCCESS RETURN, INTEGER IN N\r
+\r
+GETNU: TDZA X1,X1 ;GET A NUMBER OF ANY LENGTH\r
+GETNUM: MOVEI X1,5 ;GET A NUMBER OF AT MOST 5 DIGS\r
+ TLNN C,F.DIG ;NUMERAL?\r
+ POPJ P, ;NO. FAIL RETURN\r
+ MOVEI N,-60(C) ;YES. ACCUMULATE FIRST DIGIT\r
+GETN1: MOVE G,T ;SAVE PNTR FOR USE BY INSERT\r
+ PUSHJ P,NXCH ;GET NEXT CHAR\r
+ SOJE X1,CPOPJ1 ;EXIT IF FIVE DIGITS ALREADY\r
+ TLNN C,F.DIG ;NUMERAL?\r
+ JRST CPOPJ1 ;NO. RETURN.\r
+ IMULI N,^D10 ;YES. ACCUMULATE NUMBER\r
+ ADDI N,-60(C)\r
+ JRST GETN1 ;GO FOR MORE\r
+;ROUTINE TO READ A LINE INTO LINB0\r
+;CALL: PUSHJ P,INLINE\r
+\r
+INLINE: SETOM TYI+2\r
+ MOVE T,[POINT 7,LINB0]\r
+ MOVEI T1,0\r
+ JRST N,INLI1A\r
+\r
+INLI1: ILDB C,TYI+1 ;GET CHAR\r
+ CAIN C,15 ;CR??\r
+ JRST INLI1A\r
+ JUMPE C,INLI1A\r
+ CAIN C,"_" ;DELETE?\r
+ JRST INLI3 ;YES\r
+ CAIE C,30\r
+ CAIN C,FUNSTA\r
+ JRST N,INLI4\r
+ CAIE C,21 ;IGNORE XON,XOFF\r
+ CAIN C,23\r
+ SOJA T1,INLI1A\r
+ CAIG C,14 ;LINE TERMINATOR?\r
+ CAIGE C,12\r
+ CAIA\r
+ JRST INLI2 ;YES. GO FINISH UP\r
+ CAIGE T1,^D94 ;ROOM FOR CHAR+1 MORE?\r
+ IDPB C,T ;STORE CHAR\r
+INLI1A: SOSLE TYI+2 ;MORE INPUT?\r
+ AOJA T1,INLI1 ;YES. BUMP COUNT AND GO GET MORE\r
+ INPUT\r
+ STATZ 20000\r
+ JRST BASIC\r
+ STATO 740000\r
+ AOJA T1,INLI1\r
+ PUSHJ P,TTYIN\r
+ PUSHJ P,INLMES\r
+ ASCIZ /SYSTEM ERROR/\r
+ JRST N,BASIC\r
+INLI2: MOVEI C,15 ;DONE. PUT CR IN BFR\r
+ IDPB C,T\r
+ MOVE T,[POINT 7,LINB0]\r
+ SETZM HPOS\r
+ JRST NXCH\r
+INLI3: JUMPE T1,INLI1A ;BACKARROW HANDLER, IGNORE IF AT LEFT\r
+ MOVEI C,4\r
+ IBP T\r
+ SOJG C,.-1\r
+ SUBI T1,2\r
+ SOJA T,INLI1A\r
+INLI4: MOVEI T,INLI5\r
+ CALL T,[SIXBIT /DDTOUT/]\r
+ JRST INLINE\r
+INLI5: ASCIZ / DELETED\r
+/\r
+\r
+;ROUTINE TO START READING NEXT LINE OF PROGRAM\r
+NXLINE: MOVE T,FLLIN\r
+ ADDI T,(L)\r
+ MOVE T,(T)\r
+ MOVS D,T ;SAVE LINE START\r
+ HRLI T,440700\r
+ MOVE G,FLREF ;SETUP REFROL REFERENCE.\r
+ ADDI G,(L)\r
+ JRST NXCH\r
+;PRINTING SUBROUTINES\r
+\r
+;PRINT TO QUOTE CHAR\r
+;CALL: MOVE T,<ADDRS OF MSG>\r
+; MOVE D,<QUOTE CHAR>\r
+; PUSHJ P,PRINT\r
+;CALL: MOVE T,<ADDRS OF MSG>\r
+; MOVE D,<QUOTE CHAR>\r
+; PUSHJ P,PRINT\r
+;ALTERNATE CALL: PRINT1, IF BYTE PNTR IN T.\r
+\r
+\r
+PRINT: HRLI T,440700\r
+PRINT1: ILDB C,T\r
+ CAMN C,D\r
+ POPJ P,\r
+ PUSHJ P,OUCH ;OUTPUT THE CHAR\r
+ JRST PRINT1\r
+OUCH: SOSG TYO+2\r
+ OUTPUT\r
+ IDPB C,TYO+1\r
+ CAIE C,12\r
+ AOSA HPOS\r
+ SETZM HPOS\r
+ POPJ P,\r
+\f;ROUTINE TO PRINT SIXBIT CHARACTERS IN ACCUM "T".\r
+;IGNORES BLANKS.\r
+\r
+\r
+PRNSIX: MOVE T1,[POINT 6,T]\r
+ ILDB C,T1\r
+ JUMPE C,PRNS1 ;SKIP A BLANK\r
+ ADDI C,40\r
+ PUSHJ P,OUCH\r
+PRNS1: TLNE T1,770000 ;ALL SIX PRINTED?\r
+ JRST PRNSIX+1\r
+ POPJ P,\r
+PRNS2: JUMPE X1,PRDE2\r
+ MOVE T,X1\r
+ PUSHJ P,PRDE1\r
+ MOVE C,A\r
+ PUSHJ P,OUCH\r
+\f;SPECIAL DECIMAL PRINT ROUTINE. PRINTS X1,X2 AS DECIMAL NUMBERS\r
+;SEPARATED BY THE CHARACTER IN ACCUM "A".\r
+;IF X1 OR X2 ARE ZERO, THEY PRINT AS "00".\r
+\r
+PRDE2: MOVE T,X2\r
+ PUSHJ P,PRDE1\r
+ MOVE C,A\r
+PRDE2A: PUSHJ P,OUCH\r
+ MOVE T,Q\r
+ MOVEI A,177\r
+PRDE1: MOVEI C,"0" ;A ONE DIGIT NUMBER?\r
+ CAIG T,^D9\r
+ PUSHJ P,OUCH ;YES. PUT OUT LEADING ZERO.\r
+ JRST PRTNUM\r
+PTIME: SKIPE N,174\r
+ SKIPN MTIME\r
+ POPJ P,\r
+RTIME: PUSHJ P,INLMES\r
+ ASCIZ /\r
+\r
+TIME: /\r
+ CALL X2,[SIXBIT /RUNTIM/] ;GET TIME NOW.\r
+ SUB X2,MTIME ;GET ELAPSED TIME.\r
+ IDIVI X2,^D10 ;REMOVE THOUSANDS.\r
+ IDIVI X2,^D100 ;SECS TO X1, THENTS AND HUNDREDS TO X2.\r
+ MOVE T,X2 ;OUTPUT THE\r
+ JUMPE X2,.+2\r
+ PUSHJ P,PRTNUM ;SECONDS.\r
+ MOVEI C,"." ;OUTPUT ., THE TENTHS,\r
+ PUSHJ P,PRDE2A ;AND THE HUNDREDTHS.\r
+ PUSHJ P,INLMES\r
+ ASCIZ / SECS.\r
+/\r
+ SETZM MTIME\r
+ OUTPUT\r
+ POPJ P,\r
+\r
+;NUMBER PRINTER (PRINTS INTERGER IN T)\r
+\r
+\r
+PRTNUX: TDZA X1,X1\r
+PRTNX1: MOVE X1,B\r
+ MOVEI X1,5(X1)\r
+ PUSHJ P,CHROOM\r
+ PUSHJ P,PSIGN\r
+PRTNUM: IDIVI T,^D10\r
+ JUMPE T,PRTN1\r
+ PUSH P,T1\r
+ PUSHJ P,PRTNUM\r
+ POP P,T1\r
+PRTN1: MOVEI C,60(T1)\r
+ JRST OUCH\r
+PSIGN: MOVEI C," " ;PRINT "SIGN" (BLANK OR MINUS)\r
+ JUMPGE N,.+2\r
+ MOVEI C,55\r
+ JRST OUCH\r
+\r
+\r
+;MESSAGE PRINTER\r
+\r
+INLMES: EXCH T,(P) ;GET MSG ADR AND SAVE T.\r
+ MOVEI D,0 ;END ON NULL\r
+ PUSHJ P,PRINT\r
+ EXCH T,(P)\r
+ JRST CPOPJ1 ;RTN AFTER MSG.\r
+\f SUBTTL CORE COMPRESSION AND EXPANSION\r
+;PANIC - ROUTINE TO COMPRESS CORE\r
+\r
+PANIC: PUSHJ P,PRESS ;COMPRESS MEMORY\r
+ MOVE Q,TOPSTG ;IS THERE ROOM BETWEEN STODGY AND\r
+ MOVE X1,FLOOR+1(Q) ;MOVEABLE ONES?\r
+ SUB X1,CEIL(Q)\r
+ CAML X1,E ;ENOUGH ROOM?\r
+ POPJ P,\r
+\r
+ MOVE X1,JOBREL ;EXPAND BY 1K\r
+ ADDI X1,2000\r
+ CALL X1,[SIXBIT /CORE/]\r
+ JRST N,PANIC1\r
+ JRST N,PANIC\r
+PANIC1: PUSHJ P,INLMES\r
+ ASCIZ /OUT OF ROOM/\r
+ JRST N,UXIT\r
+\r
+PRESS: PUSH P,G ;SAVE AC\r
+ SKIPN PAKFLA ;ARE LINES PACKED?\r
+ JRST PRESS5 ;YES\r
+ SETZM PAKFLA\r
+\r
+ MOVE X1,FLTXT ;LOOK FOR EMPTY SPACE\r
+PRESS2: CAML X1,CETXT ;THROUGH LOOKING?\r
+ JRST PRESS5\r
+ SKIPE (X1) ;A FREE WORD?\r
+ AOJA X1,PRESS2 ;NO\r
+\r
+ MOVEI X2,1(X1) ;YES\r
+PRESS3: CAML X2,CETXT\r
+ JRST PRESS4 ;FREE TO END\r
+ SKIPN (X2)\r
+ AOJA X2,PRESS3\r
+\r
+ SUB X1,X2 ;X1 :=-LNG OF MOVE\r
+ MOVE Q,FLLIN\r
+PRES3A: CAML Q,CELIN ;MOVE DOWN THE REFERENCES\r
+ JRST PRES3B ;IN THE LINE ROLL\r
+ HRRZ G,(Q)\r
+ CAML G,X2\r
+ ADDM X1,(Q)\r
+ AOJA Q,PRES3A\r
+\r
+PRES3B: MOVE G,CETXT ;MOVE DOWN THE TEXT ROLL\r
+ ADD G,X1\r
+ MOVEM G,CETXT\r
+ ADD X1,X2\r
+ HRL X2,X1\r
+ MOVSS X2\r
+ BLT X2,-1(G)\r
+ JRST PRESS2\r
+\r
+PRESS4: MOVE Q,X1\r
+\r
+;ROUTINE TO MOVE ROLLS UP\r
+\r
+ SUB Q,X1\r
+ ADDM Q,CETXT\r
+PRESS5: MOVEI G,ROLTOP ;HIGHEST MOVABLE ROLL\r
+ MOVE X1,JOBREL ;X1 IS PREVIOUS FLOOR\r
+ ;NOTE: TOP WORD OF USR CORE IS LOST\r
+\r
+PRESS6: MOVE X2,CEIL(G) ;GET OLD CEIL AND FLOOR\r
+ MOVE Q,FLOOR(G)\r
+ SUBI X2,1 ;SET UP X2 FOR POP LOOP\r
+ ORCMI X2,777777\r
+ MOVEM X1,CEIL(G) ;NEW CEILING\r
+\r
+PRESS7: CAILE Q,(X2) ;DONE?\r
+ JRST N,PRESS8\r
+ POP X2,-1(X1) ;MOVE ONE WORD\r
+ SOJA X1,PRESS7\r
+\r
+PRESS8: MOVEM X1,FLOOR(G) ;NEW FLOOR\r
+ SOS G ;GO TO NEXT LOWER ROLL\r
+ CAMLE G,TOPSTG ;IS THIS ROLL MOVEABLE?\r
+ JRST PRESS6 ;YES. GO PRESS IT.\r
+PRESS9: POP P,G ;RESTORE G\r
+ POPJ P, ;RETURN\r
+\r
+\f;THIS ROUTINE OBTAINS SPACE IN THE "FREE CORE AREA" FOR REAL STRINGS,\r
+;APPEND BLOCKS, THE TEMPORARY STRINGS WHICH ARE THE RESULTS OF\r
+;STRING FUNCTIONS, AND BUFFERS FOR DATA FILES. IT HAS SIX ENTRY POINTS:\r
+;VCHCKC AND VCHCKW FOR REAL STRINGS, VCHTSC AND VCHTSW FOR TEMPORARY\r
+;STRINGS, VCHAPP FOR APPEND BLOCKS, AND VCHBUF FOR DATA FILES.\r
+;STRINGS HAVE TWO ENTRY POINTS SO THAT THEY MAY REQUEST SPACE IN UNITS\r
+;OF EITHER CHARACTERS OR WORDS. THE REQUEST IS IN AC T. NO OTHER\r
+;AC'S ARE DESTROYED. THE LOCATION OF THE LOWER BOUND OF THE OBTAINED\r
+;SPACE IS RETURNED IN AC T.\r
+\r
+\r
+VCHCKC: MOVEI E,25\r
+ SKIPG G\r
+ PUSHJ P,VCHCK9\r
+VCHCK1: MOVE X1,VARFRE\r
+ ADD X1,E\r
+ CAMGE X1,JOBREL\r
+ POPJ P,\r
+ SKIPE VPAKFL\r
+ JRST N,VCHCK2\r
+ PUSHJ P,VCHCK3\r
+ JRST N,VCHCK1\r
+VCHCK2: MOVE X1,JOBREL\r
+ ADDI X1,2000\r
+ CALL X1,[SIXBIT /CORE/]\r
+ JRST N,PANIC1\r
+ JRST N,VCHCK1\r
+VCHCK3: PUSH P,G\r
+ PUSH P,E\r
+ MOVE G,SVRTOP\r
+VCHCK4: HRRZI X2,-1\r
+ MOVE Q,FLVSP\r
+ SETZI X1,0\r
+VCHCK5: CAML Q,SVRTOP\r
+ JRST N,VCHCK7\r
+ CAMN Q,CEVSP\r
+ MOVE Q,SVRBOT\r
+ HRRZ E,(Q)\r
+ JUMPE E,VCHCK6\r
+ CAML E,G\r
+ CAMG X2,E\r
+VCHCK6: AOJA Q,VCHCK5\r
+ MOVE X1,Q\r
+ MOVE X2,E\r
+ AOJA Q,VCHCK5\r
+VCHCK7: JUMPE X1,VCHCKE\r
+ HLRE E,(X1)\r
+ JUMPN E,VCHCK8\r
+ SETZM N,(X1)\r
+ JRST N,VCHCK4\r
+VCHCK8: HRL G,(X1)\r
+ MOVN C,E\r
+ CAIL C,1000\r
+ MOVEI C,0\r
+ ADDI C,4\r
+ IDIVI C,5\r
+ MOVE E,C\r
+ ADDI E,(G)\r
+ HRRZ X2,(X1)\r
+ CAIN X2,(F)\r
+ HRRM G,F\r
+ HRRM G,(X1)\r
+ BLT G,(E)\r
+ AOS G,E\r
+ MOVEM E,VARFRE\r
+ JRST N,VCHCK4\r
+VCHCKE: POP P,E\r
+ SETOM N,VPAKFL\r
+ JRST N,PRESS9\r
+\fSUBTTL DECIMAL NUMBER EVALUATE/PRINT\r
+;ROUTINE TO EVALUATE NUMBER\r
+;T: PNTR TO FIRST CHAR, C: FIRST CHAR\r
+;NON-SKIP IS FAIL RETURN\r
+;RETURN NUMBER IN N\r
+\r
+;N: ACCUM NBMR, B: SCA FAC, D: DIG CNT, USE FLGS IN LEFT OF F\r
+\r
+EVANUM: SETZB N,B ;CLEAR ACS\r
+ MOVEI D,8\r
+ MOVEI F,0(F) ;CLEAR LH OF F\r
+\r
+ TLNE C,F.PLUS ;SKIP +\r
+ JRST EVAN1\r
+ TLNN C,F.MINS ;CHECK FOR -\r
+ JRST EVAN2 ;NO\r
+ TLO F,F.MIN ;SET MINUS FLG\r
+EVAN1: PUSHJ P,NXCH\r
+EVAN2: TLNN C,F.DIG ;DIGIT?\r
+ JRST N,EVAN3\r
+ TLO F,F.NUM ;DIGIT SEEN FLAG\r
+ JUMPE N,EVAN2A ;DONT COUNT LEADING ZEROS\r
+ SOJG D,EVAN2A ;COUNT DIGIT, GO ACCUM IF OK\r
+; REST OF DIGITS ARE INSIGNIFIGANT.\r
+ AOJA B,EVAN2B ;LEAD OR TRAIL 0, FUDGE SCA FAC\r
+\r
+EVAN2A: IMULI N,^D10 ;ACCUMULATE DIGIT\r
+ ADDI N,-60(C)\r
+EVAN2B: TLNE F,F.DOT ;DECIMAL SEEN?\r
+ SUBI B,1 ;YES. COUNT DOWN SCALE FACT\r
+ JRST EVAN1 ;GO TO NEXT CHAR\r
+\r
+EVAN3: TLNN C,F.PER ;NOT DIGIT. DEC PNT?\r
+ JRST EVAN4 ;NO.\r
+ TLOE F,F.DOT ;YES, SET FLG & CHK ONLY ONE\r
+ POPJ P, ;2 DEC PNTS\r
+ JRST EVAN1\r
+EVAN4: TLNN F,F.NUM ;DID WE SEE A DIGIT?\r
+ POPJ P, ;NO. WHAT A LOUSY NUMBER\r
+\r
+ MOVEI X1,"E"\r
+ CAIE X1,(C) ;EXPLICIT SCALE FACTOR?\r
+ JRST EVAN8 ;NO\r
+ PUSHJ P,NXCH ;DO LOOK AHEAD\r
+ TLNE C,F.PLUS ;SCALE FACTOR SIGN\r
+ JRST EVAN5\r
+ TLNN C,F.MINS\r
+ JRST EVAN6\r
+ TLO F,F.MXP\r
+EVAN5: PUSHJ P,NXCH\r
+EVAN6: TLNN C,F.DIG ;CHK FOR DIGIT\r
+ POPJ P,\r
+ MOVEI A,-60(C) ;SAVE FIRST EXPON DIGIT\r
+ PUSHJ P,NXCH\r
+ TLNN C,F.DIG ;IS THERE A SECOND DIGIT\r
+ JRST EVAN7 ;NO\r
+ IMULI A,^D10 ;YES. ACCUMULATE IT\r
+ ADDI A,-60(C)\r
+ PUSHJ P,NXCH ;DO LOOK AHEAD\r
+\r
+EVAN7: TLNE F,F.MXP ;NEG EXPON?\r
+ MOVN A,A ;YES. NEGATE IT\r
+ ADD B,A ;ADD TO SCALE FACTOR\r
+EVAN8: JUMPE N,CPOPJ1 ;IGNORE SCALE IF NUMBER IS ZERO\r
+EVAN8A: MOVE X1,N ;)\r
+ IDIVI X1,^D10 ;)REMOVE ANY TRAILING ZEROS\r
+ JUMPN X2,EVAN8B ;) IN MANTISSA.. (REASON:\r
+ MOVE N,X1 ;) SO THAT, E.G., .1,\r
+ AOJA B,EVAN8A ;) .10, .100,... ARE THE SAME)\r
+EVAN8B: MOVM A,B\r
+ CAILE A,46\r
+ POPJ P,\r
+ TLO N,233000 ;FLOAT N\r
+ FAD N,[0]\r
+ JOV .+1 ;CLEAR OVER/UNDERLFOW FLAG\r
+EVAN8C: CAIGE B,^D15 ;SCALE UP IF .GE. 10^15\r
+ JRST EVAN8D\r
+ SUBI B,^D14 ;SUBTRACT 14 FROM SCALE FACTOR\r
+ FMPR N,D1E14 ;MULTIPLY BY 10^14\r
+ JRST EVAN8C ;GO LOOK AT SCALE AGAIN\r
+EVAN8D: CAML B,[EXP -^D4] ;SCALE DONW IF .LT. 10^-4\r
+ JRST N,EVAN8E\r
+ ADDI B,^D18 ;ADD 18 TO SCALE\r
+ FMPR N,D1EM18 ;MULTIPLY BY 10^-18\r
+ JRST N,EVAN8D ;GO LOOK AT SCALE AGAIN\r
+EVAN8E: FMPR N,DECTAB(B) ;SCALE N\r
+ TLNE F,F.MIN ;MINUS\r
+ MOVN N,N ;YES. NEGATE IT.\r
+ JOV CPOPJ\r
+ JRST CPOPJ1 ;SUCCESS RETURN, NUMBER IN N\r
+\f;ROUTINE TO PRINT NUMBER\r
+\r
+OUTNUM: SETOM STRFCN\r
+ MOVM T,N\r
+ JUMPE T,PRTNUX\r
+ PUSH P,E ;DO NOT CLOBBER E (FOR MATRIX)\r
+ MOVEI E,0 ;CHANGE IN EXPONENT\r
+OUTN1A: CAMG T,D1E14 ;SCALE IF .GT. 10^14\r
+ JRST OUTN1B\r
+ ADDI E,^D18 ;ADD 18 TO SCALE\r
+ FMPR T,D1EM18 ;AND MULTIPLY BY 10^-18\r
+ JRST OUTN1A\r
+OUTN1B: CAML T,D1EM4 ;SCALE IF .LT. 10^-4\r
+ JRST OUTN1C\r
+ SUBI E,^D14 ;SUBTRACT 14 FROM SCALE\r
+ FMPR T,D1E14 ;AND MULT BY 10^14\r
+ JRST OUTN1B ;GOT SEE IF MORE SCALING\r
+OUTN1C: MOVE A,T ;LOOK UP IN DEC ROLL\r
+ MOVEI R,DECROL\r
+ PUSHJ P,SEARCH\r
+ JFCL ;DONT CARE IF FOUND\r
+ CAME A,(B) ;FUDGE BY 1 IF EXACT MATCH\r
+ SUBI B,1\r
+ SUBI B,DECTAB ;FIND DIST FROM MIDDLE\r
+ JUMPN E,OUTN2 ;(NOT INTEGER IF WE SCALED)\r
+ CAIGE B,^D8 ;CHK 8 DIG NUMBER\r
+ CAIGE B,0\r
+ JRST OUTN2\r
+ CAML T,FIXCON ;IS THIS 2^26?\r
+ JRST OUTN1D ;YES, ITS 27 BIT INT.\r
+ MOVE X1,T\r
+ FAD X1,FIXCON ;INTEGER?\r
+ FSB X1,FIXCON\r
+ CAME X1,T\r
+ JRST OUTN2 ;NOT SUCH (LOST FRACTIONAL PART)\r
+ FAD T,FIXCON ;SUCH. FIX NUMBER\r
+ TLZ T,377400\r
+OUTN1D: TLZ T,377000 ;(IN CASE 27-BIT INTEGER)\r
+ POP P,E ;RESTORE E\r
+ JRST PRTNX1\r
+\r
+OUTN2: FDVR T,DECTAB(B) ;GET MANTISSA\r
+ FMPR T,DECTAB+5\r
+ FADR T,FIXCON\r
+ TLZ T,377400 ;FIX\r
+ CAMGE T,[EXP ^D1000000]\r
+ JRST .+3\r
+ IDIVI T,^D10 ;ROUNDING MADE 7 DIGITS\r
+ ADDI B,1 ;MAKE IT 6 AGAIN\r
+ CAIL T,^D100000 ;ROUNDING MADE 5 DIGITS?\r
+ JRST .+3\r
+ IMULI T,^D10 ;YES. MAKE 6 AGAIN\r
+ SUBI B,1\r
+ ADDB B,E ;ADD TOGETHER TWO PARTS OF SCALE\r
+ AOJL E,.+2 ;BETWEEN 10^-1 AND 10^6?\r
+ CAILE E,6\r
+ SKIPA E,[EXP 1] ;NO. PRINT 1 DIG BEFORE POINT\r
+ PUSHJ P,CHKNEF ;PRINT WITHOUT EXP (CHK ROOM FOR ^8 SP)\r
+ PUSHJ P,CHKEF ;PRINT WITH EXP (CHK ROOM FOR ^14 SP)\r
+ PUSHJ P,PSIGN ;PRINT "SIGN"\r
+ JUMPN E,OUTN3 ;SHOULD DEV. POINT PRECEDE NUMER?\r
+ MOVEI C,"0" ;YES,SEND OUT LEADING ZERO.\r
+ PUSHJ P,OUCH\r
+ PUSHJ P,DNPRN2\r
+OUTN3: PUSHJ P,DNPRNT ;GO PRINT NUMBER WITH DECIMAL\r
+\r
+;HERE TO PRINT EXPONENT\r
+\r
+\r
+ POP P,E ;RESTORE E\r
+ JUMPE B,CPOPJ\r
+ PUSHJ P,INLMES\r
+ MOVEM T1,@N\r
+ MOVEI C,"+"\r
+ JUMPGE B,.+2 ;SPIT OUT SIGN\r
+ MOVEI C,"-"\r
+ PUSHJ P,OUCH\r
+ MOVM T,B ;USE PRTNUM TO PRINT EXPON\r
+ JRST N,PRTNUM\r
+\r
+\r
+;SUBROUTINE USED BY OUTNUM TO PRINT DECIMAL NUMBER. PRINTS\r
+;SIX DIGITS (INTEGER IN T) WITH CONTENTS(E) DIGITS\r
+;TO THE LEFT OF DECIMAL POINT\r
+\r
+DNPRNT: MOVEI D,-1 ;SIGNAL TRAILING ZERO UNLESS...\r
+ JUMPE B,.+2 ;E-NOTATION\r
+ MOVEI D,0\r
+DNPRN0: IDIVI T,^D10 ;GET LAST DIGIT\r
+ JUMPE T,DNPRN1 ;IS IT FIRST?\r
+ JUMPN T1,.+2 ;NON ZERO DIGIT?\r
+ SKIPA T1,D ;NO, STASH ZERO OR TRAILZERO\r
+ MOVEI D,0 ;YES. TRAILER IS OVER.\r
+ HRLM T1,(P) ;NO. STASH DIGIT\r
+ PUSHJ P,DNPRN0 ;CALL DNPRNT RECURSIVELY\r
+ HLRE T1,(P) ;RESTORE DIGIT\r
+ JUMPGE T1,.+3 ;ORDINARY DIGIT?\r
+ JUMPLE E,CPOPJ ;NO, TRAILZERO. AFTER DECIMAL POINR?\r
+ MOVEI T1,0 ;NO, STASH A ZERO.\r
+\r
+DNPRN1: MOVEI C,60(T1) ;PRINT DIGIT\r
+ PUSHJ P,OUCH\r
+ SOJN E,CPOPJ ;COUNT DIGITS. PRINT NEXT?\r
+DNPRN2: MOVEI C,"." ;YES. PRINT POINT\r
+ JRST N,OUCH\r
+\r
+;CHECK FOR ROOM ON A LINE FOR E-FORM NUMBER:\r
+CHKEF: MOVEI X1,^D14 ;NEED 14 SP TO PRINT THIS NUMBER\r
+ PUSH P,B ;SAVE EXPONENT\r
+ PUSHJ P,CHROOM\r
+ POP P,B\r
+ POPJ P,\r
+CHKNEF: MOVEI X1,^D9\r
+ PUSHJ P,CHROOM\r
+ MOVEI B,0 ;NO EXPONENT.\r
+ JRST CPOPJ1 ;SKIP-RTN\r
+\r
+;POWER-OF-TEN TABLE.\r
+\r
+D1EM18: OCT 105447113564 ;10^-18\r
+\r
+DECFLO:\r
+D1EM4: OCT 163643334273\r
+ OCT 167406111565\r
+ OCT 172507534122\r
+ OCT 175631463146\r
+DECTAB: DEC 1.0 ;10^0\r
+ DEC 1.0E1\r
+ DEC 1.0E2\r
+ DEC 1.0E3\r
+ DEC 1.0E4\r
+ DEC 1.0E5\r
+ DEC 1.0E6\r
+ DEC 1.0E7\r
+ OCT 1.0E8\r
+ DEC 1.0E9\r
+ DEC 1.0E10\r
+ DEC 1.0E11\r
+ OCT 250721522451 ;10^12\r
+ OCT 254443023471\r
+D1E14: OCT 257553630410 ;10^14\r
+DECCEI:\r
+\r
+MAXEXP=^D38\r
+DECFIX: EXP 225400000000\r
+FIXCON: EXP 233400000000\r
+\r
+;FLAGS USED BY DECIMAL READER/PRINTER\r
+\r
+F.NUM=200000 ;DIGIT SEEN\r
+F.MIN=100000 ;MINUS SEEN\r
+F.MXP=40000 ;MINUS EXPONENT\r
+F.DOT=20000 ;DECIMAL POINT SEEN\r
+\f SUBTTL RUN-TIME ROUTINES\r
+\r
+;RUN-TIME GOSUB ROUTINES\r
+\r
+GOSBER: MOVE X1,@40\r
+ MOVE R,FCNLNK\r
+ HRLM R,@40 ;SAVE PRECEDING CALL\r
+ MOVE R,40 ;FETCH CURRENT CALL\r
+ MOVEM R,FCNLNK\r
+ TRNN X1,777777 ;IF FCN, BEGINS AT CTRL WRD + 1\r
+ HRRI X1,1(R)\r
+ TLNN X1,777777 ;CHECK RECURSIVE CALL\r
+ JRST (X1)\r
+\r
+ PUSHJ P,INLMES ;RECURSIVE CALL\r
+ ASCIZ /SUBROUTINE OR FUNCTION CALLS ITSELF IN /\r
+GOSR2: PUSH P,[EXP UXIT] ;PRINT LINE NUMBER AND END EXECUTION\r
+GOSR3: MOVE T,LP\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ POPJ P,\r
+\r
+FORCOM: HRRZI X1,313000 ;RUNTIME COMPARE FIX-DONT USE IF CONN\r
+ SKIPGE @40\r
+ HRRZI X1,315000 ;SET UP COMPARE FOR ENTIRE LOOP\r
+ HRLM X1,@(P)\r
+ POPJ P,\r
+\r
+XCTON: JUMPLE N,XCTON1 ;IS ON ARGUMENT <=0?\r
+ FAD N,FIXCON\r
+ HRRZ T,N ;GET INTEGER PART\r
+ JUMPE T,XCTON1\r
+ ADDI T,(Q) ;GET THE "GOTO" ADDRESS\r
+ CAMGE T,(Q) ;IS IT IN RANGE?\r
+ JRST @(T) ;YES, GOGO\r
+\r
+XCTON1: PUSHJ P,INLMES\r
+ ASCIZ /ON EVALUATED OUT OF RANGE IN /\r
+ JRST GOSR2\r
+\r
+\f;HERE ON OVFLOW ERROR\r
+OVTRAP: PUSH P,X1 ;SAVE THIS REG IN CASE FALSE ALARM.\r
+ MOVEI X1,10\r
+ CALL X1,[SIXBIT /APRENB/]\r
+ HRRZ X1,JOBTPC ;GET TRAP ADDRESS.\r
+ CAML X1,FLCOD ;TRAP IN USER PROG?\r
+ CAMLE X1,CECOD\r
+ JRST OVFLCM ;NO. FALSE TRAP.(NOT BY USER)\r
+ MOVE X1,JOBTPC ;GET TRAP FLAGS.\r
+ SKIPE N,174\r
+ JRST OVTR0\r
+ TLNE X1,(1B11) ;UNDERFLOW?\r
+ JRST UNTRAP ;YES\r
+ TLNE X1,(1B12) ;ZERO DIVIDE?\r
+ JRST DVTRAP ;YES\r
+ TLNN X1,(1B3)\r
+ JRST OVFLCM ;NOT OVFLOW EITHER. IGNORE\r
+OVTR0: PUSHJ P,INLMES\r
+ ASCIZ /OVERFLOW IN /\r
+ SKIPL N ;NEG OVFLOW?\r
+OVTR2: HRLOI N,377777 ;LRG NUMBER\r
+ SKIPG N\r
+ MOVE N,MIFI\r
+OVTR1: PUSHJ P,GOSR3\r
+OVFLCM: POP P,X1\r
+ JRST N,@JOBTPC\r
+\r
+UNTRAP: PUSHJ P,INLMES\r
+ ASCIZ /UNDERFLOW IN /\r
+ SETZI N, ;RESULT IS ZERO.\r
+ JRST OVTR1\r
+DVTRAP: PUSHJ P,INLMES\r
+ ASCIZ /DIVISION BY ZERO IN /\r
+ JRST OVTR2\r
+\r
+RETURN: SETZI T,0 ;GOSUB RETURN, NOTHING ON PLIST\r
+FRETRN: MOVE R,FCNLNK\r
+ JUMPE R,BADRET ;CHECK RETURN TOO FAR\r
+ MOVS X1,(R) ;FETCH LINK BACK\r
+ HRRZS (R) ;MARK SUBR NOT IN USE\r
+ MOVEI R,(X1)\r
+ MOVEM R,FCNLNK\r
+ POP P,X2 ;SAVE REAL RETURN LOCATION\r
+ SUB P,T ;POP ANY ARGUMENTS OFF THE PUSH LIST\r
+ JRST (X2) ;RETURN\r
+\r
+BADRET: PUSHJ P,INLMES\r
+ ASCIZ /RETURN BEFORE GOSUB IN /\r
+ JRST N,GOSR2\r
+\r
+IFN FTRND,<\r
+;RUN-TIME RANDOMIZER\r
+RANDER: CALL N,[SIXBIT /MSTIME/]\r
+ IMUL N,N ;USE THE 31 LOW ORDER BITS OF MILLISECS IN DAY ^2\r
+ TLZ N,760000\r
+ JRST WRANB ;PRINT RANDOM FCN AND RETURN.\r
+>;ASSEMBLE ABOVE IF INCLUDING RANDOM FACILITY\r
+\r
+DOREAD: MOVE R,[XWD NXREAD,PREAD]\r
+ SETZM N,INPFLA\r
+ POPJ P,0\r
+DOINPT: SETZM N,PINPUT\r
+ SETZM N,IFIFG\r
+ MOVE R,[XWD NXINPT,PINPUT]\r
+ POP P,INPFLA\r
+ JRST N,@INPFLA\r
+\r
+;ROUTINE TO GET A DATA WORD\r
+\r
+DATAER: SKIPN T,(R) ;MORE ON SAME LINE?\r
+ JRST DATR1 ;NO\r
+ PUSHJ P,NXCH ;PUT FIRST CHAR OF NEXT NUMBER IN C\r
+DATAE0: PUSHJ P,EVANUM\r
+ PUSHJ P,SSKIP\r
+ MOVEM N,@40\r
+ TLNE C,500000\r
+ SETZI T,0\r
+ MOVEM T,(R) ;STORE THE DATA WORD.\r
+DATR0: POP P,X1\r
+ SKIPN T ;END OF A LINE?\r
+ SKIPN INPFLA ;YES, IS THIS INPUT\r
+ JRST (X1) ;NO, RETURN\r
+ MOVEM X1,INPFLA ;YES, RESTART NEXT ERROR FROM HERE.\r
+ JRST (X1)\r
+\r
+DATR1: MOVS X1,R ;DISPATCH ADDRS FOR MORE DATA\r
+ JRST (X1)\r
+\r
+;ROUTINE TO GET A DATA STRING\r
+\r
+IFN FTSTR,<\r
+SDATAE: MOVE T,1(R) ;GET CURRENT LINE POINTER\r
+ SKIPE INPFLA ;INPUT,INSTRUCTION?\r
+ MOVE T,(R) ;YES, SHARE POINTER WITH NUMBER DATA\r
+ SKIPN T ;MOVE ON CURRENT STRING DATA LINE?\r
+ JRST SDATR1 ;NO. HUNT FOR NEXT DATA LINE\r
+ PUSHJ P,NXCH ;GET FIRST CHAR\r
+SDAT1: PUSHJ P,REDSTR ;READ THE STRING AND STORE IT\r
+ PUSHJ P,SSKIP ;BAD STRING\r
+ TLNE C,F.TERM\r
+ SETZI T,\r
+ MOVEM T,1(R) ;SAVE STRING DATA POINTER.\r
+ SKIPE INPFLA ;INPUT?\r
+ MOVEM T,(R) ;YES , SHARE POINTER\r
+ JRST DATR0\r
+\r
+SDATR1: MOVS X1,R ;DISPATCH ADDRESS FOR STRING DATA..\r
+ JRST 1(X1)\r
+>;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY\r
+\r
+\f;GET AN ARRAY DATA WORD\r
+\r
+ADT1ER: PUSH P,40 ;DATAER NEEDS STORE LOC\r
+ SETZM 40\r
+ PUSHJ P,DATAER\r
+ POP P,40\r
+ JRST AST1ER ;GO STORE THE WORD\r
+\r
+ADT2ER: PUSH P,40\r
+ SETZM 40\r
+ PUSHJ P,DATAER\r
+ POP P,40\r
+ JRST AST2ER\r
+\r
+;GO TO NEXT LINE OF DATA\r
+\r
+NXREAD: TDZA Q,Q ;GET NEXT DATA LINE FOR NUMBER ITEM\r
+ MOVEI Q,1 ;GET NEXT DATA LINE FOR STRING ITEM\r
+NSRSTR: MOVE T,DATLIN(Q) ;GET NXT DATA LINE NO\r
+ AOBJP T,NXRE2 ;JUMP IF OUT OF DATA\r
+ MOVEM T,DATLIN(Q)\r
+ HRRZ T,(T) ;GET ADDRS OF SOURCE LINE\r
+ HRLI T,440700\r
+ PUSHJ P,NXCH\r
+ PUSHJ P,QSA ;LOOK FOR "DATA"\r
+ ASCIZ /DATA/\r
+ JRST NSRSTR\r
+IFN FTSTR,<\r
+ JUMPG Q,SDAT1 ;GO GET STRING?\r
+>\r
+ JRST DATAE0 ;NO, GO GET NUMBER\r
+\f;REQUEST NEXT LINE OF INPUT\r
+\r
+NXVINP: SETOI Q, ;GET LINE AND RETURN TO "MATIN"\r
+ JRST NXIN1\r
+NXINPT: TDZA Q,Q ;GET A LINE OF INPUT; NUMBER ITEM NEXT\r
+ MOVEI Q,1\r
+NXIN1: SKIPN IFIFG\r
+ JRST NXIN2\r
+ PUSHJ P,INLMES\r
+ ASCIZ /NOT ENOUGH INPUT--ADD MORE\r
+/\r
+NXIN2: PUSHJ P,INLMES\r
+ ASCIZ / ?/\r
+ OUTPUT\r
+ MOVE T,[POINT 7,LINB0]\r
+ MOVEM T,PINPUT\r
+ PUSHJ P,INLINE ;READ THE LINE AND GET FIRST CHAR.\r
+ TLNE C,F.CR ;NULL LINE?\r
+ JUMPL Q,CPOPJ1 ;YES. ALLOW THIS ON MAT INPUT\r
+ PUSHJ P,DATCHK ;CHECK\r
+ JRST INPERP\r
+ JUMPE Q,DATAER ;GET NUMBER ITEM\r
+IFN FTSTR,<\r
+ JUMPG Q,SDATAE ;GET STRING ITEM\r
+>\r
+ POPJ P,\r
+INPERP: POP P,X1 ;GET RID OF CALL TO NXVINP!\r
+INPERR: PUSHJ P,INLMES\r
+ ASCIZ /INPUT DATA NOT IN CORRECT FORM--RETYPE LINE\r
+/\r
+ SETZM PINPUT\r
+INPER1: HRRZ X1,INPFLA\r
+ JRST (X1) ;START LINE OVER.\r
+\f;RESTORE DATA POINTER\r
+\r
+RESTOR: PUSHJ P,RESTOS ;RESTORE BOTH NUMBER AND STRINGS\r
+RESTON: TDZA X1,X1 ;RESTORE NUMERIC DATA\r
+RESTOS: MOVEI X1,1 ;RESTORE STRINGS\r
+ MOVE T,DATAFF\r
+ ADD T,FLLIN\r
+ SUB T,[XWD 1,1]\r
+ MOVEM T,DATLIN(X1)\r
+ SETZM PREAD(X1) ;CLEAR CURRENT LINE POINTER\r
+ POPJ P,\r
+\r
+NXRE2: PUSHJ P,INLMES ;OUT OF DATA\r
+ ASCIZ /OUT OF DATA IN /\r
+ HRRZ T,L\r
+ PUSHJ P,PRTNUM\r
+ PUSHJ P,INLMES\r
+ ASCIZ /\r
+/\r
+ JRST UXIT\r
+\r
+\f;RUNTIME MAT INPUT ROUTINE\r
+\r
+MATIN: PUSHJ P,DOINPT ;SET INPUT LOOP\r
+ HRRZ X1,40 ;GET VECTOR 2-WD BLOCK ADDRESS\r
+ HRRZ X2,(X1) ;GET ADDRESS OF FIRST ELEMENT\r
+ MOVEM X2,NUMRES ;SAVE THIS VALUE FOR COUNTING ELEMENT LATER\r
+ HLRZ X1,(X1) ;GET MAXIMUM VECTOR SIZE\r
+ ADD X1,X2 ;UPPER BOUND OF VECTOR\r
+ MOVEM X1,ELETOP ;SAVE FOR COMPARISION LATER\r
+ HRRM X2,40 ;SET UP ELEMENT ADDRESS FOR DATA ROUTINES\r
+\r
+MATIN1: MOVEI X1,MATIN4 ;POINT "INPUT ERR" TO SPECIAL ROUTINE\r
+ HRL X1,40 ;REMEMBER FIRST ELEMENT ON LINE\r
+ MOVEM X1,INPFLA\r
+ PUSHJ P,NXVINP ;INPUT THE LINE\r
+\r
+MATIN5: CAIA ;THERE IS ANOTHER ELEMENT.\r
+ JRST MATIN6 ;NULL LINE. NO MORE ELEMENTS.\r
+ HRRZ X1,40 ;MAY WE ACCEPT ANOTHER ELEMENT?\r
+ CAML X1,ELETOP\r
+ JRST MATIN3 ;NO\r
+ AOS 40 ;POINT TO NEXT ELEMENT\r
+ PUSH P,[EXP MATIN2] ;YES. SETUP RETURN FROMDATA ROUTINE\r
+IFN FTSTR,<\r
+ CAML X1,SVRBOT ;NUMBER OR STRING VECTOR?\r
+ JRST SDATAE ;STRING\r
+>\r
+ JRST DATAER ;NUMBER\r
+\r
+MATIN2: SETOM IFIFG\r
+ TLNE C,F.COMA ;END OF INPUT?\r
+ JRST MATIN5\r
+ TLNE C,F.TERM\r
+ JRST MATIN6\r
+ CAIN C,"&"\r
+ JRST MATIN1\r
+ JRST INPERR\r
+MATIN3: PUSHJ P,INLMES\r
+ ASCIZ /TOO MANY ELEMENTS -- RETYPE LINE\r
+/\r
+ JRST INPER1\r
+\r
+MATIN4: HLRZ X1,INPFLA\r
+ HRRM X1,40\r
+ JRST MATIN1\r
+\r
+MATIN6: HRRZ X1,40\r
+ SUB X1,NUMRES\r
+ TLO X1,233400\r
+ FSB X1,FIXCON\r
+ MOVEM X1,NUMRES\r
+ POPJ P,\r
+\r
+IFN FTSTR,<\r
+REDSTR: TLNN C,F.LETT+F.QUOT\r
+ POPJ P,\r
+ AOS (P) ;THIS IS A LEGITIMATE STRING\r
+ PUSH P,G\r
+ PUSH P,E\r
+ PUSHJ P,GETSTR\r
+ PUSHJ P,VCHCKC\r
+ MOVEI Q,F.COMA+F.TERM ;ASSUME A STRING WITHOUT QUOTES\r
+ TLNN C,F.QUOT ;IS IT A QUOT STRING?\r
+ JRST REDS1\r
+ MOVEI Q,F.QUOT\r
+ PUSHJ P,NXCHS ;SKIP QUOTE\r
+REDS1: SETZI X2, ;INITIALIZE COUNT.\r
+ SKIPE (F) ;NEW STRING?\r
+ SETZM VPAKFL ;NO, GARBAGE NEW EXISTS\r
+ HRR F,VARFRE\r
+ HRRM F,@N\r
+REDS2: TLNE C,(Q)\r
+ JRST REDS3\r
+ IDPB C,F ;STORE A CHAR\r
+ PUSHJ P,NXCHS\r
+ SOJA X2,REDS2\r
+REDS3: TLNE C,F.QUOT\r
+ PUSHJ P,NXCH\r
+ HRRZ X1,F ;GET NEW FREE LOCATION\r
+ POP P,E\r
+ POP P,G\r
+ JRST REDS8\r
+\r
+SSKIP: SKIPE INPFLA ;IS THIS INPUT OR READ?\r
+ JRST SSKP1 ;INPUT. CANT SKIP ANY FIELDS\r
+ PUSHJ P,SKIPDA ;SKIP OVER A DATA FIELD\r
+ HALT . ;IMPOSSIBLE ERROR\r
+ POP P,X1\r
+ TLNE C,F.TERM ;END OF DATA LINE?\r
+ JRST -4(X1) ;YES. FORCE DATA SEARCH\r
+ JRST -3(X1) ;RETURN TO DATAERR OR SDATAE\r
+\r
+SSKP1: ADD P,[XWD -2,-2] ;CLEAN UP PUSH LIST\r
+ JRST INPERR\r
+\r
+;ROUTINE THAT SKIPS OVER ONE DATA FIELD\r
+SKIPDA: TLNE C,F.QUOT ;QUOTE STRING?\r
+ JRST QSKIP ;YES, USE QSKIP ROUTINE\r
+ TLNE C,F.COMA+F.TERM ;FIELD TERMINATOR?\r
+ JRST ,CPOPJ1\r
+ PUSHJ P,NXCH\r
+ JRST .-3\r
+>;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY\r
+\r
+IFE FTSTR,<\r
+SKIPDA: POPJ P, ;STRINGS NOT ALLOWED. DATA ERROR\r
+SSKIP: ADD P,[XWD -2,-2] ;CLEAN UP PUSHLIST\r
+ JRST INPERR\r
+>\r
+\r
+PRDLER: PUSHJ P,FIRCHK\r
+ SETZM N,STRFCN\r
+ MOVEI D,42\r
+ MOVE T,@(P)\r
+ AOS N,(P)\r
+ PUSHJ P,PRINT1\r
+FINPNT: MOVE X1,FMTPNT ;FINISH WITH CR?\r
+ CAIE X1,1\r
+ JRST N,PCRLF1\r
+PCRLF: PUSHJ P,INLMES ;ROUTINE TO END A LINE.\r
+ ASCIZ /\r
+/\r
+ SETZM N,STRFCN\r
+ SETZM TABVAL\r
+PCRLF1: OUTPUT\r
+ POPJ P,\r
+\f\r
+;RUN-TIME NUMBER PRINTER\r
+\r
+PRNMER: PUSHJ P,TABBR\r
+ MOVE N,@40 ;GET THE NUMBER\r
+ PUSHJ P,OUTNUM\r
+ AOS TABVAL ;CAUSE A SPACE TO FOLLOW NUMBER.\r
+ JRST FINPNT\r
+\r
+PRNTBR: PUSHJ P,TABBR\r
+ SKIPGE B,TABVAL\r
+ JUMPLE N,FINPNT\r
+ FAD N,FIXCON\r
+ TLZ N,377400\r
+ SUB N,HPOS\r
+ SUB N,4\r
+ JUMPLE N,FINPNT\r
+ ADDM N,TABVAL\r
+ JRST N,FINPNT\r
+FIRCHK: PUSHJ P,TABBR\r
+ MOVEI X1,0\r
+\f;TAB CONTROL\r
+\r
+;"TABBR" ANALYSES THE LAST FORMAT CHARACTER USING "TABB0", "TABB1", AND\r
+;"TABB3", WHICH HANDLE THE <PA>, COMMA, AND SEMICOLON, RESPECTIVELY.\r
+;"TABVAL" CONAINS THE NUMBER OF SPACES WAITING TO BE TYPED OUT\r
+;(OR IS NEGATIVE IF A <RETURN> MUST FOLLOW.)\r
+\r
+\r
+CHROOM: MOVE B,TABVAL\r
+ ADD X1,B ;TOTAL SPACE NEEDED FOR FIELD\r
+ ADD X1,HPOS\r
+ CAIL X1,113\r
+ JRST PCRLF ;NO ROOM, GO TO NEXT LINE\r
+ JUMPL B,PCRLF\r
+ JUMPE B,CPOPJ ;NO SPACING TO DO.\r
+ MOVEI C," " ;HERE TO PUT OUT SPACES\r
+ PUSHJ P,OUCH\r
+ SOJG B,.-2\r
+ SETZM TABVAL\r
+ POPJ P,\r
+\r
+TABBR: LDB X1,[POINT 4,40,12]\r
+ EXCH X1,FMTPNT ;GET OLD POSITION AND SAVE NEW FORMAT\r
+TABB1: MOVE A,TABVAL\r
+ JUMPL A,SETCR\r
+ ADD A,HPOS\r
+ JRST .+1(X1)\r
+ POPJ P, ;NO FMT CHAR\r
+ POPJ P, ;<CR> WAS TYPED WHEN FIRST SEEN.\r
+ JRST TABB3 ;SEMICOLON\r
+ CAILE A,74\r
+ JRST SETCR\r
+ IDIVI A,^D15\r
+ JUMPE B,TABB2\r
+ SUBI B,^D15\r
+ MOVNS B\r
+TABB2: ADDB B,TABVAL\r
+ POPJ P,\r
+\r
+TABB3: CAILE A,112\r
+ JRST N,SETCR\r
+ AOSGE N,STRFCN\r
+ AOS N,TABVAL\r
+ POPJ P,\r
+\r
+SETCR: SETOM TABVAL ;FORCE <RETURN TO BE NEXT>\r
+ POPJ P,\r
+TABOUT: MOVEI X1,3\r
+ PUSHJ P,TABB1\r
+ JRST FIRCHK+1\r
+\fIFN FTSTR,<\r
+ SUBTTL RUN-TIME STRING MANIPULATION ROUTINES.\r
+\r
+\r
+;GETSTR IS CALLED WITH THE ADDRESS OF A POINTER IN REG.\r
+;THE ROUTINE SETS UP THE POINTER IN F, AND THE NEGATIVE COUNT OR\r
+;(FOR LITERAL STRINGS) A POSITIVE QUANTITY IN G. (G=0 IF NULL STRING)\r
+\r
+GETSTR: PUSHJ P,PNTADR ;GET ADDRESS OF STRING POINTER\r
+ MOVE F,@N\r
+ HLRE G,F ;PUT NEGATIVE CHAR LENGTH IN G, IF NOT APP BLK OR 0.\r
+ JUMPG G,CPOPJ\r
+ HRLI F,440700 ;NOTAPP BLK, INITIALIZE POINTER.\r
+ POPJ P,\r
+\r
+;ROUTINE TO SET UP A NUMBER VECTOR INSTEAD OF A STRING\r
+GETVEC: HRRZ F,@40 ;THE LEFT SIDE OF (F) IS ZERO, IMPLYING VECTOR ADR,\r
+ MOVE G,(F) ;GET VECTOR LENGTH\r
+ JUMPL G,GETVF ;NEGATIVE?\r
+ FAD G,FIXCON ;FIX THE LENGTH\r
+ TLZ G,777400\r
+ HLRZ X1,@40 ;DOES THE LENGTH EXCEED VECTOR BOUNDS?\r
+ MOVNS G\r
+ ADD X1,G\r
+ JUMPLE X1,GETVF\r
+ AOJA F,CPOPJ ;NO. POINT TO FIRST "CHAR" AND RETURN\r
+\r
+GETVF: PUSHJ P,INLMES\r
+ ASCIZ /IMPOSSIBLE VECTOR LENGTH IN /\r
+ JRST GOSR2\r
+\r
+GETC0: SETZI G,\r
+GETCH: SETZI C,\r
+ JUMPE G,CPOPJ\r
+ ILDB C,F\r
+ JUMPG G,.+2\r
+ AOJA G,CPOPJ1\r
+ CAIN C,42 ;CHECK IF "\r
+ JRST GETC0\r
+ JRST CPOPJ1\r
+\r
+;ROUTINE TO GET NEXT VECTOR ELE AS A CHARACTER\r
+GETEL: AOJG G,CPOPJ ;IS THERE ANOTHER ELEMENT?\r
+ MOVE C,(F) ;YES. GET IT\r
+ JUMPL C,GETELF ;TOO SMALL TO BE AN ASCII\r
+ LDB Q,[POINT 8,C,8] ;GET EXPONENT\r
+ TLZ C,777000 ;TURN IT OFF\r
+ LSH C,-233(Q) ;SHIFT INTO INTEGER POSISITON\r
+ TRNN C,777600\r
+ AOJA F,CPOPJ1 ;BUMP ELEMENT POINTER AND RETURN\r
+\r
+GETELF: PUSHJ P,INLMES\r
+ ASCIZ /NON-ASCII CHAR SEEN IN /\r
+ JRST GOSR2\r
+\r
+;ROUTINE TO STORE "NUMERIC" CHARS INTO A STR.\r
+STRCHA: PUSHJ P,PNTADR\r
+ PUSHJ P,VCHCKC\r
+ SKIPE N,@N\r
+ SETZM N,VPAKFL\r
+ MOVE X1,VARFRE\r
+ MOVEM X1,@N\r
+ HRLI X1,440700\r
+ SETZI X2,\r
+STRCH1: PUSH P,[XWD STRCH2]\r
+ TLNN F,777777\r
+ JRST GETEL\r
+ JRST GETCH\r
+STRCH2: JRST REDS8\r
+ HRRM X1,VARFRE\r
+ IDPB C,X1\r
+ SOJA X2,STRCH1\r
+\r
+REDS8: HRLM X2,@N\r
+ AOJ X1,\r
+ HRRM X1,VARFRE\r
+ POPJ P,\r
+\r
+PUTVEC: HRRZ X1,@40\r
+ MOVE N,X1\r
+ HLRZ X2,@40\r
+PUTV1: PUSHJ P,GETCH\r
+ JRST PUTV2\r
+ SOJL X2,PUTVF\r
+ TLO C,233400 ;YES. FLOAT IT\r
+ FSB C,FIXCON\r
+ MOVEM C,1(X1)\r
+ AOBJP X1,PUTV1 ;COUNT CHARS IN LEFT HALF OF X1\r
+\r
+PUTV2: HLRZ X1,X1 ;GET SIZE\r
+ HRLI X1,233400 ;FLOAT IT\r
+ FSB X1,FIXCON\r
+ MOVEM X1,@N ;FIRST ELEMENT GETS SIZE\r
+ POPJ P,\r
+\r
+PUTVF: PUSHJ P,INLMES\r
+ ASCIZ /NO ROOM FOR STRING IN /\r
+ JRST N,GOSR2\r
+\r
+; COMPARE TWO STRINGS.\r
+IFSTR: PUSH P,F\r
+ PUSH P,G\r
+ PUSHJ P,GETSTR\r
+ POP P,T1\r
+ POP P,T\r
+IFST1: PUSHJ P,GETPCH ;GET PAIR OF CHARS IN (A) AND (C)\r
+ JUMPG Q,IFST3 ;HAVE BOTH STRINGS ENDED?\r
+ JUMPE Q,IFST2 ;HAS ONE STRING ENDED?\r
+ CAMN C,A ;ARE THESE TWO CHARS THE SAME?\r
+ JRST IFST1 ;YES. LOOK AT NEXT PAIR\r
+\r
+IFST2: SETOI Q, ;CHECK BOTH STRINGS FOR TRAILING BLANKS\r
+ CAIN C," " ;IS THIS CHAR A BLANK?\r
+ PUSHJ P,IFST4 ;YES, GO CHECK STRING\r
+ PUSHJ P,EXCH6 ;LOOK AT OTHER STRING\r
+ AOJLE Q,.-3\r
+\r
+IFST3: HLLZ X1,@(P) ;GET RELATION\r
+ AOS (P)\r
+ IOR X1,[Z A,C] ;SETUP COMPARE\r
+ XCT X1\r
+ POPJ P, ;RETURN AND "GOTO"\r
+ JRST CPOPJ1 ;RETURN AND STAY IN LINE\r
+\r
+IFST4: PUSHJ P,GETCH\r
+ POPJ P,\r
+ CAIN C," " ;IS NEXT CHAR A BLANK?\r
+ JRST N,IFST4 ;YES KEEP LOOKING\r
+ MOVEI C," " ;NO. USE BLANK FOR COMPARE\r
+ POPJ P,\r
+\r
+;ROUTINE TO GET A PAIR OF CHARS\r
+GETPCH: SETOI Q, ;COUNT TERMINATED STRINGS IN X2\r
+ PUSHJ P,GETCH\r
+ AOJ Q,\r
+ PUSHJ P,EXCH6\r
+ PUSHJ P,GETCH\r
+ AOJ Q,\r
+EXCH6: EXCH T,F\r
+ EXCH T1,G\r
+ EXCH A,C\r
+ POPJ P,\r
+\r
+\f;PRSTRR PRINTS A STRING WHOSE POINTER IS ADDRESSED IN (40)\r
+\r
+PRSTRR: PUSH P,G\r
+ PUSHJ P,PNTADR\r
+ PUSHJ P,GETSTR\r
+ PUSHJ P,FIRCHK\r
+ SETZM N,STRFCN\r
+PRST1: PUSHJ P,GETCH\r
+ JRST PRST2\r
+ PUSHJ P,OUCH\r
+ JRST PRST1\r
+PRST2: POP P,G\r
+ JRST FINPNT\r
+VCHCK9: MOVN X1,G\r
+ ADDI X1,4\r
+ IDIVI X1,5\r
+ MOVE E,X1\r
+ POPJ P,\r
+>;ASSEMBLE ABOVE FOR STRINGS\r
+\r
+IFN FTSTR,<\r
+;ROUTINE TO PUT ADDRESS OF POINTER IN REG\r
+PNTADR: HRRZ N,40 ;GET UUO ADDRESS\r
+ MOVE X1,@N\r
+ JUMPGE X1,CPOPJ ;ALL DONE IF THIS IS 0 OR AN APP BLK.\r
+ TLNN X1,377777 ;ALL DONE IF THIS IS NEGATIVE COUNT\r
+ HRRZ N,X1\r
+ POPJ P,\r
+>;ASSEMBLE ABOVE IF INCLUDING STRING FACILITY\r
+\r
+SAD1ER: MOVE D,[JRST SADEND] ;FETCH ADR OF ARRAY ELEMENT\r
+ JRST AFT1ER+1\r
+\r
+ASN1ER: MOVE D,[MOVNM N,(A)] ;NEGATIVE ARRAY STORE\r
+ JRST AFT1ER+1\r
+AST1ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE\r
+AFT1ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH\r
+ MOVEI A,0 ;PSEUDO LEFT HALF\r
+ MOVE B,40 ;ARRAY ADDRESS\r
+ HRRZ C,1(B) ;TRY RIGHT DIMENSION\r
+ TRNN C,777776 ;ROW VECTOR?\r
+ HLRZ C,1(B) ;NO, MUST BE COLUMN VECTOR\r
+ JRST AFT2C ;FINISH UP WITH 2-DIM CODE\r
+\r
+ASN2ER: MOVE D,[MOVNM N,(A)] ;NEGATIVE ARRAY STORE\r
+ JRST N,.+3\r
+AST2ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE\r
+AFT2ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH\r
+ MOVE B,40 ;ARRAY ADDRESS\r
+ HLRZ C,1(B) ;LEFT DIMENSION\r
+ PUSHJ P,SUBSCR ;GET AND FIX SUBSCRIPT IN E\r
+ HRRZ A,1(B)\r
+ IMUL A,E ;LEFT SCRIPT TIMES RIGHT DIM!\r
+ HRRZ C,1(B) ;RIGHT DIMENSION\r
+AFT2C: PUSHJ P,SUBSCR ;GET AND FIX SUBSCRIPT IN E\r
+ ADD A,E ;ADD TO LEFT DIM\r
+ ADD A,(B) ;ADD ARRAY ADDRS\r
+ XCT D ;DO THE OPERATION\r
+ POPJ P, ;RETURN\r
+\r
+IFN FTSTR, <\r
+SADEND: HRRZI N,(A) ;PUT STRING VECTOR POINTER ADDRESS IN N\r
+ TLO N,(1B0) ;MAKE IT LOOK LIKE AN ADDRESS, NOT A POINTER\r
+ POPJ P,\r
+>\r
+\f;ROUTINE TO FETCH AND CHECK SUBSCRIPT\r
+\r
+;CALL: MOVE C,DIMENSION\r
+; PUSHJ P,SUBSCR\r
+\r
+\r
+SUBSCR: MOVE E,@-1(P) ;GET SUBSCRIPT\r
+ AOS N,-1(P) ;SKIP ARGUMENT\r
+ MOVE E,(E)\r
+ FAD E,[XWD 233400,0];FIX SUBSCRIPT\r
+ TLZ E,777400\r
+ CAMGE E,C ;CHECK DIMENSION\r
+ POPJ P,\r
+ ;ON ERROR, FALL INTO DIMERR\r
+\r
+\r
+;DIMENSION ERR ROUTINE\r
+\r
+\r
+\r
+DIMERR: PUSHJ P,INLMES\r
+ ASCIZ /DIMENSION ERROR IN /\r
+ JRST GOSR2\r
+\f SUBTTL MATRIX OPERATION RUN-TIME ROUTINES\r
+\r
+IFN FTMAT, <\r
+;SET MATRIX DIMENSION -- SDIM UUO\r
+\r
+\r
+SDIMER: MOVSI C,1 ;DONT FAIL IN SUBSCR\r
+ PUSHJ P,SUBSCR ;FIRST DIM\r
+ HRLZ A,E ;SAVE IT\r
+ PUSHJ P,SUBSCR ;SECOND DIM\r
+ HRR A,E\r
+ AOBJP A,MS0CHK ;GO CHECK DIMS AND STORE THEM\r
+>\r
+\fIFN FTMAT, <\r
+;MATRIX OPERATION SETUP ROUTINE\r
+;USE ENTRY POINT MS2 IF 2 ARGS, MS1 IF 1 ARG, MS0 OR MS0CHK IF 0 ARGS.\r
+;ALL ENTRIES EXPECT MS0 EXCEPT DIMENSION [XWD ROWS,COLS]\r
+; OF DESTINATION TO BE SET UP IN A AND CHECK FOR ROOM\r
+; AND SET DIMENSION OF DESTINATION.\r
+;AT CALL, LOCATION 40 CONTAINS THE ADDRS OF DESTINATION DOPE VECTOR,\r
+; RIGHT SIDE OF T1 CONTAINS ADDRS OF DOPE VECTOR FOR ARG 1\r
+; RIGHT SIDE OF T CONTAINS ADDRS OF DOPE VECTOR FOR ARG 2\r
+;RIGHT SIDES OF T1,T,B ARE REPLACED WITH ADDRESSES OF ELEMENTS 0,0\r
+; OF ARG 1, ARG 2, DEST, RESPECTIVELY, WITHOUT CHANGING LEFT SIDES,\r
+; AND THE RESULTS ARE STORED IN TEMP1, TEMP2, AND TEMP3, RESPECTIVELY.\r
+;THE MAXIMUM ROW NUMBER OF DEST IS STORED IN SB1M1, THE MAXIMUM\r
+; COLUMN NUMBER OF DEST IS STORED IN SB2M1\r
+;E, T1, AND G ARE SET TO FIRST ROW NUMBER, FIRST COL NUMBER,\r
+; AND RELATIVE LOCATION OF FIRST ELEMENT, RESPECTIVELY\r
+;IT IS INTENDED THAT E, T1, G, TEMP1, TEMP2, TEMP3 BE SET UP FOR\r
+; IMMEDIATE CALL TO MLP, AND THAT ELEMENTS OF FIRST\r
+; ARGUMENT, SECOND ARGUMENT, AND DESTINATION BE ACCESSED\r
+; BY INDIRECT ADDRESSING THROUGH TEMP1, TEMP2, AND TEMP3, RESPECTIVELY.\r
+\r
+\r
+MS2: HRR T,(T) ;ADDRS OF FIRST ARG\r
+MS1: HRR T1,(T1) ;ADDRS OF SECOND OR ONLY ARG\r
+MS0CHK: HRR B,40 ;DOPE VECTOR OF DEST\r
+ HLLZ X1,A ;CHECK NEW DIMENSION\r
+ IMULI X1,(A) ;X1 := (TOTAL SIZE)0\r
+ CAMLE X1,0(B) ;IS THERE ROOM IN ARRAY?\r
+ JRST DIMERR ;NO. DIMENSION ERROR\r
+ MOVEM A,1(B) ;STORE NEW DIMENSION\r
+\r
+MS0: HRR B,40 ;ENTER HERE FOR NO DIM CHECK\r
+ MOVE A,1(B) ;FETCH DIMENSIONS\r
+ SUB A,[XWD 1,1] ;E := (MAX ROW)MAX COL\r
+ HLRZM A,SB1M1 ;FIRST DIMENSION -1\r
+ HRRZM A,SB2M1 ;SECOND DIMENSION -1\r
+\r
+ HRR B,(B) ;ADDRS OF DEST (LEAVE IN B FOR MINV)\r
+ MOVEM T1,TEMP1 ;STORE FIRST XCT INSTRUCTION\r
+ MOVEM T,TEMP2 ;STORE SECOND XCT INSTRUCTION\r
+ MOVEM B,TEMP3 ;STORE THIRD XCT INSTRUCTION\r
+\r
+;NOW SETUP E, T1, AND G FOR "MLP"\r
+\r
+ SKIPE E,SB1M1 ;MORE THEN 0'TH ROW?\r
+ MOVEI E,1 ;YES. USE FIRST\r
+ SKIPE T1,SB2M1 ;MORE THAN 0'TH COL\r
+ MOVEI T1,1 ;YES. USE FIRST\r
+ MOVE G,SB2M1 ;CALCUATE FIRST ELT OF RESLT\r
+ ADDI G,1\r
+ IMULI G,(E)\r
+ ADDI G,(T1)\r
+ POPJ P,\r
+>\r
+\fIFN FTMAT, <\r
+;MATRIX OPERATION MAIN LOOP\r
+\r
+;ON CALLING, T, T1, G ARE SET UP TO ROW NUMBER, COL NUMBER, AND\r
+; REL LOC OF CURRENT ELEMENT IN DESTINATION MATRIX.\r
+;MLP EXECUTES THE CONTENT OF TEMP1, TEMP2, TEMP3 FOR EACH\r
+; ELEMENT OF CURRENT ROE. AT END OF ROW, MLP RETURNS\r
+; WITHOUT SKIP TO ALLOW ONCE-PER-ROW OPERATIONS TO BE PERFORMED.\r
+; WHEN ALL ROWS HAVE BEEN PROCESSED, MLP RETURNS WITH SKIP.\r
+;NOTE SPECIAL CODING SO THAT ROW AND COLUMN VECTORS ARE\r
+; HANDLED CORRECTLY.\r
+\r
+MLP: XCT TEMP1\r
+ XCT TEMP2\r
+ XCT TEMP3\r
+\r
+ ADDI G,1\r
+ CAMGE T1,SB2M1\r
+ AOJA T1,MLP\r
+ SKIPE SB2M1 ;MORE THAN A 0'TH COL?\r
+ AOJA G,.+2 ;YES. SKIP 0'TH COL\r
+ TDZA T1,T1 ;NO. SET TO USE 0'TH COL\r
+ MOVEI T1,1 ;YES AGAIN. SET TO USE COL 1.\r
+\r
+ CAML E,SB1M1 ;ALL ROWS USED?\r
+ AOS (P) ;YES. SET FOR SKIP RETURN\r
+ AOJA E,CPOPJ ;BUMP ROW AND RETURN\r
+>\r
+\fIFN FTMAT,<\r
+;MATRIX READ ROUTINE\r
+\r
+;SET UP AND CALL MLP. FOR EACH ELEMENT, THE FOLLOWING\r
+;ARE PERFORMED:\r
+; TEMP1: PUSHJ P,MTRELT\r
+; TEMP2: ... ;(SKIPPED)\r
+; TEMP3: MOVEM N,<DEST>(G)\r
+;MTRELT READS A NUMBER INTO N\r
+\r
+MTRDER: MOVE T1,[PUSHJ P,MTRELT]\r
+ PUSHJ P,DOREAD\r
+ HRRZ X1,@40 ;GET ADDRESS OF ZEROTH ELEMENT.\r
+ CAML X1,SVRBOT ;IS THIS A STRING VECTOR?\r
+ JRST MTRDS ;ELEMENTS WILL BE STRINGS.\r
+ HRLI B,G(MOVEM N,)\r
+MTRD1: PUSHJ P,MS0 ;SET UP FOR LOOP\r
+ SETZM 40 ;NOP THE STORE THAT DATAER USES\r
+MTRD2: PUSHJ P,MLP ;EXECUTE LOOP\r
+ JRST .-1 ;NO ACTION ON ROW\r
+ POPJ P,\r
+\r
+;ROUTINE CALLED BY MTRDER TO PRINT AN ELEMENT\r
+\r
+MTRELT: PUSHJ P,DATAER\r
+ JRST CPOPJ1\r
+\r
+MTRDS: MOVSI T1,(SKIPA)\r
+ MOVSI B,G(STOCHA)\r
+ JRST MTRD1\r
+\r
+;MATRIX PRINT ROUTINE\r
+\r
+;SET UP AND CALL MLP:\r
+; TEMP1: PUSH P,T\r
+; TEMP2: PRNM <FORMAT CODE>,<DEST>(G)\r
+; TEMP3: POP P,T\r
+MTPRER: MOVE T1,[PUSH P,T1] ;TO SAVE T1 AROUND PRNM\r
+ PUSHJ P,MS0 ;SET UP FOR LOOP\r
+ HLL B,40 ;PICK UP UUO AC FIELD\r
+ TLZ B,777000 ;CONSTRUCT PRNM INSTR\r
+ SKIPE SB1M1 ;COLUMN VECTOR?\r
+ SKIPN SB2M1\r
+ JRST .+3 ;YES. ALLOW <CR> FORMAT\r
+ TLNN B,(Z 16,) ;OH, NO. TREAT <RET> FORMAT ==<COMA> FORMAT.\r
+ HRLI B,(Z 3,)\r
+ HRRZ X1,@40\r
+ CAMGE X1,SVRBOT ;NUMBER ARRAY?\r
+ TLO B,G(PRNM) ;YES, SETUP NUMBER UUO\r
+ CAML X1,SVRBOT ;STRING ARRAY?\r
+ TLO B,G(PRSTR) ;YSE SEUP STRING PRINT UUO.$\r
+ MOVEM B,TEMP2 ;SET UP TEMP2 AND TEMP3\r
+ MOVE X1,[POP P,T1]\r
+ MOVEM X1,TEMP3\r
+MTP1D: PUSHJ P,MTP3D ;TOW BLANK LINES\r
+MTP2D: PUSHJ P,MLP\r
+ JRST MTP4D\r
+MTP3D: PUSHJ P,PCRLF\r
+ PUSHJ P,PCRLF\r
+ POPJ P,\r
+MTP4D: SKIPE SB1M1 ;VECTOR OR ARRAY?\r
+ SKIPN SB2M1\r
+ JRST MTP2D ;ARRAY... SPACE BETW ROWS\r
+ JRST MTP1D ;VECTOR...DONT SPACE BETW ROWS\r
+>\r
+\fIFN FTMAT, <\r
+;MATRIX ADD AND SUBTRACT ROUTINES\r
+\r
+;SET UP AND CALL MLP:\r
+; TEMP1: MOVE N,<ARG 2>(G) ;OR MOVN\r
+; TEMP2: FADR N,<ARG 1>(G)\r
+; TEMP3: MOVEM N,<DEST>(G)\r
+MTADER: TLOA T1,G(MOVE N,) ;MAKE ADD INSTR (T LOADED WITH MOVEI)\r
+MTSBER: HRLI T1,G(MOVN N,) ;MAKE SUBTRACT INSTR\r
+ HRLI T,G(FADR N,) ;FETCH\r
+ HRLI B,G(MOVEM N,)\r
+ MOVE A,1(T) ;GET AND CHECK DIMENSIONS OF ARGS\r
+ CAME A,1(T1)\r
+ JRST DIMERR\r
+ PUSHJ P,MS2 ;SET UP MATRIX LOOP\r
+ JRST MTRD2 ;FINISH -- NO EACH ROW RTN\r
+\r
+;MATRIX SCALE ROUTINE\r
+\r
+;SET UP AND CALL MLP:\r
+; TEMP1: MOVE A,<ARG 1>(G)\r
+; TEMP2: FMPR A,N\r
+; TEMP3: MOVEM A,<DEST>(G)\r
+\r
+MTSCER: HRLI T1,G(MOVE A,)\r
+ MOVSI T,(FMPR A,N)\r
+MTSC1: HRLI B,G(MOVEM A,)\r
+ MOVE A,1(T1)\r
+ PUSHJ P,MS1\r
+ JRST MTRD2\r
+>\r
+\fIFN FTMAT, <\r
+;MATRIX ZERO, IDENTITY, AND ONE ROUTINES\r
+\r
+;SET UP AND CALL MLP:\r
+; ..IDEN.. ..ZERO.. ..ONE..\r
+; TEMP1: SETZM@TEMP3 SETZM @TEMP3 CAIA\r
+; TEMP2: CAMN T,T1 CAIA ...\r
+; TEMP3: MOVEM A,<DEST>(G)......................\r
+\r
+\r
+MTIDER: SKIPA T,[CAMN E,T1]\r
+MTZRER: MOVSI T,(CAIA)\r
+ SKIPA T1,[SETZM @TEMP3]\r
+MTCNER: MOVSI T1,(CAIA)\r
+ HRLI B,G(MOVEM D,)\r
+ MOVSI D,(DEC 1.0) ;CONSTANT 1.0 TO STORE\r
+ JRST N,MTRD1 ;GO FINISH WITH READ CODE\r
+\r
+\r
+;MATRIX TRANSPOSE ROUTINE\r
+\r
+;SET UP AND CALL MLP:\r
+;A CONTAINS RELATIVE LOC OF CURRENT ELE IN SOURCE\r
+; TEMP1 : FETCH SOURCE ELEMENT\r
+; TEMP2 : UPDATE SOURCE INDEX\r
+; TEMP3 : STORE DESTINATION ELEMENT\r
+\r
+\r
+\r
+MTTNER: MOVS A,1(T1) ;FETCH DESTINATION DIMENSION\r
+ HRLI T1,200003\r
+ HLRZ T,A ;E := ADDI A,<NBR ROWS>\r
+ HRLI T,(ADDI A,)\r
+ HRLI B,G(MOVEM N,)\r
+ PUSHJ P,MS1 ;SET UP CHK DIMENSION\r
+\r
+MTTN1: MOVE A,SB1M1 ;A := <NBR ROWS>*COL + ROW\r
+ ADDI A,1\r
+ IMUL A,T1\r
+ ADD A,E\r
+\r
+ PUSHJ P,MLP ;MOVE A ROW\r
+ JRST MTTN1\r
+ POPJ P,\r
+>\r
+\f\r
+IFN FTMAT, <\r
+;MATRIX MULTIPLY ROUTINE\r
+\r
+;SET UP AND CALL MLP\r
+;FOR EACH ELEMENT OF DESTINATION MATRIX, CALL SUBROUTINE\r
+; MYELT TO FORM THE DOT PRODUCT OF THE APPROPRIATE ROW AND COLUMN\r
+\r
+\r
+MTMYER: MOVE A,1(T) ;CHECK DIMENSIONS\r
+ HLRZ D,1(T1) ;D := INNER DIMENSION\r
+ CAIE D,(A) ;SAVE AS FIRST ARG?\r
+ JRST DIMERR ;NO\r
+ HRR A,1(T1)\r
+\r
+ HRLI T1,T1(MOVEI X2,) ;TO COMPUTE ADDRESS OF 1ST ELT 2ND ARG\r
+ HRLI T,(MOVEI X1,) ;DITTO 1ST ARG\r
+ HRLI B,G(MOVEM N,) ;STORE INSTR\r
+ PUSHJ P,MS2 ;SETUP NEW DIMENSIONS AND MLP ARGS\r
+ MOVEI X1,1(A) ;PREPARE TO SKIP ROW ZERO IF..\r
+ CAIE D,1 ;INNER DIM=1?\r
+ ADDM X1,TEMP1\r
+ MOVE B,[PUSHJ P,MYELT] ;CALL TO ELT COMPUTATION\r
+ EXCH B,TEMP2\r
+\r
+ CAIE D,1 ;INNER DIM 1? (IE PROD OF VECTORS)\r
+ ADDI B,1 ;NO. SKIP 0'TH COL OF 1'ST ARG\r
+ JUMPE E,MTMY2 ;DONT SKIP FIRST ROW IF ONLY 1\r
+\r
+MTMY1: ADDM D,B ;NEXT ROW OF FIRST ARG\r
+MTMY2: PUSHJ P,MLP\r
+ JRST MTMY1\r
+ POPJ P,\r
+\r
+;SUBROUTINE TO COMPUTE ELEMENT OF PRODUCT\r
+;X1 CONTAINS ADDRS OF 1ST ELT OF 1ST ARG FOR DOT PRODUCT,\r
+; AFTER FIRST XCT BELOW, X2 CONTAINS ADDRS OF SAME FOR 2ND ARG\r
+\r
+MYELT: XCT B\r
+ MOVEI N,0 ;TO ACCUMULATE DO PRODUCT\r
+ MOVEI C,-1(D) ;NUMER OF ADDS= REAL INNER DIMENSION\r
+\r
+MYEL1: MOVE Q,(X1) ;PRODUCT OF 2 ELTS\r
+ FMPR Q,(X2)\r
+ FADR N,Q ;ADD INTO DOT PRODUCT\r
+ ADDI X2,1(A) ;NEXT ROW OF 2ND ARG\r
+ SOJLE C,CPOPJ ;DONE?\r
+ AOJA X1,MYEL1 ;NO. TO NEXT ELT\r
+>\r
+\f SUBTTL RUN-TIME MATRIX INVERTER\r
+\r
+IFN FTMAT, <\r
+;SUBROUTINE TO CALL MATRIX INVERTER\r
+\r
+MTIVER: MOVS A,1(T1) ;MAKE SURE SQUARE MATRIX\r
+ CAME A,1(T1)\r
+ JRST N,DIMERR\r
+\r
+ HRLI T1,G(SKIPA A,) ;MOVE DESTINATION\r
+ PUSHJ P,MTSC1 ;(USE MTCNER CODE)\r
+ SKIPE SB1M1 ;GO INVERT UNLESS ONLY ELT IS (0,0)\r
+ JRST MINVB\r
+\r
+ SUBI B,3\r
+ MOVEM B,TEMP3 ;ONLY ELEMENT IS (0,0)\r
+ AOS SB1M1 ;FOOL MINV INTO THINGING ITS (1,1)\r
+ JRST MINVB\r
+\r
+;THIS PORTION OF THE MAT INVERSE PROG RUNS IN ACS 0-7\r
+\r
+JLOOP:\r
+ PHASE 0\r
+\r
+ZERO: CAMN JX,NT ;SKIP SAME COL\r
+ JRST JXIT\r
+ MOVE TAC,@TEMP1 ;A(I,J)=A(I,J)+A(NT,J)*A(I,NT)\r
+ FMPR TAC,(KX) ;***\r
+MOD: FADRM TAC,0(JX) ;ADDR MODIFIED BY OUTER LOOP\r
+JXIT: CAMGE JX,SB1M1 ;LOOP DONE?\r
+ AOJA JX,ZERO\r
+ JRST IXIT ;YES RETURN\r
+\r
+ DEPHASE\r
+\r
+;SOME AC DEFS FOR MINV\r
+\r
+NT=10 ;OUTERMOST LOOP INDEX\r
+IX=11 ;I SUBSCRIPT\r
+JX=12 ;J SUBSCRIPT\r
+KX=13 ;SCRATCH INDEX REG\r
+LX=14 ; " " "\r
+TAC=15\r
+TAC1=16 ; " (MUST BE SAVE & RESTORED)\r
+>\r
+\fIFN FTMAT, <\r
+;MAIN ROUTINE ENTERS HERE TO SET UP REGS\r
+;ROUTINE EXPECTS 1) ARRAY ADDR IN TEMP3\r
+; 2) ORDER OF ARRAY IN SB1M1\r
+;ROUTINE USES 1) VECT1 & VECT2 AS SCRATCH\r
+; 2) SB2M1 AS CNT OF ELEMENTS / ROW\r
+\r
+MINVB: HRRZS TEMP3 ;MAKE SURE ADDR ONLY\r
+ MOVE TAC,SB1M1 ;GET ORDER\r
+ ADDI TAC,1 ;ADD ONE FOR 0'TH ROW & COL\r
+ MOVEM TAC,SB2M1 ;SAVE IN SB2\r
+ PUSH P,TAC1\r
+ MOVSI TAC,(1.0) ;INIT DETERM.\r
+ MOVEM TAC,DETER\r
+ HRLZI TAC,JX ;SET INDEX REG IN\r
+ HLLZM TAC,TEMP1 ;TEMP1 FOR INDIRECT\r
+ MOVE TAC,[XWD JLOOP,ZERO]\r
+ BLT TAC,7 ;PUT JLOOP INTO ACS\r
+\r
+ MOVEI NT,1 ;INITIALIZE OUTER LOOP\r
+MINVLP: MOVE TAC,NT\r
+ IMUL TAC,SB2M1 ;CALC (NT,NT) SUBSCR\r
+ ADD TAC,NT\r
+ ADD TAC,TEMP3 ;***\r
+ MOVEM TAC,TEMP2 ;SAVE IT FOR LATER\r
+ CAMN NT,SB1M1 ;LAST ITER?\r
+ JRST FOUND1 ;SAVE SEARCH STUFF\r
+ MOVM TAC,(TAC) ;GET A(NT,NT)\r
+ MOVE IX,NT ;INITIALIZE SEARCH\r
+\r
+LUPI: MOVE KX,SB2M1 ;CALC I INDEX\r
+ IMUL KX,IX\r
+ ADD KX,TEMP3 ;***\r
+ MOVE JX,NT ;INIT J INDEX\r
+LUPJ: MOVE LX,KX\r
+ ADD LX,JX ;FINISH INDEX FOR ELEMENT\r
+ MOVM LX,(LX) ;GET IT\r
+ CAMGE LX,TAC ;IS IT LARGER THAN PRESENT\r
+ JRST LUPEND ;NO\r
+ MOVE TAC,LX ;YES SAVE IT\r
+ MOVEM IX,VECT1(NT) ;AND INDEXES\r
+ MOVEM JX,VECT2(NT)\r
+LUPEND: CAMGE JX,SB1M1 ;END OF J LOOP LOGIC\r
+ AOJA JX,LUPJ\r
+ CAMGE IX,SB1M1\r
+ AOJA IX,LUPI\r
+>\r
+\fIFN FTMAT, <\r
+ PUSHJ P,FSWAP\r
+FOUND1: MOVE TAC,@TEMP2 ;GET PIVOT ELEMENT\r
+ JUMPE TAC,SING ;TEST FOR SINGULARITY.\r
+ MOVEM TAC,PIVOT ;SAVE IT\r
+ FMPRM TAC,DETER ;PERPETUATE DETERM\r
+ MOVSI TAC,(1.0) ;1./A(NT,NT)\r
+ FDVRM TAC,PIVOT ;***\r
+\r
+ MOVEI IX,1 ;SET UP I\r
+ILOOP: CAMN IX,NT ;SKIP SAME ROW\r
+ JRST IXIT ;AS PIVOT ROW\r
+ MOVE LX,SB2M1 ;CALCUATE ALL ROW OFFSETS\r
+ IMUL LX,IX\r
+ ADD LX,TEMP3 ;LX= IX*N+A\r
+ MOVE KX,LX\r
+ ADD KX,NT ;KX=LX+NT\r
+ MOVN TAC,PIVOT ;GET -PIVOT\r
+ FMPRM TAC,(KX) ;A(I,NT)=A(I,NT)/(-A(NT,NT))\r
+ MOVEI JX,1 ;SET J LOOP START\r
+ MOVE TAC,SB2M1\r
+ IMUL TAC,NT\r
+ ADD TAC,TEMP3 ;TAC=NT*N+A\r
+ HRRM TAC,TEMP1 ;STORE FOR @TMEP1(JX)\r
+ HRR MOD,LX ;SAT ADDR IN INNER LOOP\r
+ JRST ZERO ;GO\r
+\r
+IXIT: CAMGE IX,SB1M1 ;RETURN HERE FROM ACS\r
+ AOJA IX,ILOOP\r
+ MOVEI JX,1 ;SET LOOP FOR LAST COL\r
+ MOVE TAC,PIVOT ;GET PIVOT\r
+LCOL: FMPRM TAC,@TEMP1 ;A(NT,J)=A(NT,J)/A(NT,NT)\r
+ CAMGE JX,SB1M1 ;DONE\r
+ AOJA JX,LCOL\r
+ MOVEM TAC,@TEMP2 ;A(NT,NT)=PIVOT\r
+ CAMGE NT,SB1M1 ;INVERSE DONE?\r
+ AOJA NT,MINVLP\r
+>\r
+\fIFN FTMAT, <\r
+;HERE WHEN INVERSE DONE PUT MATRIX BACK TOGETHER\r
+\r
+ MOVE NT,SB1M1 ;DO LOOP IN REVERSE ORDER\r
+INVFIX: SOJLE NT,OUT ;FINISHED\r
+ PUSHJ P,BSWAP ;SWAP ROW - COL IN REV.\r
+ JRST INVFIX\r
+BSWAP: MOVE KX,VECT2(NT)\r
+ MOVE LX,VECT1(NT) ;SET REGS\r
+ JRST SWAP\r
+FSWAP: MOVE KX,VECT1(NT)\r
+ MOVE LX,VECT2(NT)\r
+SWAP: MOVE TAC1,NT\r
+ IMUL TAC1,SB2M1 ;CALC BOTH ROW OFFSETS\r
+ IMUL KX,SB2M1\r
+ ADD TAC1,TEMP3\r
+ ADD KX,TEMP3 ;***\r
+ MOVEI JX,1\r
+ HRLI TAC1,JX\r
+ HRLI KX,JX\r
+SWP1: MOVE TAC,@TAC1 ;EXCHANGE ITEMS IN ROWS\r
+ EXCH TAC,@KX\r
+ MOVEM TAC,@TAC1\r
+ CAMGE JX,SB1M1\r
+ AOJA JX,SWP1\r
+ MOVEI IX,1\r
+ MOVE TAC1,NT\r
+ MOVE KX,SB2M1\r
+ ADD KX,TEMP3 ;GET COL ADDR\r
+ HRLI TAC1,KX\r
+ HRLI LX,KX\r
+SWP2: MOVE TAC,@LX\r
+ EXCH TAC,@TAC1\r
+ MOVEM TAC,@LX\r
+ CAML IX,SB1M1 ;CHECK DONE\r
+ POPJ P, ;RETURN\r
+ ADD KX,SB2M1 ;TO NEXT COL\r
+ AOJA IX,SWP2\r
+\r
+;HERE TO RETURN OR MAKE SINGULAR\r
+\r
+SING: SETZB ZERO,DETER\r
+OUT: POP P,TAC1\r
+DETB: MOVE ZERO,DETER\r
+ POPJ P,\r
+\r
+ABSB: MOVMS N,N\r
+ POPJ P,\r
+>\r
+\f SUBTTL INTRINSIC FUNCTIONS (ADAPTED FROM LIB4 V.005)\r
+\r
+;FLOATING POINT SINGLE PRECISION ARCTANGENT FUNCTION\r
+;ATAN(X) = X(B0+A1(Z+B1-A2(Z+B2-A3(Z+B3)**-1)**-1)**-1)\r
+;WHERE Z=X^2, IF 0<X<=1\r
+\r
+;IF X>1, THEN ATAN(X) = PI/2 - ATAN(1/X)\r
+;IF X>1, THEN RH(A) =-1, AND LH(A) = -SGN(X)\r
+;IF X<1, THEN RH(A) = 0, AND LH(A) = SGN(X)\r
+\r
+ATANB: ;ENTRY TO ARCTANGENT ROUTINE\r
+ MOVM T, N ;GET ABSF OF ARGUMENT\r
+ CAMG T, A1 ;IF A<2^33, THEN RETURN WITH...\r
+ POPJ P, ;ATAN(X)=X\r
+ HLLO B, N ;SAVE SIGN, SET PH(A) = -1\r
+ CAML T, A2 ;IF A>2^33, THEN RETURN WITH\r
+ JRST N, AT4 ;ATAN(X) = PI/2\r
+ MOVSI T1, (1.0) ;FORM 1.0 IN T1\r
+ CAMG T, T1 ;IS ABSF(X)>1.0?\r
+ TRZA B, -1 ;IF T .E. 1.0, THEN RH(A) = 0\r
+ FDVM T1, T ;B IS REPLACED BY 1.0/B\r
+ TLC B, (B) ;XOR SIGN WITH .G. 1.0 INDICATOR\r
+ MOVEM T, C3 ;SAVE THE ARGUMENT\r
+ FMP T, T ;GET B^2\r
+ MOVE T1, KB3 ;PICK UP N CONSTANT\r
+ FAD T1, T ;ADD B^2\r
+ MOVE N, KA3 ;ADD IN NEXT CONSTANT\r
+ FDVM N, T1 ;FORM -A3/(B^2 + B3)\r
+ FAD T1, T ;ADD B^2 TO PARTIAL SUM\r
+ FAD T1, KB2 ;ADD B2 TO PARTIAL SUM\r
+ MOVE N, KA2 ;PICK UP -A2\r
+ FDVM N, T1 ;DIVIDE PARTIAL SUM BY -A2\r
+ FAD T1, T ;ADD B^2 TO PARTIAL SUM\r
+ FAD T1, KB1 ;ADD B1 TO PARTIAL SUM\r
+ MOVE N, KA1 ;PICK UP A1\r
+ FDV N, T1 ;DIVIDE PARTIAL SUM BY A1\r
+ FAD N, KB0 ;ADD B0\r
+ FMP N, C3 ;MULTIPLY BY ORIGINAL ARGUMENT\r
+ TRNE B, -1 ;CHECK .G. 1.0 INDICATOR\r
+ FSB N, PIOT ;ATAN(N) = -(ATAN(1/A)-PI/2)\r
+ CAIA ;SKIP\r
+AT4: MOVE N, PIOT ;GET PI/2 AS ANSWER\r
+NEGANS: SKIPGE B ;LH(A)= -SGN(T) IF B>1.0\r
+ MOVNS N ;NEGATE ANSWER\r
+ POPJ P, ;EXIT\r
+\r
+A1: 145000000000 ;2**-33\r
+A2: 233000000000 ;2**33\r
+KB0: 176545543401 ;0.1746554388\r
+KB1: 203660615617 ;6.762139240\r
+KB2: 202650373270 ;3.316335425\r
+KB3: 201562663021 ;1.448631538\r
+KA1: 202732621643 ;3.709256262\r
+KA2: 574071125540 ;-7.106760045\r
+KA3: 600360700773 ;-0.2647686202\r
+PIOT: 201622077325 ;PI/2\r
+\f;FLOATING POINT TRUNCATION FUNCTION\r
+;TRUNCATES FRACTIONAL PART OF FLOATING POINT NUMBER\r
+;AND RETURNS ANSWER AS N FLOATING POINT NUMBER. THE\r
+;ALGORITHM MAKES USE OF THE NORMALIZING PROPERTIES OF FAD.\r
+;ROUTINE EXITS WITH (T)=ZERO IF NUMBER WAS AN INTEGER.\r
+\r
+INTB:\r
+ MOVE B,N ;SAVE ARGUMENT\r
+ MOVMS N ;GET ABSF(ARG)\r
+ SKIPGE B ;NEGATIVE?\r
+ FAD N,ALMST1 ;YES. MAKE AINT[-2.3]=-3 ETC.\r
+ CAML N,MOD1 ;IS ARGUMENT<=2**26?\r
+ JRST NEGANS ;YES; IT MUST BE AN INTERGER ALREADY\r
+ FAD N,MOD1\r
+ FSB N,MOD1 ;NOW FRACTIONAL PART HAS BEEN LOST.\r
+ JRST NEGANS ;CHECK SIGN AND EXIT.\r
+\r
+MOD1: XWD 233400,000000 ; 2**26\r
+\r
+ALMST1: XWD 200777,777777 ;1.0-<SMALLEST QUANTITY>\r
+\r
+\f;FLOATING POINT SINGLE PRECISION LOGARITHM FUNCTION\r
+;LOG(ABSF(X)) IS CALCULATED BY THE SUBROUTINE, AND AN\r
+;ARGUMENT OF ZERO IS RETURNED AS MINUS INFINITY. THE ALGORITHM IS\r
+\r
+;LOGE(X) = (I + LOG2(F))*LOGE(2)\r
+;WHERE X = (F/2)*2^(I+1), AND LOG2(F) IS GIVEN BY\r
+;LOG2(F) = C1*Z + C3*Z^3 + C5*Z^5 - 1/2\r
+;AND Z = (F-SQRT(2))/(F+SQRT(2))\r
+\r
+LOGB:\r
+ JUMPL N, ALOGB1\r
+LOGB0: MOVMS N, N ;USE ABSOLUTE VALUE\r
+ JUMPE N, LZERO ;CHECK FOR ZERO ARGUMENT\r
+ CAMN N, ONE ;CHECK FOR 1.0 ARGUMENT\r
+ JRST ZERANS ;IT IS 1.0 RETURN ZERO ANS.\r
+ ASHC N, -33 ;SEPARATE FRACTION FROM EXPONENT\r
+ ADDI N, 211000 ;FLOAT THE EXPONENTY AND MULT. BY 2\r
+ MOVSM N, C3 ;NUMBER NOW IN CORRECT FL. FORMAT\r
+ MOVSI N, 567377 ;SET UP -401.0 IN N\r
+ FADM N, C3 ;SUBTRACT 401 FORM EXP.*2\r
+ ASH T, -10 ;SHIFT FRACTION FOR FLOATING\r
+ TLC T, 200000 ;FLOAT THE FRACTION PART\r
+ FAD T, L1 ;B = T-SQRT(2.0)/2.0\r
+ MOVE N, T ;PUT RESULTS IN N\r
+ FAD N, L2 ;A = N+SQRT(2.0)\r
+ FDV T, N ;B = B/A\r
+ MOVEM T, SX ;STORE NEW VARIABLE IN LZ\r
+ FMP T, T ;MULTIPLY BY Z^2\r
+ MOVE N, L3 ;PICK UP FIRST CONSTANT\r
+ FMP N, T ;MULTIPLY BY Z^2\r
+ FAD N, L4 ;ADD IN NEXT CONSTANT\r
+ FMP N, T ;MULTIPLY BY Z^2\r
+ FAD N, L5 ;ADD IN NEXT CONSTANT\r
+ FMP N, SX ;MULTIPLY BY Z\r
+ FAD N, C3 ;ADD IN EXPONENT TO FORM LOG2(X)\r
+ FMP N, L7 ;MULTIPLY TO FORM LOGE(X)\r
+ POPJ P, ;EXIT\r
+LZERO: PUSHJ P,INLMES\r
+ ASCIZ /LOG OF ZERO IN /\r
+ PUSHJ P,GOSR3\r
+ MOVE N,MIFI\r
+ POPJ P,\r
+ZERANS: SETZI N, ;MAKE ARG ZERO\r
+ POPJ P,\r
+\r
+;CONSTANTS FOR ALOGB\r
+\r
+\r
+ONE: 201400000000\r
+L1: 577225754146 ;-0.707106781187\r
+L2: 201552023632 ;1.414213562374\r
+L3: 200462532521 ;0.5989786496\r
+L4: 200754213604 ;0.9614706323\r
+L5: 202561251002 ;2.8853912903\r
+ALOGB1: PUSH P,N ;SAVE ARGUMENT\r
+ PUSHJ P,INLMES\r
+ ASCIZ /LOG OF NEGATIVE NUMBER IN /\r
+ PUSHJ P,GOSR3 ;PRINT LINE NUMBER\r
+ POP P,N ;GET ARGUMENT\r
+ JRST LOGB0\r
+L7: 200542710300 ;0.69314718056\r
+MIFI: XWD 400000,000001 ;GOAL POSTS. LARGEST NEGATIVE NUMBER.\r
+NUMB: MOVE N,NUMRES\r
+ POPJ P,\r
+SGNB:\r
+ JUMPE N,ZERANS ;RETURN ZERO ANSWER\r
+ MOVE B,N\r
+ MOVSI N,(1.0) ;RETURN 1.0\r
+ JRST NEGANS ;CHECK IF MINUS RESULT\r
+\r
+\f;FLOATING POINT SINGLE PRECISION SINE AND COSINE FUNCTION\r
+;THE ARGUMENT IS IN RADIANS.\r
+;ENTRY POINTS ARE SIN AND COS.\r
+;COS CALLS SIN TO CALCULATE SIN(PI/2 + X)\r
+\r
+;THE ROUTINE CALCULATES SINES AFTER REDUCING THE ARGUMENT TO\r
+;THE FIRST QUADRANT AND CHECKING THE OVERFLOW BITS TO DETERMINE\r
+;THE QUADRANT OF THE ORIGINAL ARGUMENT\r
+;000 - 1ST QUADRANT\r
+;001 - 2ND QUADRANT, X=-(X-PI)\r
+;010 - 3RD QUADRANT, X=-(X-PI)\r
+;011 - 4TH QUADRANT, X=X-3*PI/2-PI/2\r
+;THE ALGORITHM USES N MODIFIED TAYLOR SERIES TO CALCULATE\r
+;THE SINE OF THE NORMALIZED ARGUMENT.\r
+\r
+\r
+COSB: ;ENTRY TO COSINE RADIANS ROUTINE\r
+ FADR N, PIOT ;ADD PI/2\r
+ ;FALL INTO SINE ROUTINE\r
+\r
+SINB: ;ENTRY TO SINE RADIANS ROUTINE\r
+ MOVE T, N ;PICK UP THE ARGUMENT IN T\r
+ MOVEM T, SX ;SAVE IT\r
+ MOVMS T ;GET ABSF OF ARGUMENT\r
+ CAMG T, SP2 ;SINX = X IF X<2^-10\r
+ POPJ P, ;EXIT WITH ANS=ARG\r
+ FDV T, PIOT ;DIVIDE X BY PI/2\r
+ CAMG T, ONE ;IS X/(PI/2) < 1.0?\r
+ JRST S2 ;YES, ARG IN 1ST QUADRANT ALREADY\r
+ MULI T, 400 ;NO, SEPARATE FRACTION AND EXP.\r
+ ASH T1, -202(T) ;GET X MODULO 2PI\r
+ MOVEI T, 200 ;PREPARE FLOATING FRACTION\r
+ ROT T1, 3 ;SAVE 3 BITS TO DETERMINE QUADRANT\r
+ LSHC T, 33 ;ARGUMENT NOW IN RANHGE (-1,1)\r
+ FAD T, SP3 ;NORMALIZE THE ARGUMENT\r
+ JUMPE T1, S2 ;REDUCED TO FIRST QUAD IF BITS 00\r
+ TLCE T1, 1000 ;SUBTRACT 1.0 FROM ARG IF BITS ARE\r
+ FSB T, ONE ;01 OR 11\r
+ TLCE T1, 3000 ;CHECK FOR FIRST QUADRANT, 01\r
+ TLNN T1, 3000 ;CHECK FOR THIRD QUADRANT, 10\r
+ MOVNS N, T ;01,12\r
+\f\r
+S2: SKIPGE SX ;CHECK SIGN OF ORIGINAL ARG\r
+ MOVNS T ;SIN(-X) = -SIN(X)\r
+ MOVEM T, SX ;STORE REDUCED ARGUMENT\r
+ FMPR T, T ;CALCULATE X^2\r
+ MOVE N, SC9 ;GET FIRST CONSTANT\r
+ FMP N, T ;MULTIPLY BY X^2\r
+ FAD N, SC7 ;ADD IN NEXT CONSTANT\r
+ FMP N, T ;MULTIPLY BY X^2\r
+ FAD N, SC5 ;ADD IN NEXT CONSTANT\r
+ FMP N, T ;MULTIPLY BY X^2\r
+ FAD N, SC3 ;ADD IN NEXT CONSTANT\r
+ FMP N, T ;MULTIPLY BY X^2\r
+ FAD N, PIOT ;ADD IN LAST CONSTANT\r
+ FMPR N, SX ;MULTIPLY BY X\r
+ POPJ P, ;EXIT\r
+\r
+\r
+SC3: 577265210372 ;-0.64596371106\r
+SC5: 175506321276 ;0.07968967928\r
+SC7: 606315546346 ;0.00467376557\r
+SC9: 164475536722 ;0.00015148419\r
+\r
+SP2: 170000000000 ;2**-10\r
+SP3: 0 ;0\r
+CD1: 90.0\r
+SCD1: 206712273406\r
+\f;FLOATING POINT SINGLE PRECISION SQUARE ROOT FUNCTION\r
+;THE SQUARE ROOT OF THE ABSOLUTE VALUE OF THE ARGUMENT IS\r
+;CALCULATED. THE ARGUMENT IS WRITTEN IN THE FORM\r
+; X= F*(2**2B) WHERE 0<F<1\r
+;SQRT(X) IS THEN CALCULATED AS (SQRT(X))*(2**B)\r
+;SQRT(F) IS CALCULATED BY N LINEAR APPROXIMATION, THE NATURE\r
+;OF WHICH DEPENDS ON WHETHER 1/4 < F < 1/2 OR 1/2 < F < 1,\r
+;FOLLOWED BY TWO ITERATIONS OF NEWTON'S METHOD.\r
+\r
+SQRTB: MOVE T, N ;PICK UP THE ARGUMENT IN T\r
+SQRTB0: JUMPL T, SQRMIN ;SQRT OF NEGATIVE NUMBER?\r
+ JUMPE T, ZERANS ;CHECK FOR AGUMENT OF ZERO\r
+ ASHC T, -33 ;PUT EXPONENT IN T, FRACTION IN T1\r
+ SUBI T, 201 ;SUBTRACT 201 FROM EXPONENT\r
+ ROT T, -1 ;CUT EXP IN HALF, SAVE ODD BIT\r
+ HRRM T, EX1 ;SAVE FOR FUTURE SCALING OF ANS\r
+ ;IN FSC N,. INSTRUCTION\r
+ LSH T, -43 ;GET BIT SAVED BY PREVIOUS INST.\r
+ ASH T1, -10 ;PUT FRACTION IN PROPER POSITION\r
+ FSC T1, 177(T) ;PUT EXPONENT OF FRACT TO -1 OR 0\r
+ MOVEM T1, N ;SAVE IT. 1/4 < F < 1\r
+ FMP T1, SQCON1(T) ;LINEAR FIRST APPROX,DEPENDS ON\r
+ FAD T1, SQCON2(T) ;WHETHER 1/4<F<1/2 OR 1/2<F<1.\r
+ MOVE T, N ;START NEWTONS METHOD WITH FRAC\r
+ FDV T, T1 ;CACULATE X(0)/X(1)\r
+ FAD T1, T ;X(1) + X(0)/X(1)\r
+ FSC T1, -1 ;1/2(X(1) + X(0)/X(1))\r
+ FDV N, T1 ;X(0)/X(2)\r
+ FADR N, T1 ;X(2) + X(0)/X(2)\r
+ XCT EX1\r
+ POPJ P, ;EXIT\r
+\r
+SQCON1: 0.8125 ;CONSTANT, USED IF 1/4<FRAC<1/2\r
+ 0.578125 ;CONSTANT, USED IF 1/2<FRAC<1\r
+SQCON2: 0.302734 ;CONSTANT, USED IF 1/4<FRAC<1/2\r
+ 0.421875 ;CONSTANT, USED IF 1/2<FRAC<1\r
+\r
+SQRMIN: PUSH P,T ;SAVE ARG\r
+ PUSHJ P,INLMES\r
+ ASCIZ /SQRT OF NEGATIVE NUMBER IN /\r
+ PUSHJ P,GOSR3 ;PRINT LINE NUMBER\r
+ POP P,T ;GET ARG\r
+ MOVMS T\r
+ JRST SQRTB0 ;USE ABSOLUTE VALUE\r
+\r
+\f;TAN - SINGLE PRECISION TANGENT ROUTINE.\r
+;\r
+;BASED ON ACM ALGORITHM 229, (COMM. ACM, 7, MAY 1964, J. MORELOCK).\r
+\r
+;METHOD:\r
+;\r
+;TAN(N*(PI/2)+A) = -(1/TAN(A)) IF N IS ODD,\r
+;TAN(N*(PI/2)+A) = TAN(A) IF N IS EVEN.\r
+;\r
+;/A/ IS <= 0.5*(PI/2).\r
+\r
+;ON ENTRY, THE ARG IS IN AC N.\r
+;ON EXIT, THE ANSWER IS IN AC N.\r
+\r
+;COTAN (X)=TAN(PI/2-X)\r
+\r
+COTB: MOVNS N ;CALCULATE -X...\r
+ FADR N,PIOT ;PLUS PI/2\r
+TANB: MOVEM N,PIVOT\r
+ PUSHJ P,COSB\r
+ JUMPE N,TANB1\r
+ EXCH N,PIVOT\r
+ PUSHJ P,SINB\r
+ FDVR N,PIVOT\r
+ POPJ P,\r
+TANB1: PUSHJ P,INLMES\r
+ ASCIZ 'TAN OF PI/2 OR COTAN OF ZERO IN '\r
+ JRST 410317\r
+\f;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION\r
+;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE\r
+; -88.028<X<88.028\r
+;IF X<-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER\r
+;IF X>88.028, THE PROGRAM RETURNS +INFINITY AS THE ANSWER\r
+;THE RANGE OF THE ARGUMENT IS REDUCED AS FOLLOWS:\r
+;EXP(X) = 2**(X*LOG(B)BASE2) = 2**(M+F)\r
+;WHERE M IS AN INTEGER AND F IS N FRACTION\r
+;2**M IS CALCULATED BY ALGEBRAICALLY ADDING M TO THE EXPONENT\r
+;OF THE RESULT OF 2**F. 2**F IS CALCULATED AS\r
+\r
+;2**F = 2(0.5+F(A+B*F^2 - F-C(F^2 + D)**-1)**-1\r
+\r
+;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:\r
+; PUSHJ P, EXP\r
+;\r
+;THE ARGUMENT IS IN N\r
+;THE ANSWER IS RETURNED IN ACCUMULATOR N\r
+\r
+EXPB: ;ENTRY TO EXPONENTIAL ROUTINE\r
+ MOVE T, N ;PICK UP THE ARGUMENT IN T\r
+ MOVM N, T ;GET ABSF(X)\r
+ CAMLE N, E7 ;IS ARGUMENT IN PROPER RANGE?\r
+ JRST N, EXTOLG ;EXP TO LARGE.;##MSG +CON OR STOP?\r
+\r
+ SETZM N, ES2 ;INITIALIZE ES2\r
+ MULI T, 400 ;SEPARATE FRACTION AND EXPONENT\r
+ TSC T, T ;GET N POSITIVE EXPONENT\r
+ MUL T1, E5 ;FIXED POINT MULTIPLY BY LOG2(B)\r
+ ASHC T1, -242(T) ;SEPARATE FRACTION AND INTEGER\r
+ AOSG T1 ;ALGORITHM CALLS FOR MULT. BY 2\r
+ AOS T1 ;ADJUST IF FRACTION WAS NEGATIVE\r
+ HRRM T1, EX ;SAVE FOR FUTURE SCALING\r
+ ASH A, -10 ;MAKE ROOM FOR EXPONENT\r
+ TLC A, 200000 ;PUT 200 IN EXPONENT BITS\r
+ FADB A, ES2 ;NORMALIZE, RESULTS TO A AND ES2\r
+ FMP A, A ;FORM X^2\r
+ MOVE N, E2 ;GET FIRST CONSTANT\r
+ FMP N, A ;E2*X^2 IN N\r
+ FAD A,E4 ;ADD E4 TO RESULTS IN A\r
+ MOVE T, E3 ;PICK UP E3\r
+ FDV T, A ;CALCULATE E3/(F^2 + E4)\r
+ FSB N, T ;E2*F^2-E3(F^2 + E4)**-1\r
+ MOVE T1, ES2 ;GET F AGAIN\r
+ FSB N, T1 ;SUBTRACT FROM PARTIAL SUM\r
+ FAD N, E1 ;ADD IN E1\r
+ FDVM T1, N ;DIVIDE BY F\r
+ FAD N,E6 ;ADD 0.5\r
+ XCT EX ;SCALE THE RESULTS\r
+ POPJ P, ;EXIT\r
+\r
+E1: 204476430062 ;9.95459578\r
+E2: 174433723400 ;0.03465735903\r
+E3: 212464770715 ;617.97226953\r
+E4: 207535527022 ;87.417497202\r
+E5: 270524354513 ;LOG(B), BASE 2\r
+E6: 0.5\r
+E7: 207540071260 ;88.028\r
+EXTOLG: PUSHJ P,INLMES\r
+ ASCIZ /EXP TOO LARGE IN /\r
+ PUSHJ P,GOSR3\r
+ JRST LRGNS1\r
+\f;SINGLE PRECISION EXP.2 FUNCTION\r
+;THIS ROUTINE CALCULATES A FLOATING POINT NUMBER TO A FIXED\r
+;POINT POWER. THE CALCULATION IS A**B, WHERE T IS OF THE FORM\r
+\r
+; T=Q(0) + Q(1)*2 + Q(2)*4 + ...WHERE Q(I)=0 OR 1\r
+\r
+;THE BASE IS IN ACCUMULATOR N\r
+;AND THE EXPONENT IS IN ACCUMULATOR (N+1) WHEN THE ROUTINE IS\r
+;CALLED. THE ANSWER IS RETURNED IN ACCUMULATOR N.\r
+;EXP.2 IS CALLED ONLY BY EXP.3. IT IS GUARANTEED THAT THE\r
+;BASE AND THE EXPONENT ARE NON-ZERO.\r
+\r
+\r
+EXP2.0: JUMPE N,FEXP3\r
+ MOVSI T1,(1.0)\r
+ JUMPGE T,FEXP2\r
+ MOVMS N,T ;ABSOLUTE VALUE\r
+ PUSHJ P,FEXP2\r
+ MOVSI T,(1.0)\r
+ FDVM T,N\r
+ POPJ P,\r
+FEXP1: FMP N,N ;FORM A**N, FLOATING POINT\r
+ LSH T,-1 ;SHIFT EXPONENT FOR NEXT BIT\r
+FEXP2: TRZE T,1 ;IS THE BIT ON?\r
+ FMP T1,N ;YES, MULTIPLY ANSWER BY A**N\r
+ JUMPN T,FEXP1 ;UPDATE A**N UNLESS ALL THOUGH\r
+ MOVE N,T1 ;PICK UP RESULT FROM T1\r
+ POPJ P, ;EXIT\r
+FEXP3: SKIPN N,T\r
+ MOVSI N,(1.0)\r
+ POPJ P,\r
+\r
+;SINGLE PRECISION FORTRAN IV EXP.3 FUNCTION\r
+;THIS ROUTINE CALCULATES A FLOATING POINT NUMBER RAISED TO A\r
+;FLOATING POINT POWER. THE CALCULATION IS\r
+; A**B= EXP(B*LOG(N))\r
+\r
+;IF THE EXPONENT IS AN INTEGER THE\r
+;RESULT WILL BE COMPUTED USING "EXP2.0" .\r
+\r
+;THE CALLING SEQUENCE FOR THE ROUTINE IS AS FOLLOWS:\r
+; PUSHJ P, EXP3.0\r
+;THE BASE IS IN ACCUMULATOR N\r
+;AND THE EXPONENT IS IN ACCUMULATOR (N+1) WHEN THE ROUTINE\r
+;IS CALLED. THE RESULT IS RETURNED IN ACCUMULATOR N.\r
+\r
+\r
+\r
+\r
+EXP3.0: JUMPE T,EXP3A ;IS EXPONENT ZERO?\r
+ JUMPE N,EXP3B ;IS BASE ZERO?\r
+EXP3A0: MOVM A,T ;SET UP ABS VAL OF EXPON FOR SHIFTING\r
+ JUMPL N,EXP3C ;IS BASE NEGATIVE?\r
+EXP3A1: MOVEI T1,0 ;CLEAR AC T1 TO ZERO\r
+ LSHC T1,11 ;SHIFT 9 PLACES LEFT\r
+ SUBI T1,200 ;TO OBTAIN SHIFTING FACTOR\r
+ JUMPLE T1,EXP3GO\r
+ HRR B,T1\r
+ MOVEI T1,0\r
+ LSHC T1,0(B)\r
+ JUMPN A,EXP3GO\r
+ SKIPGE T ;YES, WAS IT NEG. ?\r
+ MOVNS T1 ;YES, NEGATE IT\r
+ MOVE T,T1 ;MOVE INTEGER INTO T\r
+ JRST EXP2.0 ;OBTAIN RESULT USING EXP2.0\r
+EXP3GO: PUSH P,T ;SAVE EXPONENT\r
+ PUSHJ P,LOGB ;CALCULATE LOG OF N\r
+ FMPR N,(P) ;CALCULATE B*LOG(N)\r
+ PUSHJ P,EXPB ;CALCULATE EXP(B*LOG(N))\r
+ POP P,T\r
+ POPJ P, ;RETURN\r
+\r
+EXP3A: MOVSI N,(1.0) ;ANSWER IS 1.0\r
+ POPJ P,\r
+\r
+EXP3B: JUMPGE T,ZERANS\r
+ PUSHJ P,INLMES\r
+ ASCIZ /ZERO TO A NEGATIVE POWER IN /\r
+ PUSHJ P,GOSR3\r
+LRGNS1: HRLOI N,377777 ;LARGEST ANSWER\r
+ POPJ P,\r
+\r
+EXP3C: MOVE X1,A\r
+ FAD X1,FIXCON\r
+ FSB X1,FIXCON\r
+ CAMN A,X1\r
+ JRST EXP3A1 ;NEGATIVE BASE, INTEGRAL POWER\r
+ PUSH P,N ;SAVE ARGUMENTS\r
+ PUSH P,T\r
+ PUSHJ P,INLMES\r
+ ASCIZ /ABSOLUTE VALUE RAISED TO POWER IN /\r
+ PUSHJ P,GOSR3\r
+ POP P,T\r
+ POP P,N\r
+ MOVMS N\r
+ JRST EXP3A0\r
+\r
+\f SUBTTL RUN-TIME RANDOM NUMBER ROUTINES\r
+\r
+IFN FTRND, <\r
+;;WRANB -- PSEUDO-RANDOM RESET/WARMUP\r
+; PUSHJ P,WRANB\r
+;\r
+;THE ARG IS IN ACCUMULATOR A\r
+;\r
+; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.\r
+; 2. W IS A BIT VECTOR (BITS 05-35 SIGNIFICANT).\r
+; 3. RETURNS NO USEFUL VALUE IN AC Z.\r
+; 4. CREATES A BASIS OF "NNN" VECTORS AT VRANT IN VRAN,\r
+; BASED ON THE WARMUP ARGUMENT W. (STANDARD VALUE\r
+; IS W=0.) RESETS VRAN'S OWN INDEX. USES VRAN LOCATIONS\r
+ ; VRANR ; VRAN OWN INDEX RESET VALUE.\r
+ ; VRANW ; VRAN'S WARMUP CONSTANT.\r
+ ; VRANT ; VRAN'S VECTOR-TABLE.\r
+ ; VRANN ; NEGATIVE TABLE LENGTH.\r
+; 5. FORTRAN AC ASSIGNMENTS ARE\r
+; N=00 ; FUNCTION-VALUE RETURN AC.\r
+; T=1 ; SCRATCH AC.\r
+; P=17 ; PUSHDOWN LIST\r
+; T1=2 ; INDEX AC.\r
+; A=3 ; INDEX AC.\r
+; 6. WRAN MAY BE USED FREELY TO REPEAT A PREVIOUSLY GENERATED\r
+; SEQUENCE (BY CALLING WRAN WITH THE PREVIOUSLY USED VALUE\r
+; FOR W), OR TO CAUSE THE GENERATION OF A COMPLETELY NEW\r
+; SEQUENCE (BY CALLING WRAN WITH A NEW VALUE FOR W).\r
+\r
+\r
+ ...=0 ; ELLIPSIS (FOR CONVENIENCE).\r
+>\r
+\r
+WRANB: XOR N,VRANW ; ADJUST,\r
+ TLZ N,(37B4) ; IGNORE BITS 00-04\r
+ JUMPE N,WRANB ; REJECT 0.\r
+ MOVSI T1,777771 ; ESTABLISH OUTER LOOP.\r
+WRAN2: MOVNI A,6 ;ESTABLISH INNER LOOP.\r
+WRAN3: MOVE T,N ; COPY ARGUMENT,\r
+ ROT T,13 ; POSITION BITS 05-10 FOR\r
+ XOR T,N ; MOD 2 SUM WITH BITS 30-35.\r
+ ROT T,-6 ; USE RESULT AS NEW\r
+ LSHC N,6 ; ARGUMENT BITS 30-35\r
+ AOJN A,WRAN3 ; SIX BYTES DONE? NO, BACK.\r
+ MOVEM N,VRANT(T1) ; YES, ARGUMENT IS BASIS VECTOR.\r
+ AOBJN T1,WRAN2 ; "NNN" VECTORS DONE? NO, BACK.\r
+ MOVE N,VRANR ; RESET VRAN OWN INDEX.\r
+ MOVEM N,VRANX ; (AFTER RESTORING AC'S!)\r
+ POPJ P, ; RETURN (OVER "ARG").\r
+\r
+;FRANB -- FLOATING-POINT PSEUDO-RANDOM GENERATOR.\r
+\r
+; PUSHJ P,FRANB\r
+;\r
+; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.\r
+; 3. RETURNS IN AC N A FLOATING-POINT NUMBER AS AN\r
+; INSTANCE OF A REAL RANDOM VARIABLE UNIFORMLY\r
+; DISTRIBUTED ON THE OPEN INTERVAL (0,1).\r
+; 4. REQUIRES THE VECTOR GENERATOR FUNCTION VRAN.\r
+;VRAN\r
+; 5. FORTRAN AC ASSIGNMENTS ARE\r
+RANB:\r
+FRAN1: PUSHJ P,VRANB ; GET RANDOM VECTOR,\r
+ LSH N,-9 ; SCALE TO MANTISSA,\r
+ JUMPE N,FRAN1 ; REJECT ZERO.\r
+ TLO N,(1B1) ; FORCE EXPONENT OF 2^0.\r
+ FAD N,[1B1] ; NORMALIZE.\r
+ POPJ P, ; RETURN (IGNORE "ARG").\r
+\fIFN FTRND, <\r
+;VRAN7B -- 36-BIT PSEUDO-RANDOM GENERATOR.\r
+\r
+;; NAME SHOULD ALWAYS BE\r
+;; "VRANXX", WHERE "XX" IS THE ASSEMBLED VALUE OF\r
+;; THE PARAMETER "NNN". (SEE 6. BELOW.) USE ONLY THE\r
+;; STATISTICALLY BEST "EEE" VALUE FOR EACH "NNN" VALUE.\r
+\r
+; PUSHJ S,VRANB\r
+;\r
+; 1. USES STANDARD BASIC "PUSHJ" CALLING SEQUENCE.\r
+; 3. RETURNS IN AC N A 36-BIT PSEUDO-RANDOM VECTOR.\r
+; VRANX ; AC STORAGE, OWN INDEX.\r
+; VRANR ; OWN INDEX RESET VALUE.\r
+; VRANW ; WARMUP CONSTANT.\r
+; VRANT ; VECTOR-TABLE.\r
+; VRANN ; NEGATIVE TABLE LENGTH.\r
+; 6. VRAN HAS THREE ASSEMBLY PARAMETERS:\r
+ RADIX 10\r
+ NNN=7 ; VECTOR-TABLE SIZE.\r
+ EEE=3 ; VECTOR-TABLE OFFSET.\r
+ RADIX 8\r
+ W=013702175435 ; VECTOR-TABLE GENERATOR.\r
+; WHICH ARE USED TO ESTABLISH AN INITIAL TABLE OF\r
+; "NNN" BASIS VECTORS <V[J] : 0 .LE. J .LT. NNN>, AND TO\r
+; GENERATE SUCCESSIVE VECTORS ACCORDING TO THE RULE:\r
+; V[NNN+J] = (V[0+J] + V[EEE+J]) MODULO (2^36) : 0 .LE. J.\r
+; (SEE RANPAK.TXT FOR ADMISSABLE VALUES FOR <NNN,EEE,W>,\r
+; AND A DISCUSSION OF THE ALGORITHM.)\r
+\r
+ VRANN=-NNN ; NEGATIVE TABLE LENGTH (FOR WRAN).\r
+>\r
+\r
+VRANB: MOVE T1,VRANX ; SET UP OWN INDEX.\r
+ MOVE N,VRANT+NNN(T1) ; ADDEND V[E+J] IF J .LT. N-E\r
+ TRNN T1,(1B0) ; [J.LT.N-E]=[RH(T1).LT.0]?\r
+ MOVE N,VRANT+0(T1) ; ADDEND V[E+J] IF J .GE. N-E.\r
+ ADDB N,VRANT+NNN-EEE(T1) ; AUGEND V[0+J] AND RESULT V[N+J].\r
+ AOBJN T1,VRAN1 ; SETP J; J.GT.N? NO,OVER.\r
+ MOVE T1,VRANR ; YES, RESET J.\r
+VRAN1: MOVEM T1,VRANX ; SAVE OWN INDEX\r
+ POPJ P, ;EXIT\r
+\r
+VRANR: XWD -<NNN+1>,-<NNN-EEE> ; OWN INDEX RESET VALUE\r
+\r
+VRANW: EXP W ;WARMUP CONSTANT (FOR WRAN).\r
+\r
+ LIT\r
+\r
+IFN PURESW,<\r
+ LOC 140\r
+>\r
+EX1: FSC N,0\r
+FRSTLN: BLOCK 1 ;141\r
+LASTLN: BLOCK 1 ;142\r
+LOWEST: BLOCK 1 ;143\r
+PREAD: BLOCK 2 ;144\r
+PINPUT: BLOCK 2 ;146\r
+DATLIN: BLOCK 2 ;150\r
+DATAFF: BLOCK 1 ;152\r
+HPOS: BLOCK 1 ;153\r
+REGPNT: BLOCK 1 ;154\r
+TMPLOW: BLOCK 1 ;155\r
+TMPPNT: BLOCK 1 ;156\r
+PSHPNT: BLOCK 1 ;157\r
+SEQPNT: BLOCK 1 ;160\r
+TOPSTG: BLOCK 1 ;161\r
+SVRBOT: BLOCK 1 ;162\r
+SVRTOP: BLOCK 1 ;163\r
+FMTPNT: BLOCK 1 ;164\r
+IFFLAG: BLOCK 1 ;165\r
+\r
+VARFRE: BLOCK 1 ;166\r
+FCNLNK: BLOCK 1 ;167\r
+ELETOP: BLOCK 1 ;170\r
+FUNAME: BLOCK 1 ;171\r
+LETSW: BLOCK 1 ;172\r
+MTIME: BLOCK 1 ;173\r
+ BLOCK 1 ;174\r
+FUNSTA: BLOCK 1 ;175\r
+FUNLOW: BLOCK 1 ;176\r
+LOWSTA: BLOCK 1 ;177\r
+SB1M1: BLOCK 1 ;200\r
+SB2M1: BLOCK 1 ;201\r
+TEMP1: BLOCK 1 ;202\r
+TEMP2: BLOCK 1 ;203\r
+TEMP3: BLOCK 1 ;204\r
+TYI: BLOCK 3 ;205\r
+TYO: BLOCK 3 ;210\r
+TTYBUF: BLOCK 3 ;213\r
+\r
+LINB0: BLOCK 20 ;216\r
+\r
+DRMBUF: BLOCK 2 ;236\r
+VECT1: BLOCK 100 ;240\r
+VECT2: BLOCK 100 ;340\r
+ BLOCK 1 ;440\r
+STRFCN: BLOCK 1 ;441\r
+TABVAL: BLOCK 1 ;442\r
+RUNFLA: BLOCK 1 ;443\r
+OLDFLA: BLOCK 1 ;444\r
+RENFLA: EXP -1 ;445\r
+CURDEV: BLOCK 1 ;446\r
+CURNAM: BLOCK 1 ;447\r
+CUREXT: BLOCK 1 ;450\r
+DETER: BLOCK 1 ;451\r
+NUMRES: BLOCK 1 ;452\r
+VRANX: BLOCK 1 ;453\r
+FILDIR: BLOCK 1 ;454\r
+ SIXBIT /BAS/ ;455\r
+ EXP 0,0 ;456\r
+ ;457\r
+EX: FSC N,0 ;SCALE THE RESULTS\r
+BADMSG: ASCII /MISSING LINE NUMBER FOLLOWING LINE /\r
+BADGNN: EXP 60,0\r
+CRLFMS: ASCIZ /\r
+/\r
+UUOH: 0 ;473\r
+ JRST UUOHAN\r
+\r
+ NNN=7\r
+ W=13702175435\r
+ INTERNAL VRANT\r
+\r
+DEFINE .WRAN(NN,WW) < ; ASSEMBLES "WRAN(0)" BASIS.\r
+ DEFINE .WRAN1 <\r
+ REPEAT 6, <\r
+ %Q=<%A>B<35+25>\r
+ %Q=<%A ! %Q> & <-1-<%A & %Q>>\r
+ %A=<%A>B<35-6> ! <%Q & 77> >\r
+ EXP %A >\r
+ %A=WW\r
+ REPEAT NN, <\r
+ .WRAN1 >>\r
+\r
+VRANT: .WRAN(NNN,W)\r
+SPEC: EXP 1\r
+NEWOL1: SIXBIT /DSK/\r
+ EXP TYI\r
+WEAVI: OCT 1\r
+WEAV: SIXBIT /DSK/\r
+ EXP TYI\r
+SAVI: OCT 1\r
+SAVEX: SIXBIT /DSK/\r
+ XWD TYO,\r
+\fDEFINE ROLLS <\r
+X TXT\r
+X LIN\r
+\r
+X COD\r
+X CON\r
+X LIT\r
+X ARA\r
+X SVR\r
+X GSB\r
+X SCA\r
+X VSP\r
+X PTM\r
+X TMP\r
+\r
+X STM\r
+X VAR\r
+X SEX\r
+X ARG\r
+X REF\r
+X FCN\r
+X FCL\r
+X FAD\r
+X CAD\r
+X LAD\r
+X SAD\r
+X FOR\r
+X NXT\r
+>\r
+ PSHROL=200000 ;ADDRESS ASSOCIATED WITH THIS\r
+ ;PHANTOM ROLL ARE ABSOLUTE, INDEXED BY (P)\r
+\r
+\fDEFINE TBLS <\r
+X CMD\r
+X STA\r
+X DEC\r
+X REL\r
+X IFN\r
+>\r
+ZZ.=0\r
+DEFINE X(A)\r
+<A'ROL=ZZ.\r
+ZZ.=ZZ.+1\r
+>\r
+ TBLS\r
+ROLLS\r
+ROLTOP=ZZ.-1\r
+\r
+\fFLOOR:\r
+DEFINE X(A)\r
+<EXP A'FLO>\r
+TBLS\r
+\r
+DEFINE X(A)\r
+<Z>\r
+\r
+ ROLLS\r
+CEIL:\r
+DEFINE X(A)\r
+<EXP A'CEI>\r
+TBLS\r
+\r
+DEFINE X(A)\r
+<Z>\r
+\r
+ ROLLS\r
+\r
+COMBOT=VARROL ;BOTTOM COMPILE ROLL AFTER CODROL\r
+COMTOP=NXTROL ;TOP COMPILE ROLL.\r
+ONCESW: EXP -1 ;ONCE-ONLY SWITCH FOR START\r
+ ;AFTERWARDS, THE CONSTANT ZERO.\r
+\r
+PAKFLA: BLOCK 1 ;612 ;-1 IF TEXT IS NOT PACKED\r
+VPAKFL: BLOCK 1 ;613 ;-1 IF VARIABLE SPACE PACKED.\r
+INPFLA: BLOCK 1 ;614 ;NON-ZERO DURING INPUT,ZERO DURING READ\r
+IFIFG: BLOCK 1 ;615\r
+PIVOT: ES2: C3: BLOCK 1 ;616\r
+SX: BLOCK 1 ;617\r
+PLIST: XWD -100,.\r
+ BLOCK 100\r
+\r
+EXTERN JOBSA,JOBREL,JOBFF,JOBREN,JOBOPC,JOBAPR,JOBTPC\r
+\r
+MINFLG=400000 ;MINUS FLAG IN LEFT HALF OF EXPR PNTR\r
+ROLMSK=377777 ;ROLL NUMBER MASK IN SAME\r
+\r
+SUBTTL LITERALS\r
+ DEFINE IMP(A)\r
+< CE'A=CEIL+A'ROL\r
+ FL'A=FLOOR+A'ROL\r
+ INTERN CE'A,FL'A >\r
+ IMP SVR\r
+ IMP LIT\r
+ IMP SCA\r
+ IMP ARA\r
+ IMP STM\r
+ IMP PTM\r
+ IMP LAD\r
+ IMP GSB\r
+ IMP FOR\r
+ IMP FCL\r
+ IMP CAD\r
+ IMP ARG\r
+ IMP REF\r
+ IMP COD\r
+ IMP SEX\r
+ IMP SAD\r
+ IMP NXT\r
+ IMP LIN\r
+ IMP CON\r
+ IMP VSP\r
+ IMP TXT\r
+ IMP TMP\r
+\r
+ END BASIC\r
git://git.sky-visions.com / retro-software/dec/tops10/v4.5.git / commitdiff