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