Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50516/basxct.mac
There are no other files named basxct.mac in the archive.
;****** UOFP SEGMENTED BASIC ******
SEARCH S
IFNDEF NOCODE,<NOCODE==0> ;NOCODE=1 : JUST DEFINE SYMBOLS
IFNDEF BASTEK,<BASTEK==0> ;DO NOT INCLUDE TEK PLOTTING PACKAGE
IFNDEF BASDDT,<BASDDT==0> ;BASDDT=1 FOR DDT
IFE NOCODE,<
IFE BASDDT,<TITLE BASXCT EXECUTE PHASE
>
IFN BASDDT,<TITLE BSXCT1 EXECUTE PHASE
>
>
IFN NOCODE,<
UNIVERSAL BSYXCT
>
;****** END UOFP SEGMENTED BASIC ******
SUBTTL PARAMETERS AND TABLES
;***COPYRIGHT 1969,1970,1971,1972,1973,1974 DIGITAL EQUIPMENT CORP., MAYNARD, MASS.***
;VERSION 17E 2-OCT-74/NA
;VERSION 17D 4-MAY-73/KK
;VERSION 17C 2-JAN-73/KK
;VERSION 17B 25-JUL-72/KK
;VERSION 17A 10-FEB-1972/KK
;VERSION 17 15-OCT-1971/KK
;VERSION 16 5-APR-1971/KK
;VERSION 15 17-AUG-1970/KK
;VERSION 14 16-JUL-1970/AL/KK
;VERSION 13 15-SEP-1969
LOC .JBINT
TRPLOC
LOC .JBVER
BYTE (3)VWHO(9)VBASIC(6)VMINOR(18)VEDIT
LOC .JB41
JSR UUOH
;****** UOFP SEGMENTED BASIC ******
IFE NOCODE,<
RELOC
HISEG
>
IFN NOCODE,<LOC 400010>
;****** END UOFP SEGMENTED BASIC ******
INTERN ERRCNT,LINADR,ERRB,ERLB
INTERN EOF31,EOF32,CRLF3,CLSRAN,PRTNUM
INTERN CHAER1,ERRXCY,ERRXCX
INTERN ATANB,CHRB,CLOGB,COSB,COTB,EXPB,INSTRB,INTB
INTERN LEFTB,LENB,LOGB,MIDB,RIGHTB,RNDB,SGNB,SINB,SLEEPB,SPACEB
INTERN SQRTB,STRB,TANB,VALB,PCRLF
INTERN TIMEB,DATEB,DAYB,ECHOB,FIXB,LINEB,PIB,POSB,ASCIIB
INTERN APPEND,CHAERR,CHAHAN,CHKIMG,CLSFIL,CNER1,CRLF
INTERN DOINPT,DOREAD,EIFLOT,ENDIMG,EOF,EUXIT,EXP3.0,FNMX0
INTERN EXP1.0,EXP2.0
INTERN FNMXER,FRETRN,GOSBER,IFIX,IMGLIN,INSEQ,INSET,MARERR,MARGAL,MARGN
INTERN MASTST,OPNFIL,OUTSET,PAGE,PAGEAL,PRDLER,RANDER,RANSCR
INTERN REINER,RESTON,RETURN,RNNUMO,RNSTRO,SAVACS,SCATH
INTERN SCNIMN,SCNIMS,SETCOR,SETERR,SEVEN,WRPRER,XCTON,XRES
INTERN UUOHAN
INTERN FIXPNT,FLTPNT
XLIST
IFN BASTEK,<
LIST
INTERN INIPLT,PAGPLT,LINPLT,ORGPLT,STRPLT,MOVPLT,WHRPLT
INTERN CURPLT,SAVPLT
XLIST
>
LIST
EXTERN ACTBL,APBMAX,APPMAX,ARAROL,BA,BGNTIM,BLOCK,C3,CECOD,CEIL,CESVR
EXTERN CEVSP,CHAFL2,CHAFLG,CLOSED,COMTIM,CORINC,CRTVAL,DATAFF
EXTERN DATLIN,DECROL,DETER,DREL,ELETOP,ENT,ENTDSK,EOFFLG
EXTERN ELECT1,ELECT2,ELECT3,ERR,ERL,ERRGO,ERRTRO
EXTERN TYPE,PFLAG,FTYPE,INLNFG
EXTERN ES2,EX1,EXTD,EXTFG,FCNLNK,FILD,FILDIR,FILFLG,FPPN
EXTERN FILTYP,FIRSFL,FLCOD,FLLIN,FLVIR,FLOAT,FLOOR,FLSVR
EXTERN FLVSP,FMTPNT,FUNAME,GTSTS,HPOS,IBDSK,IBDSK2
EXTERN IFIFG,IFNFLG,INITO,INNDSK,INPFLA,INPRES,INVFLG,INVLRG
EXTERN LASREC,LEAD,LIBFLG,LINB0,LINNUM,LINROL,LOK
EXTERN LOKUP,LZ,MARGIN,MARWAI,MASAPP,MASMAX,MIDSAV,MODBLK,MTIME
EXTERN NEWOL1,NOTLIN,NUMCOT,NUMRES,NXTROL,OBDSK,OBDSK2,OBF,ODF
EXTERN OUCH,OUTDSK,OUTERR,OUTTDS,PAGCNT,PAGLIM,PINPNM
EXTERN PINPUT,PIVOT,PLIST,POINT,PREAD,PROTEC,PSAV,QUERYF,QLIST
EXTERN QSKIP,QUOFL1,QUOFLG,QUOTBL,RANCNT,RANTST,REAINP
EXTERN REATMP,RENAMD,RNDDAT,RNDIDX,RUNFLA,RUNLIN
EXTERN SAVE1,SB1M1,SB2M1,SCAROL,SORCLN,SRTDBA,STODSK
EXTERN STRCTR,STRFCN,STRLEN,STRPTR,SVRBOT,SVRROL,SVRTOP,SX
EXTERN TABVAL,TEMLOC,TEMP1,TEMP2,TEMP3,TRAIL,TRPLOC
EXTERN USETID,USETOD,UUOH,UXFLAG,VALPTR,VARFRE,VARROL
EXTERN VECT1,VECT2,VPAKFL,VRFBOT,VRFBTB,VRFTOP,VSPROL
EXTERN VIRSIZ,VIRWRD
EXTERN WRIPRI,ZONFLG
EXTERN .JBFF,.JBREL,.JBTPC
;****** EXTERNALS FROM BASLIB (XCTLIB)
EXTERN BASORT,CPOPJ,CPOPJ1,CTTAB,D1E14,D1EM18,D1EM4
EXTERN DATCHK,DATTBL,DECCEI,DECFLO,DECTAB,DPBSTR
EXTERN EOFFL,ERRMS3,EVANUM,FILNAM,FILNMO
EXTERN FIXCON,GOSR2,GOSR3,INLINE,INLMES
EXTERN LINPT,LOCKOF,LOCKON,NOGETD,NXCH,NXCHD,NXCHD2,NXCHS
EXTERN OUCH,OUTCNT,OUTPT,PRNNAM,PRNSIX,PTXER1,QSA
EXTERN SEARCH,SKIPDA,TTYIN,UXIT6,UXIT7,VPANIC,VSUB1
;****** END EXTERNALS FROM BASLIB (XCTLIB)
IFN BASDDT,<
EXTERN DDTGO
>
EXTERN .USREL,RUNDDT,NOLINE
INTERN CHAXIT,EXECUT,OVTRAP,HSGVER,REUXIT,UXIT
BASIC=UXIT
RUNNH=UXIT
EUXIT=UXIT
EIFLOT=IFLOAT
EXTERN LUXIT1,ERRBPT,ERRTCN,ERRTBL,ERRTXT
UXIT1=LUXIT1
IFN NOCODE,<
IF2,< END>
>
ERRNUM=0
DEFINE INLBSY(A,B),<
IFN NOCODE,<
ERRNUM=ERRNUM+1
DEFINE ERM'A
<EMS'A: ASCIZ B>
>
>
;C=PDP-11 TYPE ERROR # CORRESPONDING TO PDP-10 ERROR # A.
DEFINE INLERR(C,A,B)
< BYTE (9) 1,0,^D'C,^D'A
IFN NOCODE,<XLIST
ERRNUM=ERRNUM+1
DEFINE ERM'A
<EMS'A: ASCIZ B>
LIST>
>
DEFINE INLEMS(C,A,B)
< BYTE (9) 1,0,^D'C,^D'A>
DEFINE NFERR(C,A)
< BYTE (9) 1,0,^D'C,^D'A>
DEFINE ERROM(A,B)
<IFN NOCODE,<XLIST
ERRNUM=ERRNUM+1
DEFINE ERM'A
<EMS'A: ASCIZ B>
LIST>
>
%OPD=1 ;OPDEF UUO COUNTER
DEFINE OPCNT (A)<
%OPD=%OPD+1
IFG %OPD-37,<PRINTX <TOO MANY UUO'S>>
OPDEF A [<%OPD>B8]>
OPCNT PRNM
OPCNT PRDL
OPCNT PRNTB
OPCNT GOSUB
OPCNT ARFET1
OPCNT ARFET2
OPCNT ARSTO1
OPCNT ARSTO2
OPCNT ARSTN1
OPCNT ARSTN2
OPCNT DATA
OPCNT ADATA1
OPCNT ADATA2
OPCNT SDIM
OPCNT MATRD
OPCNT MATPR
OPCNT MATSCA
OPCNT MATCON
OPCNT MATIDN
OPCNT MATTRN
OPCNT MATINV
OPCNT MATADD
OPCNT MATSUB
OPCNT MATMPY
OPCNT MATZER
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]
IFL MAXUUO-37,<
CAILE X1,MAXUUO
HALT ;ILLEGAL UUO.
>
UUOTBL:
JRST .(X1)
JRST ERRXCT
JRST PRNMER
JRST PRDLER
JRST PRNTBR
JRST GOSBER
JRST AFT1ER
JRST AFT2ER
JRST AST1ER
JRST AST2ER
JRST ASN1ER
JRST ASN2ER
JRST DSKRT
JRST ADT1ER
JRST ADT2ER
JRST SDIMER
JRST MTRDER
JRST MTPRER
JRST MTSCER
JRST MTCNER
JRST MTIDER
JRST MTTNER
JRST MTIVER
JRST MTADER
JRST MTSBER
JRST MTMYER
JRST MTZRER
JRST SUUOEX
JRST SAD1ER
JRST PRSTRR
JRST FORCOM
JRST MATIN
HSGVER: SIXBIT /BASX13/ ;[3] SEGMENT VERSION
DSKRT: LDB X1,[POINT 4,40,12]
CLEARM FTYPE ;ASSUME REAL
TRZE X1,10 ;IS IT INTEGER?
SETOM FTYPE ;YES, MARK IT
DPB X1,[POINT 4,40,12]
JRST .+1(X1)
JRST DATAER ;DATA 0, UUO.
JRST RANUM ;DATA 1, -- R.A.
JRST RANUM1 ;DATA 2, -- R.A.
JRST RANUM2 ;DATA 3, -- R.A.
JRST RANSTR ;DATA 4, -- R.A.
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 PUTSTR
JRST COMSTR
JRST INSTR
JRST GETVEC
JRST PUTVEC
JRST STRCHA
JRST GETVEC ;INTEGER FETCH
JRST PUTVEC ;INTEGER STORE
MASUUO=.-UUOSTR-1
OPDEF STRSTO [STRUUO 1,]
OPDEF STRIF [STRUUO 2,]
OPDEF STRIN [STRUUO 3,]
OPDEF VECFET [STRUUO 4,]
OPDEF VECPUT [STRUUO 5,]
OPDEF STOCHA [STRUUO 6,]
INLBSY(57,</
? No such device />)
INLBSY(58,</
? Quota exceeded or block no. too large on output device/>)
INLBSY(59,</
? Device is write locked/>)
INLBSY(69,</
? Input line too long/>)
REUXIT: SETZM MTIME
UXIT: SETZM CHAFL2
SETZM CHAFLG
CHAXIT: SETZM FUNAME
JRST XXXXXX##
SUBTTL BEGIN EXECUTION
;BEGIN EXECUTION
ENTRY DDTNH
DDTNH:
IFN BASDDT,<
JRST DDTGO
>
IFE BASDDT,<
JFCL
>
EXECUT: SETOM FCNLNK ;INITIALIZE FCN CALLS
SETOM PFLAG ;ASSUME AMBIGUOUS CONSTANTS ARE INTEGER
SETZM ERR ;CLEAR ERR FLAG
SETOM NOLINE ;DO NOT PRINT LINE # ON ERROR YET
CLEARM CRTVAL ;DEFAULT CRT VAL = 0, 10-13 ILLEGAL
SETZM ERRGO ;CLEARM ERROR RETURN
SETZM ERL ;CLEAR ERR LINE
MOVEM P,PSAV ;SAVE CURRENT PUSHDOWN POINTER
MOVE X1,.JBREL ;GET HIGH MARK
SKIPN RUNDDT ;DOING BASDDT?
MOVEM X1,.USREL ;NO, SET AS USER HIGH MARK
MOVEI X1,DECFLO ;
MOVEI T,DECROL
MOVEM X1,FLOOR(T)
MOVEI X1,DECCEI
MOVEM X1,CEIL(T)
PUSHJ P,RESTOR ;SET TO START AT BEGINNING OF DATA
SETZB R,COMTIM ;POINTER TO GOSUB RTRN
AOS COMTIM
PUSHJ P,INLMES ;RETURNS SIGNAL END OF COMPILATION.
ASCIZ /
/
OUTPUT
;INITIALIZE SOME SWITCHES:
SETZM INPFLA ;NO INPUT CURRENTLY BEING READ
SETZM FILFLG
HRRZ X1,VARFRE ;SET UP FILES.
MOVEM X1,.JBFF
MOVEI X1,9
EXLAB1: SETZM PROTEC-1(X1)
SOJG X1,EXLAB1
MOVEI X1,9
EXEC6: SKIPN A,ACTBL-1(X1)
JRST EXEC11 ;NO FILE ON THIS CHANNEL.
EXEC0: HRRZ T1,.JBFF
HRLM T1,BA-1(X1)
SETZM @FILMOD-1(X1) ;MODE IS ASCII FOR SEQ.
JUMPG A,EXEC7 ;FILES AND STRING R.A. FILES,
MOVEI T1,34 ;BINARY FOR NUMERIC R.A. FILES.
SKIPL STRLEN-1(X1) ;SET USER WORD COUNT FOR R.A. FILES.
MOVEI T1,20
MOVEM T1,@FILMOD-1(X1)
EXEC7: XCT INITO-1(X1)
JRST [MOVE T,OPS1+1
JRST NOGETD]
DPB X1,[POINT 4,LOKUP,12]
MOVE N,FILD-1(X1)
MOVEM N,LOK
MOVE N,FPPN-1(X1)
MOVEM N,LOK+3
MOVE N,EXTD-1(X1)
MOVEM N,LOK+1
SETZM LOK+2
PUSH P,N ;CHECK FOR CORE BEFORE INBUFS.
HRRZ N,.JBFF
ADDI N,406
CAMG N,.USREL
JRST EXEC71 ;OKAY
MOVEI N,2000
MOVEM N,CORINC
ADD N,.JBREL
CORE N,
JRST [SETZM ACTBL-1(X1)
INLEMS(60,60,PANIC1)
JRST GOSR2] ;ABORT
IFE BASDDT,<
PUSHJ P,NPANIC
>
IFN BASDDT,<
PUSHJ P,DPANIC##
>
EXEC71: POP P,N
JUMPL A,EXEC8 ;SEQ. OR R.A.?
DPB X1,[POINT 4,IBDSK2,12] ;SEQ.
XCT IBDSK2
SETZM PROTEC-1(X1)
XCT LOKUP
JRST [HRRZ T1,LOK+1
TRZ T1,777770
JUMPN T1,LOOKFL
MOVEI T1,2
JRST EXLAB2]
MOVEI T1,1
EXLAB2: MOVEM T1,ACTBL-1(X1) ;SET UP ACTBL.
CAIE T1,1
JRST EXEC72
HLLZ T1,LOK+2 ;SAVE < >.
TLZ T1,777
MOVEM T1,PROTEC-1(X1)
EXEC72: HRRZ T1,.JBFF
HRRM T1,BA-1(X1) ;SET UP BA.
JRST EXEC12
EXEC8: DPB X1,[POINT 4,IBDSK,12] ;RANDOM ACCESS.
XCT IBDSK
HLLZM N,ENT+1
MOVE N,FILD-1(X1)
MOVEM N,ENT
DPB X1,[POINT 4,OBDSK,12]
XCT OBDSK
DPB X1,[POINT 4,ENTDSK,12]
SETZM ENT+2
MOVE T1,FPPN-1(X1)
MOVEM T1,ENT+3
SETZM PROTEC-1(X1)
XCT LOKUP ;DOES FILE EXIST NOW.
JRST [MOVE T1,.JBFF
HRRZ A,LOK+1
JUMPN A,LOOKFL
JRST EXEC9]
HLLZ T1,LOK+2
TLZ T1,777
MOVEM T1,PROTEC-1(X1)
MOVEM T1,ENT+2
MOVE T1,.JBFF
XCT ENTDSK ;YES.
JRST ENFFAL
DPB X1,[POINT 4,OUTTDS,12] ;SET UP BUFFER.
XCT OUTTDS
JRST EXLAB3
JRST EXEC86
EXLAB3: DPB X1,[POINT 4,INNDSK,12] ;SET UP BUFFER.
XCT INNDSK
JRST EXEC81
EXEC89: DPB X1,[POINT 4,STODSK,12]
XCT STODSK
JRST EXEC91 ;NULL FILE--SAME AS NON-EXISTENT.
EXEC86: SETZM ACTBL-1(LP)
INLEMS(1,70,INLSYS) ;SYSTEM ERROR
JRST GOSR2
EXEC81: MOVE T1,-403(T1) ;GET FIRST WORD.
TLNN T1,377777
JRST EXEC83
EXEC82: PUSH P,.JBFF
PUSH P,[Z EXNAME]
EXNAM: PUSH P,X1
INLERR(10,61,</
? File />)
POP P,X1
EXNAM2: MOVE T,FILD-1(X1)
MOVEM T,FILDIR
MOVE T,EXTD-1(X1)
MOVEM T,FILDIR+1
MOVE T,FPPN-1(X1)
MOVEM T,FILDIR+3
SETZM SAVE1
PUSHJ P,ERRXCX
JRST PRNNAM
EXNAME: PUSHJ P,ERRXCY
PUSH P,X1
INLERR(10,62,</ is not random access />)
POP P,X1
EXNAM1: SKIPE NOLINE ;SHOULD WE PRINT LINE #
JRST EXNAM3 ;YES, DON'T OUTPUT LINE NUMBER
PUSH P,X1
INLERR (34,66,</ in line />)
POP P,X1
MOVE T,BLOCK-1(X1)
PUSHJ P,ERRXCX
PUSHJ P,PRTNUM
EXNAM3: SETZM ACTBL-1(X1)
SKIPE CHAFL2
PUSHJ P,ERRMS3
OUTPUT
POP P,.JBFF
PUSHJ P,ERRXCY
SKIPE FILFLG
JRST UXIT
SETZM RUNFLA
JRST EXEC12
EXEC83: HRRZM T1,LASREC-1(X1)
MOVE T1,.JBFF
SKIPGE A,STRLEN-1(X1) ;NUMERIC OR STRING.
JRST EXEC85 ;NUMERIC.
MOVE T1,-402(T1) ;STRING.
CAMGE T1,[000001000000]
JRST EXEC82
JUMPN A,EXEC84
MOVEM T1,STRLEN-1(X1)
HRRZI T1,(T1)
CAIG T1,^D132
CAIGE T1,1
JRST EXEC82
JRST EXEC10
EXEC84: CAME A,T1
JRST EXLAB4
MOVEM A,STRLEN-1(X1)
JRST EXEC10
EXLAB4: PUSH P,.JBFF
PUSHJ P,EXNAM
PUSH P,X1
INLERR(10,63,</ record length or type does not match />)
POP P,X1
JRST EXNAM1
EXEC85: SKIPE -402(T1)
JRST EXEC82
SETOM STRLEN-1(X1)
JRST EXEC10
EXEC9: XCT ENTDSK ;NON-EXISTENT FILE.
JRST ENFFAL
DPB X1,[POINT 4,OUTTDS,12] ;SET UP BUFFER.
XCT OUTTDS
JRST EXEC91
JRST EXEC86
EXEC91: SETZM LASREC-1(X1)
MOVE A,.JBFF ;CLEAR OUTPUT BUFFER.
SUBI A,200
EXLAB5: SETZM -1(T1)
SOJ T1,
CAIE T1,(A)
JRST EXLAB5
SKIPL A,STRLEN-1(X1) ;NUMERIC OR STRING?
JRST EXEC92 ;STRING.
HRLZI A,400000 ;NUMERIC.
MOVEM A,(T1)
JRST EXEC93
EXEC92: JUMPN A,EXLAB6
MOVE A,[XWD ^D8,^D34]
EXLAB6: MOVEM A,1(T1)
MOVEM A,STRLEN-1(X1)
EXEC93: MOVEI A,200 ;SET THE WORD COUNT.
HRRM A,-1(T1)
DPB X1,[POINT 4,OUTTDS,12]
XCT OUTTDS
JRST EXEC94 ;OUTPUT THE HEADER RECORD.
DPB X1,[POINT 4,GTSTS,12]
XCT GTSTS
JRST [SETZM ACTBL-1(X1)
JRST OUTERR]
EXEC94: DPB X1,[POINT 4,CLOSED,12]
XCT CLOSED
HLLZS LOK+1
SETZM LOK+2
MOVE T1,FPPN-1(X1)
MOVEM T1,LOK+3
XCT LOKUP
JRST [HRRZ T1,LOK+1
TRZ T1,777770
JRST LOOKFL]
HLLZS ENT+1
SETZM ENT+2
LDB T1,[POINT 9,PROTEC-1(X1),8]
DPB T1,[POINT 9,ENT+2,8]
MOVE T1,FPPN-1(X1)
MOVEM T1,ENT+3
XCT ENTDSK
JRST ENFFAL
HLRZ T1,BA-1(X1)
MOVEM T1,.JBFF
DPB X1,[POINT 4,IBDSK,12]
DPB X1,[POINT 4,OBDSK,12]
XCT IBDSK
XCT OBDSK
DPB X1,[POINT 4,OUTTDS,12]
DPB X1,[POINT 4,INNDSK,12]
XCT OUTTDS
JRST EXLAB7
JRST EXEC86
EXLAB7: XCT INNDSK
JRST EXEC10
JRST EXEC86
EXEC10: HRRZ T1,.JBFF
HRRM T1,BA-1(X1)
JRST EXEC12
EXEC11: SETZM BA-1(X1)
EXEC12: SKIPGE FILFLG ;DON'T LOOP--IF ONCE
JRST OPNFL4 ;ONLY FILE STATEMENT.
SOJG X1,EXEC6 ;GO BACK TO LOOP.
MOVE X1,.JBFF
MOVEM X1,VARFRE
JRST EXEC1
LOOKFL: PUSH P,.JBFF
PUSH P,X1
INLERR(5,64,</
? Cannot lookup file />)
POP P,X1
JRST ENTLOK
ENFFAL: PUSH P,.JBFF
PUSH P,X1
INLERR(4,65,</
? Cannot enter file />)
POP P,X1
ENTLOK: PUSHJ P,EXNAM2
PUSHJ P,ERRXCY
JRST EXNAM1
EXEC1: PUSHJ P,BASORT ;SORT THE TABLE BA INTO SRTDBA.
MOVEI X1,^D9
EXEC2: SETZM PINPNM-1(X1)
SETZM WRIPRI-1(X1)
SETZM REAINP-1(X1)
SETZM BLOCK-1(X1)
SETZM MODBLK-1(X1)
SETZM POINT-1(X1)
AOS POINT-1(X1)
SETZM EOFFLG-1(X1)
SOJG X1,EXEC2
MOVEI N,^D72
MOVEI X1,^D9
EXEC3: SETZM HPOS(X1)
SETOM FIRSFL(X1)
SETZM TABVAL(X1)
SETZM FMTPNT(X1)
SETZM MARWAI(X1)
SETOM PAGLIM(X1)
SETZM QUOTBL(X1)
SETOM ZONFLG(X1)
MOVEM N,MARGIN(X1)
SOJGE X1,EXEC3
SKIPE RUNFLA ;SKIP IF AN ERROR HAS OCCURRED
SETOM UXFLAG
SETOM NUMRES ;NO MAT INPUT HAS OCCURRED YET
SETZ N, ;ARG FOR RANDOM NUMBER SET UP.
PUSHJ P,RANDOM ;INITIALIZE THE "STANDARD" RANDOM NUMBERS.
MOVEI X1,630010
APRENB X1,
PUSHJ P,LOCKOF ;EXECUTION MAY BE INTERRUPTED.
SETZM IFIFG
SETZM ODF
MOVEI Q,MASAPP
MOVEM Q,MASAPP
MOVE Q,QLIST
SETZM INVFLG
SETZM VRFBOT
SKIPN RUNDDT
SKIPE RUNFLA ;IF ANY ERRORS
CAIA ;UNLESS UNDER BASDDT
JRST UXIT ;EXIT
SETZ X1, ;SET THE CORE INCREMENT AS A FUNCTION
MOVE A,FLSVR ;OF THE NUMBER OF STRING VARIABLES IN
EXEC31: CAML A,CESVR ;THE PROGRAM.
JRST EXEC33
HLRZ X2,(A)
ADDI X1,(X2) ;ADD IN THE ARRAYS.
ADDI A,3
JRST EXEC31
EXEC33: HRRZ X2,CEVSP
SUB X2,FLVSP
ADDI X1,(X2) ;ADD IN THE SCALARS.
MOVEI A,2000
CAIG X1,^D200
JRST EXEC35
MOVEI A,4000
CAILE X1,^D500
MOVEI A,6000
EXEC35: MOVEM A,CORINC
SKIPE CHAFLG ;CHAINING?
JRST EXEC4 ;YES. DON'T DISTURB TIME.
SETZ A,
RUNTIM A,
MOVEM A,BGNTIM
EXEC4: SETZM NOLINE ;NOW PRINT LINE #S ON ERRORS
SKIPGE A,RUNLIN ;BEGIN EXECUTION---
JRST @FLCOD ;AT THE BEGINNING.
JRST (A) ;AT A LINE NUMBER.
XFIL30: ADDI B,-60(C)
PUSHJ P,NXCH
TLNN C,F.DIG
POPJ P,
IMULI B,^D10
JRST XFIL30
SUBTTL RUNTIME ROUTINES
;RUNTIME ROUTINE TO CLOSE FILES FOR FILE STATEMENTS.
CLSFIL: SKIPN FILD-1(LP) ;IS FILE ESTABLISHED?
JRST FNR ;NO, THEN CAN'T CLOSE
IFN BASTEK,<
CAMN LP,PLTOUT ;
CLEARM PLTOUT ;
CAMN LP,PLTIN ;
CLEARM PLTIN
>
SKIPG X2,ACTBL-1(LP) ;SEQ. OR R.A.?
JRST CLSRAN
CAIE X2,3 ;SEQ.
JRST CLSSE1
SETOM ODF
SKIPE HPOS(LP)
PUSHJ P,CRLF3 ;END CURRENT LINE.
CLSSE1: DPB LP,[POINT 4,DREL,12]
XCT DREL
MOVEI X1,3
CAME X1,ACTBL-1(LP)
POPJ P,
MOVEI X1,(LP) ;FILE IS IN WRITE MODE,
PUSHJ P,UXIT6 ;SO SET UP PROTECTION CODE.
XCT DREL
POPJ P,
CLSRAN: MOVE X2,BLOCK-1(LP) ;R.A.
SKIPE MODBLK-1(LP)
PUSHJ P,OUTRAN
MOVEI X2,1
PUSHJ P,INRAN
HLRZ X2,BA-1(LP)
HRRZ X1,3(X2)
CAMN X1,LASREC-1(LP) ;NEED TO UPDATE LAST REC. NO.?
JRST CLSRN1
MOVE X1,LASREC-1(LP) ;YES.
HRRM X1,3(X2)
MOVEI X2,1
PUSHJ P,OUTRAN
CLSRN1: PUSH P,B ;LAST BLOCK NEEDS COUNT NE 200?
PUSH P,T
PUSH P,T1
MOVE T,LASREC-1(LP)
SKIPG STRLEN-1(LP)
JRST CLSRN2
HLRZ B,STRLEN-1(LP) ;STR FILE.
MOVEI X1,^D128
IDIVI X1,(B)
IDIVI T,(X1)
MOVEI T1,1(T1)
IMULI T1,(B)
JRST CLSR22
CLSRN2: MOVEI T,1(T) ;NUM. FILE.
IDIVI T,^D128
MOVEI T1,1(T1)
CLSR22: MOVEI X2,1(T)
PUSHJ P,INRAN
HLRZ X1,BA-1(LP)
HRRZ T,2(X1)
CAIN T,(T1)
JRST CLSRN3 ;NO, NEEDS 200, WHICH IT ALREADY HAS.
HRRM X2,USETOD-1(LP) ;YES, NEEDS NE 200 COUNT.
XCT USETOD-1(LP)
HRLI X2,3(X1)
MOVEI X1,206(X1)
HRRI X2,(X1)
BLT X2,177(X1)
HRRM T1,-1(X1) ;SET THE COUNT.
DPB LP,[POINT 4, OUTTDS,12]
XCT OUTTDS
JRST CLSRN3
DPB LP,[POINT 4, GTSTS,12]
XCT GTSTS
JRST [SETZM ACTBL-1(LP)
JRST OUTERR]
CLSRN3: POP P,T1
POP P,T
POP P,B
MOVEI X2,3
MOVEM X2,ACTBL-1(LP)
JRST CLSSE1
;RUNTIME ROUTINE TO OPEN FILES FOR THE FILE STATEMENT.
OPNFIL: PUSHJ P,STRPL1 ;GET STR + 1 SPACE.
JRST CHAER1
SOS MASAPP
PUSHJ P,FILNMO ;GET FILENM.EXT.
JUMP SAVE1
PUSH P,T
PUSH P,C
SETZM FILD-1(LP) ;CHECK FOR DUPLICATE NAME.
MOVEI D,9
MOVE X1,FILDIR
OPNL1: MOVE X2,FILDIR+1
OPNL2: CAMN X1,FILD-1(D)
CAME X2,EXTD-1(D)
JRST OPNL3
MOVE X2,FILDIR+3
CAMN X2,FPPN-1(D)
JRST OPNER2
SOJG D,OPNL1
SKIPA X2,FILDIR+1
OPNL3: SOJG D,OPNL2
OPNFL1: MOVEM X1,FILD-1(LP)
MOVEM X2,EXTD-1(LP)
MOVE X2,FILDIR+3
MOVEM X2,FPPN-1(LP)
HLRZ T,BA-1(LP) ;GET BUFFERS.
JUMPN T,OPNFL2
PUSHJ P,VCHBUF
HRLM T,BA-1(LP)
ADDI T,406
HRRM T,BA-1(LP)
PUSHJ P,BASORT
HLRZ T,BA-1(LP)
OPNFL2: MOVEM T,.JBFF
POP P,C
POP P,T
MOVE N,VALPTR
CAME N,T ;SEQ. OR R.A.?
JRST OPNFL6 ;R.A. OR ERROR.
SKIPLE FILTYP ;VIRTUAL OPEN?
JRST OPNF20 ;YES.
SKIPE FILTYP ;SEQ.
JRST FNMX1
MOVEI A,1
OPNFL3: MOVEM A,ACTBL-1(LP) ;SET UP FOR EXEC.
HRRZ X1,SORCLN
SKIPN NOTLIN
HRRZ X1,0(X1) ;SORCLN NOW POINTS TO LINE #.
MOVEM X1,BLOCK-1(LP)
MOVEI X1,(LP)
SETOM FILFLG
JRST EXEC0
OPNFL4: POP P,Q ;RETURN HERE FROM EXEC.
MOVEI X2,OPLAB1
JRST RESACS ;RESTORE THE AC'S.
OPLAB1: SKIPL ACTBL-1(LP) ;CLEAR AND SET UP FLAGS.
JRST OPNFL5
SETZM BLOCK-1(LP)
SETZM MODBLK-1(LP)
MOVEI X1,1
MOVEM X1,POINT-1(LP)
POPJ P,
OPNFL5: MOVEI X1,^D72
MOVEM X1,MARGIN(LP)
SETZM MARWAI(LP)
SETOM PAGLIM(LP)
SETZM QUOTBL(LP)
MOVEI X1,(LP)
JRST XRES01
OPNFL6: MOVEI X2,"%" ;R.A. OR ERROR.
CAIE X2,(C)
JRST OPNFL8
PUSHJ P,NXCH
OPNF20: HRLZI X1,400000
MOVEM X1,STRLEN-1(LP)
OPNF11: SKIPN FILTYP
JRST FNMX1
MOVE N,VALPTR
CAME N,T
JRST CHAER1
SETO A,
SKIPLE FILTYP ;VIRTUAL ARRAY?
SOJ A, ;YES. -2 TO ACTBL
JRST OPNFL3
OPNFL8: TLNN C,F.DOLL
JRST CHAER1
PUSHJ P,NXCH
SETZ B,
TLNN C,F.DIG
JRST [SETZM STRLEN-1(LP)
JRST OPNF11]
PUSHJ P,XFIL30
SKIPLE B
CAILE B,^D132
JRST OPNER4
OPNF10: MOVEM B,STRLEN-1(LP)
ADDI B,4
IDIVI B,5
ADDI B,1
HRLM B,STRLEN-1(LP)
JRST OPNF11
OPNER2: INLERR(3,67,</
? File />)
SETZM SAVE1
PUSHJ P,ERRXCX
PUSHJ P,PRNNAM
PUSHJ P,ERRXCY
INLERR(34,1,</ on more than one channel/>)
JRST GOSR2
OPNER4: INLERR(7,2,</
? String record length < 1 or > 132/>)
JRST GOSR2
DEFINE R(A)
<IRP A
< EXP OPS'A
EXTERN OPS'A>>
FILMOD: R<1,2,3,4,5,6,7,8,9>
INSEQ: SETOM QUERYF ;FLAG NO ?
JRST INSET2
INSET: JUMPN LP,INSET1 ;TTY?
SETZM QUERYF ;FLAG QUERY TO GO OUT
INSET2: SETZM IFIFG ;YES.
POPJ P,
INSET1: SKIPG X1,ACTBL-1(LP) ;NO. GET CORRESPONDING ACCESS CODE.
JRST FNMXER
CAMN LP,PLTIN ;PLOTTING FILE?
JRST PLTERR ;NO, GIVE ERROR
CAIE X1,1 ;IF NOT EQUAL TO 1, FILE NOT OK FOR READING
JRST ILRD ;ILLEGAL READ ERROR MESSAGE
SETOM IFIFG
POPJ P,
;END OF FILE TEST.
EOF: SKIPG X2,ACTBL-1(LP) ;ACTBL ENTRY = 1 MEANS A READABLE FILE.
JRST FNMXER
CAIE X2,1
JRST EOF6
SETOM IFIFG
EOF30: SKIPN T,PINPNM-1(LP) ;CHECK THE LINE BUFFER.
JRST EOF3
PUSHJ P,DELAWY
TLNN C,F.CR
JRST EOF0
SETZM PINPNM-1(LP)
EOF3: SETZ X1, ;NEED ANOTHER LINE. NXIN5 WILL CHECK
PUSHJ P,NXIN5 ;TO SEE IF IT SHOULD COME BACK HERE BY
EOF32: JRST EOF30 ;LOOKING FOR EOF32 ON PLIST.
EOF31: POP P,X1 ;BACK HERE FROM INLINE; CLEAR PUSH LIST.
POP P,X1
POP P,X1
SETZM IFIFG
POPJ P,
EOF0: SETZM IFIFG
SKIPN REAINP-1(LP) ;WARN READ# STATEMENTS TO SKIP
SETOM EOFFLG-1(LP) ;A LINE NUMBER; PROBLEM ONLY ARISES
JRST CPOPJ1 ;IF MODE WAS NOT SET WHEN IF END# WAS EXECUTED.
EOF6: PUSHJ P,TTYIN
INLERR(10,3,</
? IF END asked for unreadable file/>)
JRST GOSR2
;RESTORE.
XRES: SKIPG X2,ACTBL-1(LP) ;GET ACCESS CODE.
JRST FNMXER
CAIE X2,3
JRST XRES0
SETOM ODF
SKIPE HPOS(LP)
PUSHJ P,CRLF3
XRES0: DPB LP,[POINT 4,DREL,12] ;DEPOSIT CHANNEL NUMBER FOR RELEASE
XCT DREL ;DO RELEASE
HLRZ X2,BA-1(LP) ;GET BUFFER ADDRESS
MOVEM X2,.JBFF
SETZM @FILMOD-1(LP) ;SET MODE TO ASCII.
XCT INITO-1(LP) ;INIT THAT CHANNEL
JRST [MOVE T,OPS1+1
JRST NOGETD]
DPB LP,[POINT 4, IBDSK, 12]
XCT IBDSK
MOVE X2,FILD-1(LP) ;GET FILE NAME
MOVEM X2,LOK ;SET FOR LOOKUP
MOVE X2,EXTD-1(LP)
MOVEM X2,LOK+1
SETZM LOK+2
MOVE X2,FPPN-1(LP) ;GET PJ-PG
MOVEM X2,LOK+3 ;SAVE IT FOR LOOKUP
DPB LP,[POINT 4,LOKUP,12] ;SET CHANNEL FOR LOOKUP
XCT LOKUP ;DO LOOKUP
JRST LOKFAL
MOVE X2,ACTBL-1(LP)
CAIE X2,3
JRST XRES00
MOVEI X1,(LP)
PUSHJ P,UXIT7
MOVEI X2,1
MOVEM X2,ACTBL-1(LP)
JRST XRES0
XRES00: MOVEI X2,1
MOVEM X2,ACTBL-1(LP) ;SET ACCESS TABLE FOR READ
XRES01: SETZM PINPNM-1(LP)
SETZM REAINP-1(LP)
SETZM EOFFLG-1(LP)
SETZM ODF
POPJ P,
;SCRATCH
SCATH: SKIPG X2,ACTBL-1(LP) ;GET ACCESS CODE
JRST FNMXER
HLRZ X2,BA-1(LP) ;GET BUFFER ADDRESS
MOVEM X2,.JBFF
SETZM @FILMOD-1(LP) ;SET MODE TO ASCII.
XCT INITO-1(LP) ;DO INIT
JRST [MOVE T,OPS1+1
JRST NOGETD]
DPB LP,[POINT 4,OBDSK2,12] ;SET CHANNEL FOR OUTBUF
XCT OBDSK2 ;DO "OUTBUF"
MOVE X2,FILD-1(LP) ;GET FILE NAME
MOVEM X2,ENT ;SET FOR ENTER
MOVE X2,EXTD-1(LP)
HLLZM X2,ENT+1
SETZM ENT+2
LDB T1,[POINT 9,PROTEC-1(LP),8]
DPB T1,[POINT 9,ENT+2,8]
MOVE X2,FPPN-1(LP)
MOVEM X2,ENT+3
DPB LP,[POINT 4,ENTDSK,12] ;SET CHANNEL FOR ENTER
XCT ENTDSK ;DO ENTER
JRST ENFAIL ;ENTER FAILED
DPB LP,[POINT 4,OUTDSK,12] ;SET FOR DUMMY OUTPUT
XCT OUTDSK ;DO DUMMY OUTPUT
MOVEI X2,3 ;FILE OK FOR WRITING
MOVEM X2,ACTBL-1(LP) ;TELL ACCESS TABLE
MOVEI X2,^D990
MOVEM X2,LINNUM-1(LP)
SETZM WRIPRI-1(LP)
SETZM HPOS(LP)
SETOM FIRSFL(LP)
SETZM FMTPNT(LP)
SETZM PAGCNT(LP)
SETZM TABVAL(LP)
SETOM ZONFLG(LP)
POPJ P,
;R.A. RUNTIME SCRATCH.
RANSCR: SKIPL ACTBL-1(LP)
JRST FNMXER
SETZM LOK
DPB LP,[POINT 4,RENAMD,12] ;ERASE FILE.
XCT RENAMD
JRST RANSRF
MOVE X1,FILD-1(LP)
MOVEM X1,ENT
MOVEM X1,LOK
MOVE X1,EXTD-1(LP)
HLLZM X1,ENT+1
HLLZM X1,LOK+1
SETZM ENT+2
LDB X1,[POINT 9,PROTEC-1(LP),8]
DPB X1,[POINT 9,ENT+2,8] ;PRESERVE PROTECTION
MOVE X1,FPPN-1(LP)
MOVEM X1,ENT+3
DPB LP,[POINT 4,ENTDSK,12]
XCT ENTDSK
JRST ENFAIL
HLRZ X1,BA-1(LP)
ADDI X1,203
MOVEM X1,.JBFF ;SET UP HEADER RECORD.
DPB LP,[POINT 4,OBDSK,12]
XCT OBDSK
DPB LP,[POINT 4,OUTTDS,12]
XCT OUTTDS
JRST RSLAB1
JRST RANSC5
RSLAB1: MOVE X2,.JBFF
SOJ X2,
RANSC1: SETZM (X2)
SOJ X2,
CAIL X2,3(X1)
JRST RANSC1
SKIPG X1,STRLEN-1(LP)
JRST RSLAB2
MOVEM X1,2(X2)
JRST RANSC3
RSLAB2: HRLZI X1,400000
MOVEM X1,1(X2)
RANSC3: MOVEI X1,200 ;A DUMMY WORD COUNT
MOVEM X1,(X2)
DPB LP,[POINT 4,OUTTDS,12]
XCT OUTTDS
JRST RANSC4
RANSC5: DPB LP,[POINT 4,GTSTS,12]
XCT GTSTS
JRST [SETZM ACTBL-1(LP)
JRST OUTERR]
RANSC4: DPB LP,[POINT 4,CLOSED,12]
XCT CLOSED
SETZM LOK+2
SETZM LOK+3
DPB LP,[POINT 4,LOKUP,12]
XCT LOKUP
JRST LKFAIL
HLLZS ENT+1
SETZM ENT+2
MOVE X1,FPPN-1(LP)
MOVEM X1,ENT+3
XCT ENTDSK
JRST ENFAIL
HLRZ X1,BA-1(LP)
MOVEM X1,.JBFF
DPB LP,[POINT 4,IBDSK,12]
XCT IBDSK
XCT OBDSK
DPB LP,[POINT 4,OUTTDS,12]
XCT OUTTDS
JRST RSLAB3
JRST RANSC5
RSLAB3: DPB LP,[POINT 4,INNDSK,12]
XCT INNDSK
JRST RSLAB4
JRST EXEC86
RSLAB4: SETZM BLOCK-1(LP)
SETZM MODBLK-1(LP)
SETZM LASREC-1(LP)
MOVEI X1,1
MOVEM X1,POINT-1(LP)
POPJ P,
SETERR: INLERR(18,4,</
? SET argument/>)
JRST OUTBND
SEVEN: OCT 7
OUTSET: JUMPN LP,OSLAB1 ;TTY?
SETZM ODF ;YES.
POPJ P,
OSLAB1: SKIPG X2,ACTBL-1(LP) ;GET ACCESS CODE
JRST FNMXER
CAMN LP,PLTOUT ;PLOTTING FILE?
JRST PLTERR
CAIE X2,3 ;OPEN FOR WRITING?
JRST ILWRT ;NO
SETOM ODF
POPJ P,
;THIS ROUTINE IS USED AT RUNTIME BY THE READ# STATEMENTS.
;DELAWY SKIPS THROUGH DELIMITERS AND STOPS ON THE FIRST
;NON-TAB, NON-SPACE, NON-COMMA.
DELAWY: LDB C,T
JUMPE C,DELAWY
PUSHJ P,NXCHD2
DWLAB1: TLNN C,F.COMA+F.SPTB
POPJ P,
PUSHJ P,NXCH
JRST DWLAB1
;PRINTING SUBROUTINES
;PRINT TO QUOTE CHAR
;CALL: MOVE T,<ADDRS OF MSG>
; MOVE D,<QUOTE CHAR>
; PUSHJ P,PRINT
;CALL: MOVE T,<ADDRS OF MSG>
; MOVE D,<QUOTE CHAR>
; PUSHJ P,PRINT
;ALTERNATE CALL: PRINT1, IF BYTE PNTR IN T.
OUCH0: PUSH P,C
AOS HPOS(LP)
MOVE C,MARGIN(LP)
SKIPGE QUOTBL(LP) ;QUOTE MODE?
JRST OUCH4 ;YES.
CAML C,HPOS(LP) ;NO.
JRST OUCH3
PUSHJ P,PCRLF
JUMPN LP,OUCH5
OUTPUT
JRST OUCH5
OUCH4: CAML C,HPOS(LP)
JRST OUCH3
POP P,C
JRST PTXER2
OUCH3: SOS HPOS(LP)
OUCH5: POP P,C
JRST OUCH
;NUMBER PRINTER (PRINTS INTEGER IN T)
PRTNUX: MOVEI X1,3
SKIPE STRFCN
JRST PRTNX4
JRST PRTNX3
PRTNX1: MOVEI X1,4(B) ;CHECK ROOM FOR INT. OF THIS SIZE " "
SKIPN STRFCN
PRTNX3: PUSHJ P,CHROOM
PRTNX4: PUSHJ P,PSIGN
PRTNX2: IDIVI T,^D10
JUMPE T,PRTN0
PUSH P,T1
PUSHJ P,PRTNX2
POP P,T1
PRTN0: MOVEI C,60(T1)
AOS NUMCOT
SKIPE STRFCN
JRST DPBSTR
JRST OUCH0
PRTNUM: IDIVI T,^D10
JUMPE T,PRTN1
PUSH P,T1
PUSHJ P,PRTNUM
POP P,T1
PRTN1: MOVEI C,60(T1)
AOS NUMCOT
JRST OUCH
PSIGN: MOVEI C," " ;PRINT "SIGN" (BLANK OR MINUS)
JUMPL N,PSIGN2
SKIPE STRFCN
POPJ P,
JRST OUCH0
PSIGN2: SKIPE STRFCN
JRST PSIGN4
SKIPL QUOTBL(LP)
JRST PSIGN3
MOVEI C," "
PUSHJ P,OUCH0
PSIGN3: MOVEI C,"-"
JRST OUCH0
PSIGN4: MOVEI C,"-"
JRST DPBSTR
SUBTTL CORE COMPRESSION AND EXPANSION
PANIC1: ERROM(60,</
? Out of room/>)
INLSYS: ERROM(70,</
? System error/>)
;UTILITY ROUTINE TO SET UP VRFBOT AND VRFTOP.
SETCOR: PUSH P,X2
SETZM VRFBOT
SKIPN SRTDBA
JRST SETCO3
PUSH P,T1
PUSH P,T
PUSH P,A
PUSH P,C
SETCO1: MOVE X2,VARFRE
MOVEI T1,^D200(X2)
MOVEI T,^D200
SETZ A,
PUSHJ P,VSUB1
CAMG T1,.USREL
JRST SETCO2
PUSHJ P,VPANIC
JRST SETCO1
SETCO2: MOVEM T1,VRFBOT
MOVEM T1,VRFBTB
POP P,C
POP P,A
POP P,T
POP P,T1
JRST SETCO5
SETCO3: MOVE X2,VARFRE
ADDI X2,^D200
CAMG X2,.USREL
JRST SCLAB1
PUSHJ P,VPANIC
JRST SETCO3
SCLAB1: MOVEM X2,VRFBOT
MOVEM X2,VRFBTB
SETCO5: HRRZ X2,.USREL
MOVEM X2,VRFTOP
POP P,X2
POPJ P,
;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.
LITLEN=^D27
VCHCKC: PUSH P,T1 ;ENTRY POINT--REAL STRINGS.
JUMPE T,VCHCK1
ADDI T,4
IDIVI T,5
JRST VCHCK2
VCHCKW: PUSH P,T1 ;ENTRY POINT--REAL STRINGS.
JUMPN T,VCHCK2
VCHCK1: MOVEI T,LITLEN
VCHCK2: MOVE T1,VARFRE
ADDI T1,(T)
SKIPN VRFBOT
JRST VCHCK5
CAMG T1,VRFBTB
JRST VCHCK7
JRST VCHCK6
VCHCK5: CAMG T1,.USREL
JRST VCHCK7
VCHCK6: PUSHJ P,VPANIC
JRST VCHCK2
VCHCK7: SKIPE SRTDBA ;ANY BUFFERS?
JRST VCHCK3 ;YES.
MOVE T,VARFRE ;NO.
MOVEM T1,VARFRE
JRST VOUT
VCHCK3: PUSH P,X2
PUSH P,X1
PUSH P,A
PUSH P,C
VCHCK4: MOVE X2,VARFRE ;GET OUT OF THE WAY OF THE BUFFERS,
MOVEI T1,(X2)
ADDI T1,(T)
SETZ A, ;BY MOVING UP.
PUSHJ P,VSUB1
SKIPN VRFBOT
JRST VCHCK8
CAMG T1,VRFBTB
JRST VCHCK0
JRST VCHCK9
VCHCK8: CAMG T1,.USREL
JRST VCHCK0
VCHCK9: PUSHJ P,VPANIC
JRST VCHCK4
VCHCK0: MOVEM T1,VARFRE
VOUT2: MOVEI T,(X2)
VOUT0: POP P,C
POP P,A
POP P,X1
VOUT1: POP P,X2
VOUT: POP P,T1
POPJ P,
VCHAPP: PUSH P,T1 ;ENTRY POINT--APPEND BLOCKS.
VCHAP2: MOVE T1,VRFBOT
ADDI T1,^D47
CAMG T1,VRFTOP
JRST VCLAB1
PUSHJ P,VPANIC
JRST VCHAP2
VCLAB1: SKIPE SRTDBA ;ANY BUFFERS?
JRST VCHAP1 ;YES.
MOVE T,VRFBOT ;NO.
MOVEM T1,VRFBOT
JRST VOUT ;NO.
VCHAP1: PUSH P,X2
PUSH P,X1
PUSH P,A
PUSH P,C
VCHAP3: MOVE X2,VRFBOT
MOVEI T1,(X2)
ADDI T1,^D47
HRRZI T,^D47
SETZ A,
PUSHJ P,VSUB1 ;GET OUT OF THEIR WAY BY MOVING UP.
CAMG T1,VRFTOP
JRST VCLAB2
PUSHJ P,VPANIC
JRST VCHAP3
VCLAB2: MOVEM T1,VRFBOT
JRST VOUT2
VCHBUF: PUSH P,T1 ;ENTRY POINT--DATA FILE BUFFERS.
PUSH P,X2
VCHBF4: SKIPN T1,VRFBOT ;LOWER BOUND IS VRFBOT, IF IT
MOVE T1,VARFRE ;EXISTS, OTHERWISE IT IS VARFRE.
MOVEI T,406
ADDI T1,(T)
MOVE X2,VRFTOP
SKIPN VRFBOT
MOVE X2,.USREL
CAIG T1,(X2)
JRST VCLAB3
PUSHJ P,VPANIC
JRST VCHBF4
VCLAB3: SKIPE SRTDBA ;ANY BUFFERS?
JRST VCHBF2 ;YES.
SKIPE T,VRFBOT ;NO.
JRST VCHBF3
MOVE T,VARFRE
MOVEM T1,VARFRE
JRST VOUT1
VCHBF3: MOVEM T1,VRFBOT
JRST VOUT1
VCHBF2: PUSH P,X1
PUSH P,A
PUSH P,C
VCHBF5: SETZ A,
SKIPN T1,VRFBOT
MOVE T1,VARFRE
MOVEI X2,(T1)
ADDI T1,(T)
PUSHJ P,VSUB1 ;GET OUT OF THEIR WAY BY MOVING UP.
MOVE X1,VRFTOP
SKIPN VRFBOT
MOVE X1,.USREL
CAIG T1,(X1)
JRST VOUT2
PUSHJ P,VPANIC
JRST VCHBF5
VCHTSC: PUSH P,T1 ;ENTRY POINT--TEMP. STRINGS.
JUMPE T,VCHTS1
ADDI T,4
IDIVI T,5
JRST VCHTS2
VCHTSW: PUSH P,T1
JUMPN T,VCHTS2
VCHTS1: MOVEI T,LITLEN
VCHTS2: MOVE T1,VRFTOP
ADDI T1,1
SUBI T1,(T)
CAML T1,VRFBOT
JRST VCLAB6
PUSHJ P,VPANIC
JRST VCHTS2
VCLAB6: SKIPE SRTDBA ;ANY BUFFERS?
JRST VCHTS3 ;YES.
MOVEI T,(T1) ;NO.
SUBI T1,1
MOVEM T1,VRFTOP
JRST VOUT
VCHTS3: PUSH P,X2
PUSH P,X1
PUSH P,A
PUSH P,C
VCHTS4: MOVE T1,VRFTOP
ADDI T1,1
HRRZI X2,(T1)
SUBI X2,(T)
MOVE A,T
SETZ T,
PUSHJ P,VSUB1 ;GET OUT OF THE WAY OF THE BUFFERS BY MOVING DOWN.
MOVE T,A
CAML X2,VRFBOT
JRST VCLAB7
PUSHJ P,VPANIC
JRST VCHTS4
VCLAB7: MOVEI X1,-1(X2)
MOVEM X1,VRFTOP
JRST VOUT2
SUBTTL RUNTIME ROUTINES
;ROUTINE TO PRINT NUMBER
OUTSRF: SETOM STRFCN
JRST OTLAB1
OUTNUM: SETZM STRFCN
OTLAB1: 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 ;GO 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 INTEGER
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
MOVEM T,EXTFG ;SAVE FOR "EXACT" CHECK.
FADR T,FIXCON
TLZ T,377400 ;FIX
CAMGE T,INTTAB+6
JRST OUTN21
IDIVI T,^D10 ;ROUNDING MADE 7 DIGITS
ADDI B,1 ;MAKE IT 6 AGAIN
OUTN21: CAIL T,^D100000 ;ROUNDING MADE 5 DIGITS?
JRST OUTN22
IMULI T,^D10 ;YES. MAKE 6 AGAIN
SUBI B,1
OUTN22: ADDB B,E ;ADD TOGETHER TWO PARTS OF SCALE
AOJ E,
CAIG E,6
CAMG E,[OCT -6]
JRST OUTN3 ;TO OUTN3 FOR E.LE.-6 OR 6.LT.E.
JUMPL E,OUTN23 ;TO OUTN23 FOR -6.LT.E.LT.0.
MOVEI X1,^D10 ;HERE FOR 0.LE.E.LE.6.
SKIPN STRFCN ;CHECK ROOM FOR A DEC NO. WITH NO EXP.
PUSHJ P,CHROOM
SETZ B, ;B IS A FLAG FOR DNPRNT. 0 MEANS NO EXP.
PUSHJ P,PSIGN
JUMPE E,OUTN25 ;FINISH
JRST OUTN27 ;UP.
OUTN23: MOVE T1,EXTFG ;HERE FOR -6.LT.E.LT.0.
MOVM E,E
PUSH P,T
IDIV T,INTTAB(E)
JUMPE T1,OUTN24
POP P,T
JRST OUTN3 ;NOT "EXACT".
OUTN24: POP P,T1 ;"EXACT".
MOVEI X1,^D10 ;CHECK ROOM FOR A DEC NO. WITH NO EXP.
SKIPN STRFCN
PUSHJ P,CHROOM
SETZ B, ;B IS DNPRNT FLAG. 0 MEANS NO EXP.
PUSHJ P,PSIGN
OUTN25: MOVEI C,"0" ;OUTPUT "0" AND ".".
SKIPN STRFCN
JRST OTLAB2
PUSHJ P,DPBSTR
JRST OTLAB3
OTLAB2: PUSHJ P,OUCH0
OTLAB3: PUSHJ P,DNPRN2
JUMPE E,OUTN27
OUTN26: MOVEI C,"0" ;OUTPUT LEADING 0'S AFTER ".".
SKIPN STRFCN
JRST OTLAB4
PUSHJ P,DPBSTR
JRST OTLAB5
OTLAB4: PUSHJ P,OUCH0
OTLAB5: SOJG E,OUTN26
OUTN27: PUSHJ P,DNPRNT ;OUTPUT NO.
POP P,E ;RESTORE E.
POPJ P, ;EXIT.
OUTN3: MOVEI E,1 ;HERE FOR NOS. WHICH NEED EXPONENTS.
MOVEI X1,^D14 ;CHECK FOR ROOM FOR A DEC NO. + EXP.
PUSH P,B
SKIPN STRFCN
PUSHJ P,CHROOM
POP P,B
PUSHJ P,PSIGN
PUSHJ P,DNPRNT
POP P,E ;RESTORE E
MOVEI C,"E" ;OUTPUT EXPONENT.
SKIPN STRFCN
JRST OTLAB6
PUSHJ P,DPBSTR
JRST OUTN6
OTLAB6: PUSHJ P,OUCH0
OUTN6: MOVEI C,"+"
JUMPGE B,OTLAB7 ;SPIT OUT SIGN
MOVEI C,"-"
OTLAB7: SKIPN STRFCN
JRST OTLAB8
PUSHJ P,DPBSTR
JRST OTLAB9
OTLAB8: PUSHJ P,OUCH0
OTLAB9: MOVM T,B ;USE PRTNX2 TO PRINT EXPON
JRST PRTNX2
;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,DNPRN0 ;E-NOTATION
MOVEI D,0
DNPRN0: IDIVI T,^D10 ;GET LAST DIGIT
JUMPE T,DNPRN1 ;IS IT FIRST?
JUMPN T1,DPLAB1 ;NON ZERO DIGIT?
SKIPA T1,D ;NO, STASH ZERO OR TRAILZERO
DPLAB1: 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,DNPRN1 ;ORDINARY DIGIT?
JUMPLE E,CPOPJ ;NO, TRAILZERO. AFTER DECIMAL POINT?
MOVEI T1,0 ;NO, STASH A ZERO.
DNPRN1: MOVEI C,60(T1) ;PRINT DIGIT
SKIPN STRFCN
JRST DPLAB2
PUSHJ P,DPBSTR
JRST DPLAB3
DPLAB2: PUSHJ P,OUCH0
DPLAB3: SOJN E,CPOPJ ;COUNT DIGITS. POINT NEXT?
DNPRN2: MOVEI C,"." ;YES. PRINT POINT
SKIPE STRFCN
JRST DPBSTR
JRST OUCH0
SUBTTL
SUBTTL ERROR PROCESSING
ERRXCT: PUSH P,X1 ;SAVE AN AC
SKIPE ERRGO ;ON ERROR GOTO ?
JRST ONERPR ;YES. GO PROCESS.
PUSH P,X2 ;AND ANOTHER
SKIPE X1,ERRTCN ;GET ERROR COUNT
JRST ERRXC1 ;ALREADY SOME
MOVE X2,[XWD 700,ERRTXT-1]
MOVEM X2,ERRBPT
ERRXC1: LDB X2,[POINT 9,40,35] ;PICK UP TEXT ADDRESS
JUMPE X2,ERRXC3 ;ZERO MEANS NON FATAL ERROR SO JUST IGNORE
ADD X2,[XWD 20,400007]
ERRXC2: MOVEM X2,ERRTBL(X1) ;STASH IT
AOS ERRTCN ;UP ERROR COUNT
ERRXC3: POP P,X2 ;RESTORE
POP P,X1 ;ACS
POPJ P, ;AND BACK TO WORK
ERRXCX: PUSH P,X1 ;SAVE AN AC
PUSH P,X2 ;AND ANOTHER
MOVE X1,ERRTCN ;GET ERROR COUNT
HRRZ X2,ERRBPT ;GET TEXT ADDRESS
AOJA X2,ERRXC2 ;INCREMENT
ERRXCY: PUSH P,X1 ;SAVE AN AC
PUSH P,X2 ;AND ANOTHER
MOVE X1,ERRBPT ;GET A BYTE POINTER
SETZ X2, ;MAKE ASCIZ
ERRXC4: IDPB X2,X1 ;SAVE A ZERO
TLNE X1,760000 ;REACHED A WORD BOUNDARY?
JRST ERRXC4 ;NO, CARRY ON
MOVEM X1,ERRBPT ;YES, SAVE POINTER
JRST ERRXC3 ;AND RETURN
;DO STUFF FOR USERS "ON ERROR GOTO"
ONERPR: LDB N,[POINT 9,40,26] ;PICK UP ERROR #
MOVEM N,ERR
MOVE X1,SORCLN ;PICK UP LINE #
MOVEM X1,ERL ;SAVE N CASE RETROACTIVE "ON ERROR GOTO"
MOVE X1,UUOH ;PICK UP ADDRESS OF UUO+1
SUBI X1,1 ;NOW POINTS TO UUO
MOVEM X1,ERRTRO ;NOW RETROACTIVE "ON ERROR GO TO"
;CAN FINISH UP THE ERROR CODING AS USUAL
POP P,X1 ;RESTORE X1
SVV0=ERRTBL
;SAVE ACS IN UNUSED LO SEGMENT IN CASE RETROACTIVE "ON ERROR GOTO"
POP P,SVV0 ;RECTIFY PDL
MOVEM 0,SVV0 ;SAVE AC 0
MOVE 0,[XWD 1,SVV0+1]
BLT 0,SVV0+17
PUSHJ P,PCHECK ;MAKE SURE PDL IS IN GOOD SHAPE
JRST @ERRGO ;GO TO USERS "ON ERROR GOTO" ADDRESS
ERRCNT: MOVE X1,ERL ;GET LINE FROM WHICH ERROR CAME FROM
MOVEM X1,SORCLN ;PUT BACK IN SORCLN
;RESTORE ACS SAVED AT ONERPR
MOVE 0,[XWD SVV0+1,1]
BLT 0,17
MOVE 0,SVV0
JRST @ERRTRO ;GO DO REST OF ERROR STUFF AS USUAL
LINADR: MOVEM A,SORCLN ;SORCLN POINTS TO LINE #.
JRST 1(A) ;RETURN TO DO REST OF LINE
;RUN-TIME GOSUB ROUTINES
FORCOM: MOVEI X1,313 ;RUNTIME COMPARE FIX-DONT USE IF CON
SKIPGE @40
ADDI X1,2
DPB X1,[POINT 9,@(P),8] ;SET UP COMPARE FOR ENTIRE LOOP
POPJ P,
XCTON: MOVE T,N ;
JUMPLE T,XCTON1 ;
ADDI T,(A) ;GET THE "GOTO" ADDRESS
CAML T,(A)
JRST XCTON1
HLRZ N,(T)
CAIN N,254000
JRST @(T)
MOVE N,(A)
PUSH P,N
MOVE N,(T)
MOVEM N,40
JRST GOSBER
XCTON1: INLERR(58,5,</
? ON evaluated out of range/>)
JRST GOSR2
;HERE ON OVFLOW ERROR
OVTRAP: PUSH P,X1 ;SAVE THIS REG IN CASE FALSE ALARM.
SKIPE NOLINE ;TRAP WHILE AT DDT BREAK POINT?
JRST OVTRP0 ;YES, PROCESS IT
HRRZ X1,.JBTPC ;GET TRAP ADDRESS.
CAML X1,FLCOD ;TRAP IN USER PROG?
CAMLE X1,CECOD
JRST OVFIG2 ;NO. FALSE TRAP.(NOT BY USER)
OVTRP0: MOVE X1,.JBTPC ;GET TRAP FLAGS.
TLNE X1,(1B11) ;UNDERFLOW?
JRST UNTRAP ;YES
TLNE X1,(1B12) ;ZERO DIVIDE?
JRST DVTRAP ;YES
OVTR0: TLNN X1,(1B3) ;IS IT INTEGER OR FLOATING
JRST OVTRIN ;INTEGER
NFERR (92,0)
PUSHJ P,INLMES
ASCIZ /
% Floating overflow/
JRST OVTR2 ;FIX UP RESULT
OVTRIN: NFERR (92,0)
PUSHJ P,INLMES ;OUTPUT OVERFLOW MESSAGE
ASCIZ /
% Integer overflow/
OVTR2: SKIPL N ;NEG OVFLOW?
HRLOI N,377777 ;LRG NUMBER
SKIPG N
MOVE N,MIFI ;LRG NEG NUMBER
OVTR1: PUSHJ P,GOSR3
OVFIG2: MOVEI X1,630010
APRENB X1,
SETOM LIBFLG
POP P,X1
JRST @.JBTPC
UNTRAP: NFERR (93,0)
PUSHJ P,INLMES
ASCIZ /
% Floating underflow/
SETZI N, ;RESULT IS ZERO.
JRST OVTR1
DVTRAP: NFERR (61,0)
PUSHJ P,INLMES
ASCIZ /
% Division by zero/
JRST OVTR2
SUBTTL RUNTIME ROUTINES
;ANALYZE THE FILENAME ARGUMENT FOR CHAIN.
CHAHAN: PUSHJ P,STRPL1 ;GET STR PLUS TERM DOLL SIGN
JRST CHAER1 ;SO FILNAM WILL STOP.
PUSHJ P,FILNAM
JUMP NEWOL1
CAME T,VALPTR ;STOPPED IN RIGHT PLACE?
JRST CHAER1
POP P,Q
MOVEI X2,CHLAB1
JRST RESACS
CHLAB1: SOS MASAPP
POPJ P,
GOSBER: PUSHJ P,PCHECK ;CHECK ENOUGH PDL
PUSH P,PSAV
MOVEM P,PSAV ;SAVE PDP LEVEL IN CASE ERROR TRAP
MOVE X1,@40
MOVE R,FCNLNK
HRLM R,@40
MOVE R,40
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)
INLERR(27,51,</
? Subroutine or function calls itself/>)
JRST GOSR2
RETURN: SETZB T,IFNFLG ;GOSUB RETURN, NOTHING ON PLIST.
CAIA
FRETRN: SETOM IFNFLG ;IFNFLG DISTINGUISHES BETWEEN "RETURN"
MOVE R,FCNLNK ;AND END OF FNX PROCESSING.
JUMPLE R,BADRET ;CHECK RETURN TOO FAR
MOVS X1,(R) ;FETCH LINK BACK
HRRZS (R) ;MARK SUBR NOT IN USE
HRREI R,(X1)
MOVEM R,FCNLNK
CAME P,PSAV ;MAKE SURE PDL OKAY
JRST MNYDEF
POP P,PSAV ;RESTORE SAVED PDL LEVEL
POP P,X2 ;SAVE REAL RETURN LOCATION
JFFO T,RTLAB1 ;CONVERT MASK TO NUM ARGS
JRST FRTRN1 ;ZERO, NO FIX UP NEEDED
RTLAB1: TRZ T1,1 ;MAKE EVEN
SUBI T1,^D36 ;NUMBER OF ARGS * 2
ASH T1,-1 ;DIVIDE BY 2
MOVMS T1 ;MAKE POSITIVE
HRLS T1,T1 ;LH = RH
SUB Q,T1 ;FIX PUSH DOWN LIST
FRTRN1: SKIPN IFNFLG
JRST (X2) ;RETURN
RESACS: POP P,T ;RESTORE AC'S, EXCEPT 0, X2, AND P.
POP P,T1
POP P,SORCLN
POP P,A
POP P,B
POP P,C
POP P,D
POP P,F
POP P,ODF
POP P,E
POP P,G
POP P,R
POP P,X1
POP P,L
JRST (X2)
SAVACS: POP P,X2
PUSHJ P,PCHECK ;CHECK ENOUGH PDL SPACE
PUSH P,N
HRRZ N,Q
SUBI N,QLIST
CAILE N,55
JRST MNYDEF
POP P,N
SAVCS1: PUSH P,L
PUSH P,X1
PUSH P,R
PUSH P,G
PUSH P,E
PUSH P,ODF
PUSH P,F
PUSH P,D
PUSH P,C
PUSH P,B
PUSH P,A
PUSH P,SORCLN
PUSH P,T1
PUSH P,T
JRST (X2)
PCHECK: PUSH P,N
HRRZ N,P
SUBI N,PLIST
CAILE N,250
JRST MNYDEF
POP P,N
POPJ P,
MNYDEF: SETZM ERRGO ;DISABLE ERROR TRAPPING !
INLERR(29,6,</
? Too many FN's, GOSUBs or error traps/>)
JRST GOSR2
BADRET: INLERR(31,7,</
? RETURN before GOSUB/>)
JRST GOSR2
;R.A. OUTPUT ROUTINE.
RNSTRO: SKIPG STRLEN-1(LP) ;STR FILE?
JRST RNERR1 ;NO. FAIL.
HLRZ B,STRLEN-1(LP) ;B=NO. WORDS/REC.
MOVEI X1,^D128
IDIVI X1,(B)
MOVE A,POINT-1(LP) ;X1=NO. RECS/BLK.
MOVEI T,(A)
IDIVI T,(X1) ;T = BLK NO. - 1.
IMULI T1,(B) ;T1 = NO. OF WRDS INTO BLK.
JRST RNNUM1
RNNUMO: SKIPL STRLEN-1(LP) ;NUM FILE?
JRST RNERR1 ;NO. FAIL.
MOVE A,POINT-1(LP)
MOVE T,A ;T = BLK NO. - 1.
AOS T
IDIVI T,^D128 ;T1 = NO. OF WRDS INTO BLK.
RNNUM1: AOJ T,
CAMN T,BLOCK-1(LP) ;CUR BLK?
JRST RNNUM4 ;YES.
SKIPN MODBLK-1(LP) ;NO -- NEED TO OUTPUT
JRST RNNUM2 ;CUR BLK?
MOVE X2,BLOCK-1(LP) ;YES.
PUSHJ P,OUTRAN
RNNUM2: CAMG A,LASREC-1(LP) ;IS NEW REC WITHIN FILE?
JRST RNNUM3 ;YES.
MOVE A,LASREC-1(LP) ;NO. IS IT WITHIN THE LAST BLOCK?
SKIPG STRLEN-1(LP)
AOS A
SKIPG STRLEN-1(LP)
MOVEI X1,^D128
IDIVI A,(X1)
CAIN T,1(A)
JRST RNNUM3 ;YES.
RNNM25: HLRZ A,BA-1(LP)
MOVEI B,177 ;CLEAR OUT NEW BLK.
ROLAB1: SETZM 3(A)
AOJ A,
SOJGE B,ROLAB1
JRST RNNM31 ;
RNNUM3: MOVE X2,T ;OR GET NEW BLK.
PUSHJ P,LOCKON ;SET INTERLOCK
PUSHJ P,INRAN
RNNM31: MOVEM T,BLOCK-1(LP)
PUSHJ P,LOCKOF ;
RNNUM4: MOVE A,POINT-1(LP)
CAMLE A,LASREC-1(LP)
MOVEM A,LASREC-1(LP)
HLRZ A,BA-1(LP)
ADDI A,3(T1)
SKIPL STRLEN-1(LP)
JRST RNNUM5
SKIPN VIRWRD ;VIRTUAL ARRAY?
MOVEM N,(A) ;OUTPUT NUM.
RNNOUT: AOS POINT-1(LP)
SETOM MODBLK-1(LP)
POPJ P,
RNNUM5: TLNN N,777777 ;OUTPUT STR.
JRST RNNM12
TLNE N,377777
JRST RNNUM6
MOVE T,N
MOVE N,(T)
TLNN N,777777
JRST RNNM12
RNNUM6: JUMPG N,RNNUM9
HLRE T,N
MOVM T,T
HRRZ B,STRLEN-1(LP)
CAMLE T,B
JRST RNERR2
MOVEM T,(A)
ADDI A,1
HRL A,N
SOJL T,RNNOUT
IDIVI T,5
ADDI T,(A)
BLT A,(T)
JRST RNNOUT
RNNUM9: MOVE X1,N ;APP BLK.
PUSHJ P,LENAPB
HRRZ B,STRLEN-1(LP)
CAMLE N,B
JRST RNERR2
MOVEM N,(A)
ADDI A,1
HRLI A,440700 ;A HAS NEW PNTR.
HLRE E,X1
HRRZI X1,(X1)
RNNM10: HRR X2,1(X1)
HRLI X2,440700 ;X2 IS AN OLD PNTR.
HLRE T1,1(X1)
JUMPE T1,RNNM11
ROLAB2: ILDB C,X2
IDPB C,A
AOJL T1,ROLAB2
RNNM11: SOJLE E,RNNOUT
AOJA X1,RNNM10
RNNM12: SETZM (A)
JRST RNNOUT
;UTILITY ROUTINE TO INPUT A BLOCK FOR A R.A. FILE. THE DESIRED
;BLOCK NUMBER IS IN X2.
INRAN: HRRM X2,USETID-1(LP)
XCT USETID-1(LP)
DPB LP,[POINT 4,INNDSK,12]
XCT INNDSK
POPJ P,
SETZM ACTBL-1(LP)
INLEMS(1,70,INLSYS)
JRST GOSR2
;UTILITY ROUTINE TO TRANSFER A BLOCK FROM A R.A. INPUT BUFFER TO THE
;OUTPUT BUFFER FOR THAT CHANNEL. THE BLOCK NUMBER IS IN X2.
OUTRAN: PUSH P,X1
HRRM X2,USETOD-1(LP)
XCT USETOD-1(LP)
HLRZ X2,BA-1(LP)
ADDI X2,3
HRLI X2,(X2)
MOVEI X1,203
ADDI X1,(X2)
HRRI X2,(X1)
BLT X2,177(X1)
MOVEI X2,200
HRRM X2,-1(X1)
DPB LP,[POINT 4,OUTTDS,12]
POP P,X1
XCT OUTTDS
POPJ P,
SETZM ACTBL-1(LP)
DPB LP,[POINT 4,GTSTS,12]
XCT GTSTS
JRST OUTERR
;RUNTIME ROUTINE FOR THE PAGE STATEMENT.
;PAGE SIZE IS IN AC N, IN FLOATING POINT.
PAGE: CAIGE N,1
JRST PAGERR ;OR GREATER.
PAGE0: MOVEM N,PAGLIM(LP)
JUMPE LP,PAGE1 ;TTY IS ALWAYS IN "OUTPUT MODE".
MOVE T1,ACTBL-1(LP) ;FILE. IS IT WRITEABLE?
CAIE T1,3
JRST PAGE2
PAGE1: PUSH P,ODF
SETZM ODF
JUMPE LP,PGLAB1
SETOM ODF
PGLAB1: SKIPN HPOS(LP) ;NEED TO END CURRENT LINE?
JRST PAGE3 ;NO.
MOVEI C,15
PUSHJ P,OUCH
MOVEI C,12
PUSHJ P,OUCH
PAGE3: MOVEI C,14
PUSHJ P,OUCH
SETOM FIRSFL(LP)
POP P,ODF
PAGE2: SETZM PAGCNT(LP)
SETZM HPOS(LP)
SETZM TABVAL(LP)
SETZM FMTPNT(LP)
POPJ P,
;RUNTIME ROUTINE FOR THE PAGE ALL STATEMENT.
;PAGE SIZE IS IN AC N, IN FLOATING POINT.
PAGEAL: CAIGE N,1 ;PAGE SIZE MUST BE 1.0
JRST PAGERR ;OR GREATER.
MOVEI LP,9
PAGEL1: PUSHJ P,PAGE0
SOJG LP,PAGEL1
POPJ P,
;RUNTIME ROUTINE FOR THE MARGIN STATEMENT.
;MARGIN SIZE IS IN AC N, IN FLOATING POINT.
MARGN: CAIL N,1 ;MARGIN MUST BE GE.1 AND LE.132.
CAIL N,^D133
JRST MARER1
MOVEM N,MARWAI(LP)
POPJ P,
ONE33: 133.0
ONE28: 128.0
MINONE: -1.0
;RUNTIME ROUTINE FOR THE MARGIN ALL STATEMENT.
;MARGIN SIZE IS IN AC N, IN FLOATING POINT.
MARGAL: CAIL N,1 ;MARGIN MUST BE GE. 1 AND LE. 132.
CAIL N,^D133
JRST MARER1
MOVEI LP,9
MRLAB1: MOVEM N,MARWAI(LP)
SOJG LP,MRLAB1
POPJ P,
;SEMI-IFIX ROUTINE.
;IFIX EXPECTS A NON-NEGATIVE FLOATING POINT NUMBER IN AC N
;AND RETURNS A FIXED POINT INTEGER IN AC N.
IFIX: PUSH P,T
PUSH P,T1
MOVE T,N
MULI T,400
SETZM LIBFLG
ASH T1,-243(T)
MOVE N,T1
POP P,T1
POP P,T
SKIPN LIBFLG
POPJ P,
HRLOI N,377777
POPJ P,
;SEMI-IFLOAT ROUTINE.
;IFLOAT EXPECTS A NON-NEGATIVE FIXED POINT NUMBER IN AC N AND
;RETURNS A FLOATING POINT NUMBER IN AC N.
IFLOAT: PUSH P,T
SETZ T,
LSHC N,-^D8
LSH T,-^D9
TLO N,243000
TLO T,210000
FADR N,T
POP P,T
POPJ P,
;RUN-TIME ROUTINES FOR READ AND INPUT
DOREAD: MOVE R,[XWD NXREAD,PREAD]
SETZM INPFLA ;READ, NOT INPUT
POPJ P, ;SET UP TO READ
DOINPT: SKIPN IFIFG
SETZM PINPUT ;FORCE NEW LINE
MOVE R,[XWD NXINPT,PINPUT]
POP P,INPFLA ;SAVE ERROR RETURN
MOVEM P,INPRES ;SAVE P IN CASE OF INPUT ERROR
JRST @INPFLA
;ROUTINE TO GET A DATA WORD
DATAER: SKIPN IFIFG
JRST DATAE1
SKIPN T,PINPNM-1(LP)
JRST NXINPT
SKIPGE REAINP-1(LP)
SKIPN EOFFLG-1(LP) ;SEE NOTE IN IF END# ROUTINE.
JRST DTLAB1
SETZ X1,
JRST NXIN4
DTLAB1: PUSHJ P,DELAWY
JRST DATR0
DATAE1: SKIPN T,(R) ;MORE ON SAME LINE?
;THE NEXT EIGHT LINES OF CODE SHOULD NOT BE EXPANDED
;SEE SLOPPY (DEC) CODING @ SSKIP
JRST DATR1 ;NO
PUSHJ P,NXCH ;PUT FIRST CHAR OF NEXT NUMBER IN C
SKIPE INPFLA ;CHECK TO SEE IF THIS IS REALLY
JRST DATR0 ;THE "ONE OPTIONAL TRAILING COMMA"
TLNE C,F.TERM ;ALLOWED IN DATA STATEMENTS.
JRST DATR1
DATR0: PUSHJ P,EVANUM
PUSHJ P,SSKIP ;IT WASN'T A NUMBER, TRY NEXT
JUMPE N,DATOK1 ;DON'T CHECK TYPE ON ZERO
MOVE B,TYPE ;GET TYPE FOR INPUT NUMBER
CAMN B,FTYPE ;DOES IT MATCH?
JRST DATOK1 ;YES, DATA IS OK
SKIPE FTYPE ;SHOULD IT BE REAL?
JRST DATR2 ;NO, GIVE ERROR
PUSH P,T ;FLTPNT USES T
PUSHJ P,FLTPNT ;YES, FLOAT IT
POP P,T ;RESTORE T
DATOK1: PUSH P,X1
HRRZ X1,40
MOVEM N,(X1) ;STORE THE DATA WORD.
POP P,X1
SKIPE IFIFG
PUSHJ P,DELAWY
SKIPE INPFLA ;END OF LINE TEST.
TLNN C,F.CR
TLNE C,F.TERM
SETZI T,
SKIPN IFIFG
JRST DATAE2
MOVEM T,PINPNM-1(LP)
JRST DATR01
DATAE2: MOVEM T,(R)
DATR01: 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)
DATR2: SKIPE INPFLA ;READ OR INPUT?
JRST INPERR ;INPUT, ASK FOR NEW LINE
JRST IMP ;JUST GIVE ERROR
;ROUTINE TO GET A DATA STRING
INSTR:
SDATAE: SKIPN IFIFG
JRST SDAT1
SKIPN T,PINPNM-1(LP)
JRST NXSINP
SKIPGE REAINP-1(LP)
SKIPN EOFFLG-1(LP) ;SEE NOTE IN IF END# ROUTINE.
JRST ISLAB1
MOVEI X1,1
JRST NXIN4
ISLAB1: PUSHJ P,DELAWY
JRST SDATR0
SDAT1: MOVE T,1(R) ;GET CURRENT LINE POINTER
SKIPE INPFLA ;INPUT,INSTRUCTION?
MOVE T,(R) ;YES, SHARE POINTER WITH NUMBER DATA
SKIPN T ;MORE ON CURRENT STRING DATA LINE?
;THE NEXT EIGHT LINES OF CODE SHOULD NOT BE EXPANDED
;SEE SLOPPY (DEC) CODING @ SSKIP
JRST SDATR1 ;NO. HUNT FOR NEXT DATA LINE
PUSHJ P,[SKIPE INLNFG
JRST NXCHS
JRST NXCH]
;GET FIRST CHAR
SKIPE INPFLA ;CHECK TO SEE IF THIS IS REALLY
JRST SDATR0 ;THE "ONE OPTIONAL TRAILING COMMA"
TLNE C,F.TERM ;ALLOWED IN DATA STATEMENTS.
JRST SDATR1
SDATR0: PUSHJ P,REDSTR ;READ THE STRING AND STORE IT
PUSHJ P,SSKIP ;BAD STRING
SKIPE IFIFG
PUSHJ P,DELAWY
SKIPE INPFLA ;END OF LINE TEST.
TLNN C,F.CR
TLNE C,F.TERM
SETZI T,
SKIPN IFIFG
JRST SDAT2
MOVEM T,PINPNM-1(LP)
JRST DATR01
SDAT2: MOVEM T,1(R) ;SAVE STRING DATA POINTER.
SKIPE INPFLA ;INPUT?
MOVEM T,(R) ;YES , SHARE POINTER
JRST DATR01
SDATR1: MOVS X1,R ;DISPATCH ADDRESS FOR STRING DATA..
JRST 1(X1)
;GET AN ARRAY DATA WORD
ADT1ER: PUSHJ P,ADTTYP
MOVE X1,(P) ;GET RESTART ADDRESS IN CASE OF ERROR
SKIPN T ;END OF A LINE?
SKIPN INPFLA ;IS THIS INPUT
JRST AST1ER ;GO STORE THE WORD
MOVEM X1,INPFLA ;RESTART NEXT ERROR FROM HERE
JRST AST1ER ;GO STORE THE WORD
ADT2ER: PUSHJ P,ADTTYP
MOVE X1,(P) ;GET RESTART ADDRESS IN CASE OF ERROR
SKIPN T ;END OF A LINE?
SKIPN INPFLA ;IS THIS INPUT
JRST AST2ER ;GO STORE THE WORD
MOVEM X1,INPFLA ;RESTART NEXT ERROR FROM HERE
JRST AST2ER
ADTTYP: MOVE X1,40 ;PICKUP OP-CODE
CLEARM FTYPE ;ASSUME IT IS REAL
TLZE X1,400 ;IS IT INTEGER?
SETOM FTYPE ;YES, MARK IT
PUSH P,X1 ;SAVE 40
CLEARM 40 ;DUMMY 40 FOR INPUT
PUSHJ P,DATAER ;INPUT A NUMBER
POP P,40 ;RESTORE 40
POPJ P, ;AND RETURN
;GO TO NEXT LINE OF DATA
NXREAD: TDZA X1,X1 ;GET NEXT DATA LINE FOR NUMBER ITEM
NSRSTR: MOVEI X1,1 ;GET NEXT DATA LINE FOR STRING ITEM
MOVE T,DATLIN(X1) ;GET NXT DATA LINE NO
AOBJP T,NXRE2 ;JUMP IF OUT OF DATA
MOVEM T,DATLIN(X1)
HRRZ T,(T) ;GET ADDRS OF SOURCE LINE
HRLI T,440700
PUSHJ P,NXCH
PUSH P,X1
PUSHJ P,QSA ;LOOK FOR "DATA"
ASCIZ /DATA/
JRST [POP P,X1
JRST NXREAD+2]
POP P,X1
JUMPG X1,SDATR0 ;GO GET STRING?
JRST DATR0 ;NO, GO GET NUMBER
;REQUEST NEXT LINE OF INPUT
NXVINP: SETOI X1, ;GET LINE AND RETURN TO "MATIN"
JRST NXIN1
NXINPT: TDZA X1,X1 ;GET A LINE OF INPUT; NUMBER ITEM NEXT
NXSINP: MOVEI X1,1 ;GET A LINE OF INPUT; STRING ITEM NEXT
NXIN1: SKIPN IFIFG
SETZB LP,ODF
JUMPN LP,NXIN5
PUSH P,A ;OUTPUT ANY FORMATTING BEFORE THE "?".
PUSH P,B
PUSH P,X1
PUSH P,X2
PUSH P,40
SETZM 40
PUSHJ P,PRDLER
POP P,40
SETZ X1,
PUSHJ P,CHROOM
SKIPE QUERYF ;TO OUTPUT ?
JRST NXIN7 ;NO
PUSHJ P,INLMES
ASCIZ / ?/
NXIN7: OUTPUT
SETZM QUERYF
PUSHJ P,PCRLF3
SETZM FMTPNT
POP P,X2
POP P,X1
POP P,B
POP P,A
NXIN5: MOVE T,LINPT(LP) ;IF END# ENTERS HERE.
PUSHJ P,INLINE ;READ THE LINE AND GET FIRST CHAR.
TLNE C,F.CR ;NULL LINE?
JUMPL X1,CPOPJ1 ;YES. ALLOW THIS ON MAT INPUT
NXIN4: MOVE T,LINPT(LP)
JUMPE LP,NXIN6
NXIN8: PUSHJ P,NXCH
TLNE C,F.CR
JRST NXIN5
SKIPL REAINP-1(LP) ;EXPECT A LINE NUMBER?
JRST NXIN6 ;NO.
MOVEI A,4
TLNN C,F.DIG
JRST IMP
NXLAB2: PUSHJ P,NXCHD
TLNN C,F.DIG
JRST NXLAB1
SOJGE A,NXLAB2
JRST IMP
NXLAB1: TLNE C,F.CR ;EMPTY LINE?
JRST NXIN5 ;YES.
TLNE C,F.SPTB ;DELIMITER AFTER LINE NUMBER
JRST NXIN3 ;MUST BE A SPACE, A TAB, OR THE LETTER D.
HRRZ A,C
CAIE A,"D"
JRST IMP
NXIN3: PUSH P,T
PUSHJ P,NXCH
TLNN C,F.CR
JRST NXLAB3
POP P,T ;LINE NO. FOLLOWED BY EMPTY LINE.
JRST NXIN5
NXLAB3: POP P,T
MOVEI C,40
DPB C,T
NXIN6: SKIPN IFIFG
JRST NXIN2
MOVEM T,PINPNM-1(LP)
JRST NXIN9
NXIN2: MOVEM T,PINPUT
PUSHJ P,DATCHK ;CHECK
JFCL
NXIN9: HRRZ T,(P)
CAIN T,EOF32
POPJ P, ;BACK TO IF END#.
SETZM EOFFLG-1(LP)
JUMPE X1,DATAER ;GET NUMBER ITEM
JUMPG X1,SDATAE ;GET STRING ITEM
POPJ P,
INPERP: POP P,X1 ;GET RID OF CALL TO NXVINP!
INPERR: SKIPE IFIFG
JRST IMP
NFERR (50,0)
PUSHJ P,INLMES
ASCIZ /
? Input data not in correct form/
SKIPE CHAFL2 ;CHAINING?
PUSHJ P,ERRMS3
PUSHJ P,INLMES
ASCIZ /--please retype
/
SETZM PINPUT
INPER1: HRRZ X1,INPFLA
MOVE P,INPRES ;RESTORE P TO POINT OF ERROR
JRST (X1) ;START LINE OVER.
;R.A. READ/INPUT ROUTINES.
RANUM1: PUSH P,40 ;NUM 1 DIM.
SETZM 40
PUSHJ P,RANUM
POP P,40
JRST AST1ER
RANUM2: PUSH P,40 ;NUM 2 DIM.
SETZM 40
PUSHJ P,RANUM
POP P,40
JRST AST2ER
RANSTR: SKIPG STRLEN-1(LP) ;STR.
JRST RNERR1
MOVE T,POINT-1(LP)
CAMLE T,LASREC-1(LP)
JRST EOFFL
HLRZ B,STRLEN-1(LP)
MOVEI X1,^D128
IDIVI X1,(B) ;X1=NO. OF RECS/BLK.
IDIVI T,(X1) ;T=BLK NO. - 1.
IMULI T1,(B) ;T1=NO. OF WORDS INTO BLK.
JRST RANNM1
RANUM: SKIPL STRLEN-1(LP) ;NUM.
JRST RNERR1
MOVE T,POINT-1(LP)
CAMG T,LASREC-1(LP)
JRST RANNM7
MOVNI X2,2 ;-2 IS FOR VIRTUAL ARRAY
CAME X2,ACTBL-1(LP) ;IS THIS ONE ?
JRST EOFFL ;NO, EOF ERROR
SETZ N, ;YES, RETURN 0 OR NULL STR.
POPJ P,
RANNM7: AOJ T,
IDIVI T,^D128
RANNM1: AOJ T,
CAMN T,BLOCK-1(LP)
JRST RANNM3
SKIPN MODBLK-1(LP)
JRST RANNM2
MOVE X2,BLOCK-1(LP)
PUSHJ P,OUTRAN
RANNM2: MOVEI X2,(T)
PUSHJ P,LOCKON ;SET INTERLOCK
PUSHJ P,INRAN
MOVEM T,BLOCK-1(LP)
SETZM MODBLK-1(LP)
PUSHJ P,LOCKOF ;REMOVE INTERLOCK
RANNM3: HLRZ A,BA-1(LP)
ADDI A,3(T1)
SKIPL STRLEN-1(LP)
JRST RANNM4
MOVE T,(A) ;READ NO.
HRRZ X1,40
MOVEM T,(X1)
AOS POINT-1(LP)
POPJ P,
RANNM4: MOVE T,(A) ;READ STR.
CAIG T,^D132
JUMPGE T,RMLAB1
JRST RNERR3
RMLAB1: PUSHJ P,PNTADR
SKIPE (X1)
SETZM VPAKFL
JUMPN T,RANNM5
SETZM (X1)
JRST RANNM6
RANNM5: PUSHJ P,VCHCKC
MOVE X2,(A)
HRLI T,1(A)
MOVEI X2,-1(X2)
PUSH P,Q
IDIVI X2,5
POP P,Q
ADDI X2,(T)
PUSH P,T
BLT T,(X2)
POP P,T
HRRM T,(X1)
MOVN T,(A)
HRLM T,(X1)
MOVEI X2,1(X2)
HRRM X2,VARFRE
RANNM6: AOS POINT-1(LP)
POPJ P,
;USING STATEMENT ROUTINES
;CHKIMG SETS UP THE STARTING AND CURRENT POINTER TO THE IMAGE IN MASAPP,
;THE TOTAL AND THE CURRENT NUMBER OF CHARS IN THE IMAGE IN B AND X2,
;AND BEGFLG IN T1. THE CURRENT POINTER IS ALSO IN X1.
CHKIMG: TLNN N,777777 ;GET IMAGE KEY.
JRST IMGER1
TLNE N,377777
JRST CHKIM1
MOVE T,N
MOVE N,(T)
TLNN N,777777
JRST IMGER1
CHKIM1: JUMPL N,CHKIM2
PUSHJ P,STRETT
TLNN N,777777
JRST IMGER1
CHKIM2: HLRE B,N
MOVM B,B
CAILE B,^D132
JRST IMGER2
MOVEI X2,(B)
HRLI N,440700
PUSHJ P,MASTST ;CHECK ENOUGH SPACE
AOS T1,MASAPP ;SAVE ORIGINAL AND CURRENT POINTERS
MOVEM N,(T1) ;ON MASAPP TO PROTECT THEM FROM
PUSHJ P,MASTST ;CHECK ENOUGH SPACE
AOS T1,MASAPP ;SHIFTING CORE.
MOVEM N,(T1)
SETO T1,
POP P,X1
PUSH P,B
PUSH P,X2
PUSH P,T1
JRST (X1)
IMGLIN: SETZM 40
PUSHJ P,PRDLER
MOVE G,HPOS(LP) ;END LINE IF NECESSARY.
ADD G,TABVAL(LP)
JUMPN G,CHKIM3
SKIPE G,MARWAI(LP)
MOVEM G,MARGIN(LP)
PUSHJ P,NUMINS
JRST CRLF1
CHKIM3: JUMPE LP,CKLAB1
CAIN G,^D6
SKIPL WRIPRI-1(LP)
CKLAB1: JRST CKLAB2
POPJ P,
CKLAB2: PUSH P,X2
PUSHJ P,PCRLF
JUMPN LP,CKLAB3
OUTPUT
CKLAB3: POP P,X2
POPJ P,
;MISC. UTILITY ROUTINES FOR USING STATEMENTS.
NXCHU: ILDB C,X1 ;GET NEXT CHAR OF IMAGE.
HLL C,CTTAB(C)
TRNE C,100
HRL C,CTTAB-100(C)
SOJ X2, ;DECREMENT COUNTER.
POPJ P,
SCNOUT: PUSH P,F ;OUTPUT A CHAR.
MOVE F,HPOS(LP)
CAIL F,^D132 ;USING MARGIN IS 132.
JRST SCNER3
POP P,F
JRST OUCH
IMGAPZ: JUMPN LEFT,CPOPJ1 ;USED BY IMGAPS.
JUMPN EXTEND,CPOPJ1
JUMPN RIGHT,CPOPJ1
JUMPN CENTER,CPOPJ1
POPJ P,
;SCNIMG LOOKS FOR NEXT FIELD.
;X1 IS A FLAG THAT PREVENTS LOOPING IF AN IMAGE WITH NO FIELDS IS SEEN.
SCNIMN: TDZA A,A ;ARG IS NUMBER.
SCNIMS: SETO A, ;ARG IS STRING.
POP P,X1
POP P,T1
POP P,X2
POP P,B
PUSH P,X1
MOVE X1,MASAPP ;RETRIEVE CURRENT POINTER.
MOVE X1,(X1)
SCNIM1: JUMPN X2,SCNIM2 ;CHAR LEFT IN IMAGE?
JUMPN T1,SCNER1 ;NO--ANY FIELDS SEEN?
MOVE X1,MASAPP ;YES, OKAY. O'E, FAIL.
MOVE X1,-1(X1) ;MOVE PNTR AND
MOVE X2,B ;CHAR COUNT BACK TO BEGINNING.
SETO T1,
PUSH P,X2
PUSHJ P,PCRLF ;END LINE, BEGIN NEW LINE.
JUMPN LP,SILAB1
OUTPUT
SILAB1: POP P,X2
SCNIM2: PUSHJ P,NXCHU
SCNIM0: TLNN C,F.APOS
JRST SCNIM3
JUMPE A,SCNER2 ;APOS SEEN, BETTER BE STR ARG.
SETZ T1,
PUSHJ P,IMGAPS
SCNEND: MOVE A,MASAPP ;PROTECT POINTER.
MOVEM X1,(A)
POP P,X1
PUSH P,B
PUSH P,X2
PUSH P,T1
JRST (X1) ;BACK TO USER CODE.
SCNIM3: PUSHJ P,SCNIM6
JRST SCNIM1
JRST SILAB2
JRST SCNIM0
SILAB2: JUMPN A,SCNER2
SETZ T1,
PUSHJ P,IMGPND
JRST SCNEND
SCNIM6: TLNN C,F.DOLL+F.STAR
CAMN C,[XWD F.STR,43]
JRST SCNIM4
SCNM35: JRST SCNOUT ;PRINTABLE CHAR.
SCNIM4: JUMPE X2,SCNOUT
MOVE G,C
PUSHJ P,NXCHU
CAMN C,G
JRST CPOPJ1
EXCH C,G
PUSHJ P,SCNOUT
MOVE C,G
POP P,G
JRST 2(G)
;ENDIMG ENDS A USING STATEMENT.
ENDIMG: POP P,C
POP P,T1
POP P,X2
POP P,B
PUSH P,C
MOVE X1,MASAPP
MOVE X1,(X1)
ENDIM3: JUMPE X2,ENDIM1 ;OUTPUT PRINTABLE CHARS
PUSHJ P,NXCHU ;UP TO THE NEXT FIELD.
ENDIM0: TLNE C,F.APOS
JRST ENDIM1
PUSHJ P,SCNIM6
JRST ENDIM3
JRST ENDIM1
JRST ENDIM0
ENDIM1: PUSHJ P,PCRLF ;END LINE.
ENDIM2: JUMPN LP,EILAB1
OUTPUT
EILAB1: SETZM FMTPNT(LP)
SETOM ZONFLG(LP)
SOS MASAPP
SOS MASAPP
POPJ P,
;IMGAPS ANALYZES STR FIELD AND OUTPUTS STR.
CENTER=G
EXTEND=E
LEFT=D
RIGHT=R
IMGAPS: TLNN N,777777 ;GET OUTPUT STR KEY.
JRST IMGA1
TLNE N,377777
JRST IMGAP1
MOVE T,N
MOVE N,(T)
JRST IMGAPS
IMGAP1: JUMPLE N,IMGA1
PUSHJ P,STRETT
IMGA1: SETZB CENTER,EXTEND ;CLEAR FLAGS.
SETZB LEFT,RIGHT
IMGAP0: JUMPE X2,IMGAP4 ;FIND C, E, L, AND R'S.
MOVE F,X1
PUSHJ P,NXCHU
TLNE C,F.LETT
JRST IMGAP2
IMGP01: MOVE X1,F
AOJA X2,IMGAP4
IMGAP2: TLZ C,777777
CAIE C,"L"
JRST IMGA21
JUMPN LEFT,IALAB1
PUSHJ P,IMGAPZ
IALAB1: AOJA LEFT,IMGAP0
IMGA21: CAIE C,"E"
JRST IMGA22
JUMPN EXTEND,IALAB2
PUSHJ P,IMGAPZ
IALAB2: AOJA EXTEND,IMGAP0
IMGA22: CAIE C,"C"
JRST IMGP23
JUMPN CENTER,IALAB3
PUSHJ P,IMGAPZ
IALAB3: AOJA CENTER,IMGAP0
IMGP23: CAIE C,"R"
JRST IMGP01
JUMPN RIGHT,IALAB4
PUSHJ P,IMGAPZ
IALAB4: AOJA RIGHT,IMGAP0
JRST IMGP01
IMGAP4: JUMPE LEFT,IALAB5
IMGA41: AOJA LEFT,IMGAP5
IALAB5: JUMPE EXTEND,IALAB6
AOJA EXTEND,IMGAP5
IALAB6: JUMPE CENTER,IALAB7
AOJA CENTER,IMGAP5
IALAB7: JUMPE RIGHT,IMGA41
AOJA RIGHT,IMGAP5
IMGAP5: HLRE F,N ;HAVE ANALYZED FIELD.
MOVM F,F
HRLI N,440700 ;GET PTR AND CHAR COUNT FOR ARG
SKIPN T,LEFT ;IN N AND F.
SKIPE T,EXTEND
JRST IALAB8
SKIPN T,CENTER
MOVE T,RIGHT
IALAB8: CAIGE F,(T)
JRST IMGAP6
JUMPN EXTEND,IMGP51 ;OVERFLOW.
MOVEI F,(T)
IMGP51: ILDB C,N
PUSHJ P,SCNOUT
SOJG F,IMGP51
POPJ P,
IMGAP6: SUBI T,(F)
JUMPE CENTER,IMGAP7 ;CENTER.
IDIVI T,2
ADDI T1,(T)
JUMPE T,IMGP61
MOVEI C," "
IALABA: PUSHJ P,SCNOUT
SOJG T,IALABA
IMGP61: MOVEI T,(T1)
SETZ T1, ;RESTORE FLAG.
JRST IMGAP8
IMGAP7: JUMPE RIGHT,IMGAP8 ;RIGHT.
JUMPE T,IMGP71
MOVEI C," "
IALABB: PUSHJ P,SCNOUT
SOJG T,IALABB
IMGP71: JUMPE F,IMGP82
JRST IMGP51
IMGAP8: JUMPE F,IMGP81 ;LEFT OR EXTEND.
IALABC: ILDB C,N
PUSHJ P,SCNOUT
SOJG F,IALABC
IMGP81: JUMPE T,IMGP82
MOVEI C," "
IALABD: PUSHJ P,SCNOUT
SOJG T,IALABD
IMGP82: POPJ P,
;IMGPND ANALYZES NUM FIELD AND THEN CALLS IMGINT, IMGDEC, OR IMGEXP.
COMMA=G
EXPON=E
LCOUNT=D
RCOUNT=R
IMGPND: MOVEI LCOUNT,2 ;SET UP FLAGS.
SETZB COMMA,EXPON
SETZB RCOUNT,TRAIL
MOVEM C,LEAD ;SAVE TYPE OF FIELD.
IMGPN2: JUMPE X2,IMGINT ;SORT THRU #,$, *, AND COMMAS
MOVE F,X1 ;IN LH OF FIELD.
PUSHJ P,NXCHU
CAME C,[XWD F.STR,43]
CAMN C,LEAD
AOJA LCOUNT,IMGPN2
TLNN C,F.COMA
JRST IMGP21
SETO COMMA,
AOJA LCOUNT,IMGPN2
IMGP21: TLNE C,F.PER ;NOT LH ANYMORE; DEC PT?
JRST IMGPN3
TLNE C,F.MINS ;-?
JRST IMGP22
MOVE X1,F
AOJA X2,IMGINT
IMGP22: SETOM TRAIL
JRST IMGINT
IMGPN3: JUMPE X2,IMGDEC ;MUST BE DEC OR EXP FIELD, SINCE ".".
MOVE F,X1
PUSHJ P,NXCHU
CAME C,[XWD F.STR,43] ;SORT THRU #,$,*, AND COMMAS IN RH.
CAMN C,LEAD
AOJA RCOUNT,IMGPN3
TLNN C,F.COMA
JRST IMGP31
SETO COMMA,
AOJA RCOUNT,IMGPN3 ;-?
IMGP31: TLNN C,F.MINS
JRST IALABE
SETOM TRAIL
JRST IMGDEC
IALABE: CAIN C,"^" ;POSSIBLY EXPON?
JRST IMGP32
MOVE X1,F
AOJA X2,IMGDEC
IMGP32: MOVEI EXPON,1
IMGPN4: JUMPN X2,IMGP41 ;REALLY 4 UP-ARROWS?
ADDI X2,(EXPON)
IMGP40: SUBI EXPON,5
IALABF: IBP X1
AOJL EXPON,IALABF
HRRI X1,-1(X1)
JRST IMGDEC
IMGP41: PUSHJ P,NXCHU
CAIE C,"^"
AOJA EXPON,IMGP40 ;NOT REALLY EXPON FIELD.
AOJ EXPON,
CAIGE EXPON,4
JRST IMGPN4
JUMPE X2,IMGEXP ;SEEN 4 UP-ARROWS.
MOVE F,X1
PUSHJ P,NXCHU
TLNE C,F.MINS ;ALSO -?
JRST IALABG
MOVE X1,F
AOJA X2,IMGEXP
IALABG: SETOM TRAIL
JRST IMGEXP
;IMGINT OUTPUTS NUMBER WITHOUT DECIMAL POINT AND WITHOUT EXPON.
IMGINT: PUSH P,[Z IMGIN3]
IMG0: MOVE C,LEAD ;IF THE NO. WILL BE MINUS AND
CAMG N,MINONE ;THE SIGN LEADS AND THE FIELD IS
SKIPE TRAIL ;* OR $, FAIL BECAUSE ILLEGAL.
JRST IALABH
TLNE C,F.DOLL+F.STAR
JRST IMGER4
IALABH: MOVEI F,(LCOUNT) ;F = NO. OF PLACES FOR DIGITS AND COMMAS.
TLNE C,F.DOLL
SOJA F,CPOPJ ;$ TAKES ONE PLACE.
SKIPN TRAIL
CAME C,[XWD F.STR,43]
POPJ P,
SOJA F,CPOPJ
IMGIN3: MOVE A,N ;A HAS ARG.
MOVM N,N ;N HAS /ARG/.
CAML N,ONE
JRST IMGN31
MOVEI C,1 ;ANSWER IS 0.
SETZ COMMA,
SETZB N,A
JRST IMGIN7
IMGN31: PUSH P,[Z IMGIN1]
IMGDE2: SETZ C,
FAD N,FIXCON
FSB N,FIXCON
JUMPE N,CPOPJ
IMGD10: CAMG N,D1E14
JRST IMGD11
ADDI C,^D14
FDVR N,D1E14
JRST IMGD10
IMGD11: MOVEI T,^D14
IALABI: CAML N,DECTAB(T)
JRST IMGD12
SOJGE T,IALABI
SETZ T,
MOVE N,DECTAB
IMGD12: ADDI C,1(T)
POPJ P,
IMGIN1: FDVR N,DECTAB(T)
FMPR N,DECTAB+8 ;FORCE 9 DIGITS.
CAMGE N,DECTAB+8
MOVE N,DECTAB+8
CAMGE N,DECTAB+9
JRST IMGN44
MOVE N,DECTAB+8
AOJ C,IMGN44
IMGN44: MOVE T,N
MULI T,400
ASH T1,-243(T)
MOVE N,T1
PUSH P,[Z IMGIN7]
IMG1: JUMPE COMMA,IMGIN5 ;COMMA BECOMES NO. OF ,'S TO BE OUTPUT.
MOVEI T,-1(C)
IDIVI T,3
MOVEI COMMA,(T)
IMGIN5: MOVEI T,(COMMA) ;CHECK TO SEE IF IT OVERFLOWS THE FIELD.
ADDI T,(C)
CAIG T,(F)
POPJ P,
PUSH P,C
JUMPL A,IMGIN6
SKIPE TRAIL
JRST IMGIN6
MOVE C,LEAD
CAME C,[XWD F.STR,43]
JRST IMGIN6
CAIG T,1(F)
JRST IMGN76
IMGIN6: MOVEI C,"&" ;OVERFLOWS THE FIELD.
PUSHJ P,SCNOUT
EXCH T,LCOUNT ;WIDEN FIELD.
CAIN T,(F)
JRST IMGN76
MOVE C,LEAD
TLNE C,F.DOLL
JRST IMGN73
CAME C,[XWD F.STR,43]
JRST IMGN76
JUMPGE A,IMGN76
IMGN73: AOJA LCOUNT,IMGN76
IMGN76: POP P,C
POPJ P,
IMGIN7: PUSH P,[Z IMGIN8]
IMG2: MOVEI T,(LCOUNT) ;OUTPUT EVERYTHING BEFORE THE DIGITS.
MOVEI T1,(C)
ADDI T1,(COMMA)
SUBI T,(T1) ;T = LEADING PLACES.
MOVE T1,LEAD
CAMN T1,[XWD F.STR,43]
JRST IMGN71
TLNE T1,F.DOLL
JRST IMGN72
JUMPE T,CPOPJ ;* FIELD.
PUSH P,C
MOVEI C,"*"
IALABJ: PUSHJ P,SCNOUT
SOJG T,IALABJ
POP P,C
POPJ P,
IMGN71: JUMPE T,CPOPJ ;# FIELD.
SKIPN TRAIL
JUMPL A,IMGN74
PUSH P,C
MOVEI C," "
IALABK: PUSHJ P,SCNOUT
SOJG T,IALABK
POP P,C
POPJ P,
IMGN72: SKIPA T1,[777777777777] ;$ FIELD.
IMGN74: MOVEI T1,0
PUSH P,C
SOJLE T,IMGN75
MOVEI C," "
IALABL: PUSHJ P,SCNOUT
SOJG T,IALABL
IMGN75: MOVEI C,"-"
JUMPE T1,IALABM
MOVEI C,"$"
IALABM: PUSHJ P,SCNOUT
POP P,C
POPJ P,
IMGIN8: JUMPN N,IMGN81 ;NOW OUTPUT DIGITS.
PUSH P,C
MOVEI C,"0"
PUSHJ P,SCNOUT
POP P,C
JRST IMGIN9
IMGN81: PUSH P,[Z IMGIN9]
INTOUT: JUMPE COMMA,IMGN80 ;GENERAL OUTPUT ROUTINE FOR DIGITS AND COMMAS.
MOVEI T,-1(C) ;AT ENTRY, C= NO. OF DIGITS REQ,
IDIVI T,3 ;N=/NUMBER/, COMMA=0 UNLESS ,'S TO BE OUTPUT.
IMULI T,3 ;T, T1, AND N ARE DESTROYED.
MOVEI T1,(C)
SUBI T1,(T) ;N.B. - N HAS THE LEADING DIGITS.
IMGN80: MOVE T,N
MOVE N,T1
PUSH P,C
PUSH P,A
MOVEI A,(C)
PUSHJ P,IALABN
JRST IMGN84
IALABN: IDIVI T,^D10
JUMPE T,IMGN82
PUSH P,T1
PUSHJ P,IALABN
POP P,T1
IMGN82: JUMPE COMMA,IMGN87
JUMPLE A,IMGN87
JUMPN N,IMGN83
MOVEI C,","
PUSHJ P,SCNOUT
MOVEI N,3
IMGN83: SOJ N,
IMGN87: SOJL A,IALABO
MOVEI C,60(T1)
PUSHJ P,SCNOUT
IALABO: POPJ P,
IMGN84: JUMPLE A,IMGN86
IMGN89: JUMPE COMMA,IMGN88
JUMPN N,IMGN85
MOVEI C,","
PUSHJ P,SCNOUT
MOVEI N,3
IMGN85: SOJ N,
IMGN88: MOVEI C,"0"
PUSHJ P,SCNOUT
SOJG A,IMGN89
IMGN86: POP P,A
POP P,C
POPJ P,
IMGIN9: SETZ T1, ;RESTORE FLAG.
SKIPN TRAIL
POPJ P,
MOVEI C," " ;OUTPUT TRAILING SIGN.
JUMPGE A,IALABP
MOVEI C,"-"
IALABP: JRST SCNOUT
;IMGDEC OUTPUTS NUMBERS WITH DECIMAL POINTS BUT WITHOUT EXPONENTS.
IMGDEC: PUSHJ P,IMG0 ;ERROR CHECKING AND CALC
;F=NO. OF PLACES FOR DIGITS AND COMMAS.
JUMPE N,IMGX16
PUSH P,N
MOVE A,N
PUSHJ P,IMGEX1
POP P,N
MOVSI T1,(0.5) ;ROUND.
JUMPG C,IMGD34
CAILE RCOUNT,9
JRST IMGD21
IMGD20: FDVR T1,DECTAB(RCOUNT)
JRST IMGD26
IMGD21: MOVM C,C
ADDI C,9
CAILE C,(RCOUNT)
JRST IMGD20
IMGD31: CAIG C,^D14
JRST IMGD32
FDVR T1,D1E14
SUBI C,^D14
JRST IMGD31
IMGD32: FDVR T1,DECTAB(C)
JRST IMGD26
IMGD34: ADDI C,(RCOUNT)
CAIGE C,9
JRST IMGD20
SUBI C,9(RCOUNT)
JUMPGE C,IMGD27
MOVM C,C
JRST IMGD32
IMGD27: CAIG C,^D14
JRST IMGD28
FMPR T1,D1E14
SUBI C,^D14
JRST IMGD27
IMGD28: FMPR T1,DECTAB(C)
IMGD26: MOVM N,N
FAD N,T1
JUMPL A,IALABQ
SKIPA A,N
IALABQ: MOVN A,N
PUSHJ P,IMGEX1
JUMPL C,IMGDE6
MOVEI T1,(RCOUNT)
ADDI T1,(C)
IMGD61: CAILE T1,9
MOVEI T1,9 ;T1 IS NO. OF DIGITS REQ.
JRST IMGD62
IMGDE6: MOVEI T1,1(RCOUNT)
ADD T1,C
JUMPGE T1,IMGD61
SETZ T1,
IMGD62: ADDI T,1
SUBI T,(T1)
JUMPE T,IMGD51
JUMPL T,IMGD52
FDVR N,DECTAB(T)
JRST IMGD51
IMGD52: MOVM T,T
FMPR N,DECTAB(T)
IMGD51: FAD N,FIXCON
FSB N,FIXCON
JUMPN T1,IALABR
SETZ N,
JRST IMGD53
IALABR: CAMGE N,DECTAB-1(T1)
MOVE N,DECTAB-1(T1)
CAMGE N,DECTAB(T1)
JRST IMGD53
MOVE N,DECTAB-1(T1)
AOJ C,
IMGD53: PUSH P,A
MOVEI A,(T1)
MOVE T,N
MULI T,400
ASH T1,-243(T)
MOVE T,T1
SETZB T1,N
JUMPLE C,IMGD64
CAIL C,(A)
JRST IMGD69
SUBI A,(C)
IDIV T,INTTAB(A)
MOVEI N,(A)
JUMPE T1,IMGD69
IALABT: CAMGE T1,INTTAB(A)
SOJA A,IALABT
SUBI N,1(A)
JRST IMGD69
IMGD64: MOVE T1,T
SETZ T,
MOVM N,C
CAILE N,(RCOUNT)
MOVEI N,(RCOUNT)
IMGD69: POP P,A
JUMPGE A,IMGDE7 ;CHECK AGAIN FOR NEG. * OR $ FIELD.
SKIPE TRAIL
JRST IMGDE7
PUSH P,N
MOVE N,LEAD
TLNE N,F.DOLL+F.STAR
JRST IALABU
POP P,N
JRST IMGDE7
IALABU: POP P,N
JUMPN T,IMGER4
JUMPN T1,IMGER4
IMGDE7: PUSH P,T1
PUSH P,N
JUMPG C,IALABV
MOVEI C,1
IALABV: PUSH P,T
PUSHJ P,IMG1
PUSHJ P,IMG2 ;OUTPUT EVERYTHING BEFORE THE DIGITS.
POP P,N
PUSHJ P,INTOUT ;OUTPUT LH DIGITS AND COMMAS.
MOVEI C,"."
PUSHJ P,SCNOUT
POP P,N
POP P,T
PUSHJ P,INTTRA ;OUTPUT RH SIDE.
JRST IMGIN9
IMGX16: SETZB COMMA,A ;ZERO ARG.
MOVEI C,1
PUSHJ P,IMG2 ;LEADING *,$, ETC.
PUSHJ P,IMGX17
JRST IMGIN9
;IMGEXP OUTPUTS NUMBERS WITH DECIMAL POINTS AND EXPONENTS.
IMGEXP: MOVE T,LEAD
TLNE T,F.STAR+F.DOLL
JRST IMGER3
JUMPE N,IMGEX8
MOVEI F,(LCOUNT) ;F= NO. OF PLACES FOR DIGITS IN LH.
SKIPN TRAIL
SOJ F,
JUMPE COMMA,IMGEX4
MOVEI T,-1(F)
IDIVI T,4
SUBI F,(T)
AOJ T,
IMULI T,3
CAILE F,(T)
MOVEI F,(T)
IMGEX4: MOVEI T1,(F)
ADDI T1,(RCOUNT)
CAILE T1,9
MOVEI T1,9
PUSH P,[Z IMGEX2]
MOVE A,N ;NUMBER TO A.
IMGEX1: MOVM N,N ;/NUMBER/ TO N.
SETZ C, ;C = TRUE EXPONENT.
IMGE51: CAMG N,D1E14
JRST IMGE50
ADDI C,^D14
FDVR N,D1E14
JRST IMGE51
IMGE50: CAML N,ONE
JRST IMGE52
SUBI C,^D14
FMPR N,D1E14
JRST IMGE50
IMGE52: MOVEI T,^D14
IALABW: CAML N,DECTAB(T)
JRST IMGE53
SOJGE T,IALABW
MOVE N,DECTAB
SETZ T,
IMGE53: ADDI C,1(T)
POPJ P,
IMGEX2: SUBI T,-1(T1)
JUMPE T,IMGE54
JUMPL T,IALABX
FDVR N,DECTAB(T)
JRST IMGE54
IALABX: MOVM T,T
FMPR N,DECTAB(T)
IMGE54: FADRI N,200400 ;ROUND.
FAD N,FIXCON
FSB N,FIXCON
PUSH P,[Z IMGEX9]
IMGDIV: CAMGE N,DECTAB-1(T1) ;GET LH AND RH IN
MOVE N,DECTAB-1(T1) ;T AND T1 IN FIXED POINT.
CAMGE N,DECTAB(T1)
JRST IMGEX7
MOVE N,DECTAB-1(T1)
AOJ C,IMGEX7
IMGEX7: MOVE T,N
CAIL F,(T1)
JRST IMGE71
PUSH P,A
MOVEI A,(T1)
SUBI A,(F)
MULI T,400
ASH T1,-243(T)
MOVE T,T1
IDIV T,INTTAB(A)
MOVEI N,(A)
JUMPE T1,IALABY
IALABZ: CAMGE T1,INTTAB(A)
SOJA A,IALABZ
SUBI N,1(A)
IALABY: POP P,A
POPJ P, ;T HAS LEADING NUMBER OF DIGITS.
IMGE71: MULI T,400 ;T1 HAS TRAILING NO. OF DIGITS.
ASH T1,-243(T)
MOVE T,T1 ;N HAS NO. OF LEADING ZEROES IN FRONT OF T1.
SETZB T1,N
POPJ P,
IMGEX9: SUBI C,(F)
CAIGE C,^D100
CAMG C,[-^D100]
JRST IALAB.
JRST IMGE91
IALAB.: PUSH P,C
MOVEI C,"&"
PUSHJ P,SCNOUT
POP P,C
IMGE91: SKIPE TRAIL
JRST IMGX10
PUSH P,C
MOVEI C," "
JUMPGE A,IALAB$
MOVEI C,"-"
IALAB$: PUSHJ P,SCNOUT
POP P,C
IMGX10: PUSH P,C
MOVEI C,(F) ;NO. OF DIGITS TO C.
PUSH P,T1
PUSH P,N
MOVE N,T ;N = NUMBER.
PUSHJ P,INTOUT
MOVEI C,"."
PUSHJ P,SCNOUT
POP P,N
POP P,T
PUSH P,[Z IMGX12]
INTTRA: JUMPE RCOUNT,CPOPJ ;OUTPUT RH SIDE.
JUMPLE N,INTTR0
MOVEI C,"0"
IALAB%: PUSHJ P,SCNOUT
SOJ RCOUNT,
SOJG N,IALAB%
JUMPE RCOUNT,CPOPJ
INTTR0: PUSHJ P,IALZB1
JRST INTTR2
IALZB1: IDIVI T,^D10
JUMPE T,INTTR1
PUSH P,T1
PUSHJ P,IALZB1
POP P,T1
INTTR1: SOJL RCOUNT,CPOPJ
MOVEI C,60(T1)
JRST SCNOUT
SOJA RCOUNT,CPOPJ
INTTR2: JUMPLE RCOUNT,CPOPJ
MOVEI C,"0"
IALZB2: PUSHJ P,SCNOUT
SOJG RCOUNT,IALZB2
POPJ P,
IMGX12: POP P,N
IMGX11: MOVEI C,"E" ;PRINT EXPONENT.
PUSHJ P,SCNOUT
MOVEI C,"+"
JUMPGE N,IALZB3
MOVEI C,"-"
IALZB3: PUSHJ P,SCNOUT
MOVM T,N
IDIVI T,^D10
CAIGE T,^D10
JRST IMGX13
PUSH P,T1
IDIVI T,^D10
MOVEI C,60(T)
PUSHJ P,SCNOUT
MOVE T,T1
POP P,T1
IMGX13: MOVEI C,60(T)
PUSHJ P,SCNOUT
MOVEI C,60(T1)
PUSHJ P,SCNOUT
JRST IMGIN9
IMGEX8: SOJ LCOUNT, ;EXP FIELD IS 0.
MOVEI C," "
IALZB4: PUSHJ P,SCNOUT
SOJG LCOUNT,IALZB4
PUSH P,[Z IMGE81]
IMGX17: MOVEI C,"0"
PUSHJ P,SCNOUT
MOVEI C,"."
PUSHJ P,SCNOUT
JUMPE RCOUNT,CPOPJ
MOVEI C,"0"
IALZB5: PUSHJ P,SCNOUT
SOJG RCOUNT,IALZB5
POPJ P,
IMGE81: SETZB N,A
JRST IMGX11
INTTAB: ^D1
^D10
^D100
^D1000
^D10000
^D100000
^D1000000
^D10000000
^D100000000
^D1000000000
;RESTORE DATA POINTER
RESTOR: PUSHJ P,RESTOS ;RESTORE BOTH NUMBERS 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: INLERR(57,52,</
? Out of DATA/>)
HRRZ T,L
JRST GOSR2
INLBSY(8,</
? Data file line too long/>)
INLBSY(9,</
? Illegal character in string/>)
FNMX0: MOVEI LP,(X1)
FNMXER: SKIPN ACTBL-1(LP)
JRST FNR
FNMX1: INLERR(32,10,</
? Mixed random & seq. access/>)
JRST GOSR2
PTXER2: INLERR(35,11,</
? Output item too long for line/>)
JRST GOSR2
IMP: INLERR(50,12,</
? Bad DATA/>)
JRST GOSR2
FNR: INLERR(9,13,</
? File never established - referenced/>)
JRST GOSR2
LKFAIL: INLERR(5,14,</
? Failure on lookup/>)
JRST GOSR2
ENFAIL: INLERR(4,15,</
? Failure on enter/>)
JRST GOSR2
ILWRT: CAIE X2,1
JRST ILWRT1
INLERR(10,16,<%
? Attempt to WRITE# or PRINT# to a file which is in READ# or INPUT# mode%>)
JRST GOSR2
ILWRT1: INLERR(10,17,<%
? Attempt to WRITE# or PRINT# to a file which has not been SCRATCH#ed%>)
JRST GOSR2
ILRD: CAIE X1,3
JRST ILRD1
INLERR(10,18,<%
? Attempt to READ# or INPUT# from a file which is in WRITE# or PRINT# mode%>)
JRST GOSR2
ILRD1: INLERR(9,19,<%
? Attempt to READ# or INPUT# from a file which does not exist%>)
JRST GOSR2
RANSRF: INLERR(36,53,</
? Cannot erase file on channel />)
RAN2: HRRZ T,LP
PUSHJ P,ERRXCX
PUSHJ P,PRTNUM
PUSHJ P,ERRXCY
JRST GOSR2
LOKFAL: SETZM ODF
INLERR(37,20,</
? File not found by RESTORE command/>)
JRST GOSR2
INLBSY(21,</
? EOF/>)
CHAERR: INLERR(28,22,</
? Line number/>)
JRST OUTBND
RNERR1: INLERR(41,23,</
? Mixed strings and numbers/>)
JRST GOSR2
RNERR2: INLERR(10,24,</
? Output string length greater than record length/>)
JRST GOSR2
RNERR3: INLERR(10,25,</
? File not in correct form/>)
JRST GOSR2
CHAER1: INLERR(2,26,</
? Illegal filename/>)
JRST GOSR2
WRPRER: INLERR(10,27,<"
? Mixed WRITE#/PRINT#">)
JRST GOSR2
SCNER1: INLERR(42,54,</
? No fields in image/>)
JRST GOSR2
SCNER2: INLERR(70,28,</
? Attempt to output a number to a string field or a string to a numeric field/>)
JRST GOSR2
SCNER3: INLERR(71,29,</
? Output line more than 132 characters/>)
JRST GOSR2
IMGER1: INLERR(72,55,</
? No characters in image/>)
JRST GOSR2
IMGER2: INLERR(73,30,</
? More than 132 characters in image/>)
JRST GOSR2
IMGER3: INLERR(74,31,</
? Exponent requested for * or $ field/>)
JRST GOSR2
IMGER4: INLERR(75,32,</
? Attempt to output a negative number to a * or $ field/>)
JRST GOSR2
MARERR: INLERR(76,33,</
? MARGIN too small/>)
JRST GOSR2
REINER: INLERR(10,34,<"
? Mixed READ#/INPUT#">)
JRST GOSR2
MARER1:INLERR(77,56,</
? MARGIN />)
OUTBND: INLERR(34,35,</ out of bounds/>)
JRST GOSR2
PAGERR: INLERR(78,36,</
? PAGE length/>)
JRST OUTBND
PLTERR: INLERR (79,68,</
? File opened TO PLOT/>)
JRST GOSR2
CNER1: INLERR(46,37,</
? Channel number is <1 or >9/>)
JRST GOSR2
;RUNTIME MAT INPUT ROUTINE
MATIN: SETZM IFIFG
PUSHJ P,DOINPT ;SETUP INPUT LOOP
HRRZ X1,40 ;GET VECTOR 2-WD BLOCK ADDRESS
HRRZ X2,(X1) ;GET ADDRESS OF FIRST ELEMENT
HRRZ T,1(X1) ;GET COL. DIM
SOJE T,MATINA ;ADJ COUNT UNLESS 0
ADDI X2,1(T) ;ELSE SKIP COL. 0
MATINA: MOVEM T,ELECT1 ;SET MASTER COUNT
MOVEM T,ELECT2 ;AND RUNNING COUNT
MOVEM X2,NUMRES ;SAVE THIS VALUE FOR COUNTING ELEMENTS LATER
HLRZ X1,(X1) ;GET MAXIMUM VECTOR SIZE
ADD X1,X2 ;UPPER BOUND OF VECTOR
SUBI X1,1
MOVEM X1,ELETOP ;SAVE FOR COMPARISON LATER
HRRM X2,40 ;SET UP ELEMENT ADDRESS FOR DATA ROUTINES
MATIN1: MOVEI X1,MATIN4 ;POINT "INPUT ERR" TO SPECIAL ROUTINE
HRL X1,ELECT2 ;GET CURRENT COUNT
HLRZM X1,ELECT3 ;REMEMBER IT
HRL X1,40 ;REMEMBER FIRST ELEMENT ON LINE
MOVEM X1,INPFLA
PUSHJ P,NXVINP ;INPUT THE LINE
MATIN5: JRST MILAB1 ;THERE IS ANOTHER ELEMENT.
JRST MATIN6 ;NULL LINE. NO MORE ELEMENTS.
MILAB1: HRRZ X1,40 ;MAY WE ACCEPT ANOTHER ELEMENT?
CAML X1,ELETOP
JRST MATIN3 ;NO
SKIPN ELECT1 ;VECTOR ?
JRST MTIN5A ;YES, SKIP MATRIX CODE
SOSL ELECT2 ;SKIP ELEMENT 0 ?
JRST MTIN5A ;NO
MOVE T,ELECT1 ;RESET THE COUNT
SOJ T, ;BACK OFF ONE
MOVEM T,ELECT2
AOS 40 ;DONT STORE IN ELEMENT 0
MTIN5A: AOS 40 ;POINT TO NEXT ELEMENT
PUSH P,[EXP MATIN2] ;YES. SETUP RETURN FROMDATA ROUTINE
CAML X1,SVRBOT ;NUMBER OR STRING VECTOR?
JRST SDATAE ;STRING
JRST DATAER ;NUMBER
MATIN2: TLNE C,F.CR ;END OF INPUT?
JRST MATIN6 ;YES, SET UP "NUM" FUNCTION AND RETURN.
CAIE C,"&"
JRST MATIN7
MOVE T,(R)
PUSHJ P,NXCH
TLNN C,F.CR
JRST INPERR
JRST MATIN1
MATIN7: TLNN C,F.COMA
JRST INPERR
MOVE T,(R)
PUSHJ P,NXCH
TLNE C,F.CR
JRST MATIN6
CAIE C,"&"
JRST MATIN5
PUSHJ P,NXCH
TLNN C,F.CR
JRST MATIN5
JRST MATIN1
MATIN3: NFERR (94,0)
PUSHJ P,INLMES
ASCIZ /
? Too many elements/
SKIPE CHAFL2
PUSHJ P,ERRMS3
PUSHJ P,INLMES
ASCIZ /-- retype line
/
JRST INPER1
MATIN4: HLRZ X1,INPFLA ;AN ERROR HAS OCCURRED. START LINE OVER
HRRM X1,40 ;WITH SAME ELEMENT
MOVE X1,ELECT3 ;GET REMEMBERED COUNT
MOVEM X2,ELECT2 ;AND RESTORE IT
JRST MATIN1
MATIN6: HRRZ X1,40 ;CALCULATE NUMBER OF ELEMENTS
SUB X1,NUMRES
MOVEM X1,NUMRES
POPJ P,
REDSTR: SKIPE INPFLA
JRST REDS9
TLNN C,F.LETT+F.QUOT
POPJ P,
REDS9: SKIPN IFIFG
SKIPN INPFLA
JRST REDS91
SKIPE INLNFG
JRST REDS91
TLNE C,F.COMA ;TEST FOR LEADING COMMA FOR INPUT.
POPJ P,
REDS91: AOS (P) ;THIS IS A LEGITIMATE STRING
PUSH P,G
PUSH P,E
SETOM VIRWRD ;GOING TO WRITE INTO VIRTUAL STRING (MAYBE)
PUSHJ P,SPVIRS ;SET UP F&G IF VIRTUAL STRING
JRST PVIRS1 ;NON SKIP RETURN MEANS VIRTUAL STRING
PUSHJ P,GETSTR
MOVEI N,(X1)
MOVE G,T
SETZ T,
PUSHJ P,VCHCKC ;MAKE SPACE
EXCH G,T
PVIRS1: SKIPN INLNFG ;DOING INPUT LINE?
JRST REDS41 ;NO, CONTINUE
MOVEI X1,F.CR ;ONLY END-OF LINE IS END
CLEARM INLNFG ;RESET FLAG
SETZM QUOFL1 ;CLEAR QUOTE FLAG
JRST REDS1 ;INPUT THE STRING
REDS41: SKIPN IFIFG
JRST REDS4
MOVEI X1,F.COMA+F.CR+F.SPTB+F.QUOT
JRST REDS3
REDS4: MOVEI X1,F.COMA+F.CR ;ASSUME A STRING WITHOUT QUOTES
SKIPN INPFLA
ADDI X1,F.APOS
REDS3: SETZM QUOFL1
TLNN C,F.QUOT ;IS IT A QUOT STRING?
JRST REDS1 ;NO
SETOM QUOFL1
MOVEI X1,F.QUOT+F.CR
PUSHJ P,NXCHD ;SKIP QUOTE
REDS1: SETZ X2,
SKIPE VIRSIZ ;VIRTUAL STRING?
JRST REDS2 ;YES. SKIP THIS STUFF
MOVE X2,N
SKIPE (X2) ;NEW STRING?
SETZM VPAKFL ;NO, GARBAGE NOW EXISTS
SETZ X2, ;INITIALIZE COUNT.
HRRI F,(G) ;GET FREE LOCATION
PUSH P,T
MOVE T,N
HRRM F,(T)
POP P,T
REDS2: TLNN C,(X1)
JRST REDS6
SKIPE QUOFL1
JRST REDQOT
TLNN C,F.QUOT
JRST REDS8
REDS7: POP P,E
POP P,G
SOS (P)
POPJ P,
REDQOT: TLNN C,F.QUOT
JRST REDS7
PUSHJ P,NXCHD
JRST REDS8
REDS6: CAMG X2,[-^D132] ;STRING TOO LONG ?
JRST [INLEMS(7,2,OPNER4)
JRST GOSR2]
IDPB C,F ;STORE A CHAR
PUSHJ P,NXCHD
SOJA X2,REDS2 ;COUNT THE CHAR
REDS8: HRRZ X1,F ;GET NEW FREE LOCATION
POP P,E
SKIPE VIRSIZ ;VIRTUAL STRING?
JRST REDS84 ;YES. JUST RETURN
MOVE G,N
JUMPN X2,REDS82
SETZM (G)
JRST REDS84
REDS82: HRLM X2,(G)
AOJ X1,
HRRM X1,VARFRE
REDS84: POP P,G
POPJ P,
SSKIP: SKIPE INPFLA ;IS THIS INPUT OR READ?
JRST INPERR ;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 -10(X1) ;YES. FORCE DATA SEARCH
JRST -7(X1) ;RETURN TO DATAER OR SDATAE
SUBTTL RUN-TIME ROUTINES FOR PRINTING
FINPNT: MOVE X1,FMTPNT(LP) ;FINISH WITH CR?
CAIE X1,1
POPJ P,
SETOM ZONFLG(LP)
PUSHJ P,PCRLF
FINPT4: JUMPN LP,FPLAB1
OUTPUT
FPLAB1: POPJ P,
PCRLF: MOVEI C,15 ;ROUTINE TO END A LINE AND
PUSHJ P,OUCH ;POSSIBLY BEGIN A NEW LINE.
MOVEI C,12
PUSHJ P,OUCH
PCRLF3: SETZM TABVAL(LP)
SETZM HPOS(LP)
SKIPG C,PAGLIM(LP)
JRST PCRLF2
AOS PAGCNT(LP)
CAME C,PAGCNT(LP)
JRST PCRLF2
MOVEI C,14
PUSHJ P,OUCH
SETZM HPOS(LP)
SETZM PAGCNT(LP)
PCRLF2: SKIPE C,MARWAI(LP)
MOVEM C,MARGIN(LP)
PCRLF1: JUMPE LP,FINPT3
MOVE C,MARGIN(LP)
CAIL C,^D7
JRST FINPT3
SKIPGE WRIPRI-1(LP)
JRST MARERR
FINPT3: HRRZ X2,(P)
CAIE X2,FINPT4
CAIN X2,CRLF8
POPJ P,
CAIE X2,ENDIM2
PUSHJ P,NUMINS
POPJ P,
CRLF: MOVE C,HPOS(LP) ;ROUTINE USED BY "EMPTY" OUTPUT
ADD C,TABVAL(LP) ;STATEMENTS, AND RESTORE AND UXIT.
JUMPE C,CRLF4
JUMPE LP,CRLF5
CAIN C,^D6
SKIPL WRIPRI-1(LP)
JRST CRLF5
JRST CRLF3
CRLF5: PUSHJ P,PCRLF
CRLF8: JRST CRLF2
CRLF4: PUSHJ P,PCRLF2
CRLF3: MOVEI C,15
PUSHJ P,OUCH
MOVEI C,12
PUSHJ P,OUCH
SETZM TABVAL(LP)
SETZM FMTPNT(LP)
SKIPG T,PAGLIM(LP)
JRST CRLF2
AOS PAGCNT(LP)
CAME T,PAGCNT(LP)
JRST CRLF2
MOVEI C,14
PUSHJ P,OUCH
SETZM PAGCNT(LP)
CRLF2: SETZM HPOS(LP)
CRLF1: SETZM TABVAL(LP)
SETZM FMTPNT(LP)
JUMPN LP,CRLAB1
OUTPUT
CRLAB1: SETOM FIRSFL(LP)
POPJ P,
;RUN-TIME NUMBER PRINTER
PRNMER: MOVE X1,40 ;GET UUO
SETZM FTYPE ;ASSUME REAL
TLZE X1,400 ;IS IT?
SETOM FTYPE ;NO, MARK AS INTEGER
MOVEM X1,40 ;PUT BACK LESS INTEGER BIT
PUSHJ P,TABBR
PUSHJ P,FIRCHK
SKIPGE TABVAL(LP)
PUSHJ P,PCRLF
PUSHJ P,NUMINS
MOVE N,@40 ;GET THE NUMBER
SKIPGE FTYPE ;IS IT REAL
PUSHJ P,FLTPNT ;NO, FLOAT IT
PUSHJ P,OUTNUM
AOS TABVAL(LP) ;CAUSE A SPACE TO FOLLOW NUMBER.
SETZM ZONFLG(LP)
JRST FINPNT
;RUN-TIME TAB PRINTER
PRNTBR: PUSHJ P,TABBR
PUSHJ P,FIRCHK
SKIPGE B,TABVAL(LP) ;IGNORE ZERO AND MINUS TABS.
PUSHJ P,PCRLF
JUMPL N,FINPNT
PUSHJ P,NUMINS
MOVE X1,N
MOVE N,MARGIN(LP)
IDIV X1,N
SUB X2,HPOS(LP)
SUB X2,TABVAL(LP)
JUMPL X2,FINPNT
ADDM X2,TABVAL(LP)
SETOM ZONFLG(LP)
JRST FINPNT
;RUNTIME DELIMITER SPACING ROUTINE.
PRDLER: SKIPE X1,FMTPNT(LP)
CAIN X1,4
SETOM ZONFLG(LP)
PUSHJ P,TABBR
SKIPGE TABVAL(LP)
PUSHJ P,PCRLF
PUSHJ P,NUMINS
PUSHJ P,FIRCHK
JRST FINPNT
FIRCHK: SKIPN FIRSFL(LP)
JRST FCLAB1
PUSHJ P,PCRLF1
SETZM FIRSFL(LP)
FCLAB1: SKIPN T,HPOS(LP)
JRST MARCH2
JUMPE LP,CPOPJ
CAIN T,^D6
SKIPL WRIPRI-1(LP)
POPJ P,
MARCH2: SKIPE T,MARWAI(LP)
MOVEM T,MARGIN(LP)
POPJ P,
NUMINS: JUMPE LP,CPOPJ
SKIPGE WRIPRI-1(LP) ;NEED A LINE NUMBER?
SKIPE HPOS(LP)
POPJ P, ;NO.
MOVEI X2,12 ;YES.
ADDB X2,LINNUM-1(LP)
CAILE X2,^D99999
JRST NUMLRG
PUSH P,T
MOVE T,@OUTCNT-1(LP)
JUMPLE T,NUMIN2
IDIVI T,5
JUMPE T1,NUMIN2
NILAB1: SETZ C, ;PAD WITH NULLS SO THAT THE LINE
PUSHJ P,OUCH ;NUMBER STARTS IN A NEW WORD.
SOJG T1,NILAB1
NUMIN2: MOVE T,LINNUM-1(LP)
SETZM NUMCOT
PUSHJ P,PRTNUM
MOVEI T,5
MOVEM T,HPOS(LP)
MOVE T,NUMCOT
SUBI T,5
MOVE T1,@OUTPT-1(LP)
MOVE T1,(T1)
JUMPE T,NUMIN3
NUMIN4: LSH T1,-7 ;PAD WITH LEADING ZEROES (RE-
TLO T1,300000 ;QUIRED BY THE LINED CUSP).
IBP @OUTPT-1(LP)
SOS @OUTCNT-1(LP)
AOJL T,NUMIN4
NUMIN3: TRO T1,1 ;SET THE "SEQ. NO." BIT.
MOVE T,@OUTPT-1(LP)
MOVEM T1,(T)
POP P,T
MOVEI C,11 ;TAB.
PUSHJ P,OUCH
POPJ P,
NUMLRG: PUSHJ P,TTYIN
INLERR(80,38,</
? Attempt to write a line number greater than 99999/>)
JRST GOSR2
;TAB CONTROL
;"TABBR" ANALYSES THE LAST FORMAT CHARACTER USING "TABB0", "TABB1", AND
;"TABB3", WHICH HANDLE THE <PA>, COMMA, AND SEMICOLON, RESPECTIVELY.
;"TABVAL" CONAINS THE NUMBER OF SPACES WAITING TO BE TYPED OUT
;(OR IS NEGATIVE IF A <RETURN> MUST FOLLOW.)
CHROOM: MOVE B,TABVAL(LP)
ADD X1,B ;TOTAL SPACE NEEDED FOR FIELD
ADD X1,HPOS(LP)
CAML X1,MARGIN(LP)
JRST PCRLF ;NO ROOM, GO TO NEXT LINE.
JUMPL B,PCRLF
JUMPE B,CPOPJ ;NO SPACING TO DO.
COLAB1: MOVEI C," " ;HERE TO PUT OUT SPACES
PUSHJ P,OUCH
SOJG B,COLAB1
SETZM TABVAL(LP)
POPJ P,
TABBR: LDB X1,[POINT 4,40,12]
EXCH X1,FMTPNT(LP) ;GET OLD POSITION AND SAVE NEW FORMAT
SKIPGE A,TABVAL(LP)
POPJ P,
ADD A,HPOS(LP)
JRST .+1(X1)
POPJ P, ;NO FMT CHAR
POPJ P, ;<CR> WAS TYPED WHEN FIRST SEEN.
JRST TABB3 ;SEMICOLON
JRST TABB1 ;COMMA
TABB0: PUSH P,FMTPNT(LP) ;<PA>
PUSHJ P,PAGE1
POP P,FMTPNT(LP)
POPJ P,
TABB1: MOVE X1,MARGIN(LP)
JUMPE LP,TBLAB1
SKIPGE WRIPRI-1(LP) ;FIRST ZONE STARTS AFTER LINE NUMBER.
SUBI X1,6
TBLAB1: IDIVI X1,^D14
SUBI X1,1
IMULI X1,^D14
JUMPE LP,TBLAB2
SKIPGE WRIPRI-1(LP)
SUBI A,6
TBLAB2: CAMLE A,X1
JRST SETCR
IDIVI A,^D14
JUMPE B,TBLAB3
SETOM ZONFLG(LP)
JRST TABB2
TBLAB3: SKIPN ZONFLG(LP)
JRST TBLAB4
MOVEI B,^D14
JRST TABB31
TBLAB4: SETOM ZONFLG(LP)
POPJ P,
TABB2: SUBI B,^D14
MOVNS B
TABB31: ADDM B,TABVAL(LP)
POPJ P,
TABB3: MOVE X1,MARGIN(LP)
CAML A,X1
JRST SETCR
POPJ P,
SETCR: SETOM TABVAL(LP) ;FORCE <RETURN TO BE NEXT>
POPJ P,
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,(X1)
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: CLEARM FTYPE ;ASSUME REAL VECTOR
CAILE X1,6 ;IS VECTOR REAL?
SETOM FTYPE ;NO, MARK AS INTEGER
HRRZ F,@40 ;THE LEFT SIDE OF (F) IS ZERO
MOVE G,(F) ;GET VECTOR LENGTH
JUMPL G,GETVF ;NEGATIVE?
SKIPGE FTYPE ;IS IT ALREADY AN INTEGER?
JRST GETVIN ;YES, DON'T FIX IT
FAD G,FIXCON ;FIX THE LENGTH
TLZ G,777400
GETVIN: HLRZ X1,@40 ;DOES THE LENGTH EXCEED VECTOR BOUNDS?
MOVNS G
ADD X1,G
JUMPLE X1,GETVF
SKIPGE FTYPE ;REAL VECTOR?
TLO F,1 ;NO, MARK AS INTEGER
AOJA F,CPOPJ ;NO. POINT TO FIRST "CHAR" AND RETURN
GETVF: INLERR(81,39,</
? Impossible vector length/>)
JRST GOSR2
;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
SKIPGE FTYPE ;IS VECTOR INTEGER?
JRST GETEIN ;YES, NO FIXING NEEDED
PUSH P,R
LDB R,[POINT 8,C,8] ;GET EXPONENT
TLZ C,777000 ;TURN IT OFF
LSH C,-233(R) ;SHIFT INTO INTEGER POSTION
POP P,R
GETEIN: CAIGE C,^D128
CAIGE C,0
JRST GETELF
CAIG C,^D13
CAIGE C,^D10
AOJA F,CPOPJ1
SKIPN CRTVAL ;ARE 10-13 LEGAL?
JRST GETELF ;NO, GIVE AN ERROR
AOJA F,CPOPJ1 ;BUMP ELEMENT POINTER AND RETURN
GETELF: INLERR(82,40,</
? Illegal char seen/>)
JRST GOSR2
;ROUTINE TO STORE "NUMERIC" CHARS INTO A STR.
STRCHA: CLEARM FTYPE ;ASSUME VECTOR IS REAL
TLZE F,1 ;IS IT?
SETOM FTYPE ;NO, MARK AS INTEGER
PUSH P,F
PUSH P,G
SETOM VIRWRD ;MAY DO A VIRTUAL STR WRITE
PUSHJ P,SPVIRS ;CHECK IF 40 POINTS TO VIRTUAL ROLL ETC.
JRST [POP P,G
POP P,F
MOVE T,VIRWRD
JRST STRCH1]
POP P,G
POP P,F
PUSHJ P,PNTADR
MOVM T,G ;GETVEC SET UP F AND G.
PUSH P,X1
PUSHJ P,VCHCKC
POP P,X1
SKIPE (X1)
SETZM VPAKFL
MOVEM T,(X1)
HRLM G,(X1)
HRLI T,440700
STRCH1: PUSHJ P,GETEL
JRST CPOPJ
IDPB C,T
JRST STRCH1
;ROUTINE TO MOVE "STRING" CHARS INTO A VECTOR
PUTVEC: CLEARM FTYPE ;ASSUME VECTOR IS REAL
CAILE X1,6 ;ARE WE RIGHT?
SETOM FTYPE ;NO, MARK AS INTEGER
PUSH P,40
SETZM VIRWRD
MOVE X1,N
PUSHJ P,CKVSTR
MOVE N,X1
POP P,40
TLNN N,777777
JRST PUTV3
TLNE N,377777
JRST PUTV2
MOVE T,N
MOVE N,(T)
JRST PUTV3
PUTV2: JUMPLE N,PUTV3
PUSHJ P,STRETT
PUTV3: HLRE G,N
HRRZ F,N
HRLI F,440700
HRRZ X1,40
HRRZ N,(X1) ;SAVE FIRST LOC ADDRESS FOR LENGTH STORE
HLRZ X2,(X1) ;GET SIZE
HRRZ X1,(X1)
PUTV1: JUMPE G,PUTV9 ;GET CHAR.
ILDB C,F
AOJ G,
SOJL X2,PUTVF ;ROOM FOR ANOTHER CHAR?
SKIPGE FTYPE ;IS RECEIVING VECTOR REAL
JRST PUTV4 ;NO, THEN DON'T FLOAT IT
TLO C,233400 ;YES. FLOAT IT
FSB C,FIXCON
PUTV4: MOVEM C,1(X1)
AOBJP X1,PUTV1 ;COUNT CHARS IN LEFT HALF OF X1
PUTV9: HLRZ X1,X1 ;GET SIZE
SKIPGE FTYPE ;IS VECTOR REAL?
JRST PUTV5 ;NO, DON'T FLOAT IT
HRLI X1,233400 ;FLOAT IT
FSB X1,FIXCON
PUTV5: MOVE X2,N
MOVEM X1,(X2) ;FIRST ELEMENT GETS SIZE
POPJ P,
PUTVF: INLERR(83,41,</
? No room for string/>)
JRST GOSR2
;STORE STR FOR LET STATEMENT.
PUTSTR: PUSH P,40 ;CKVSTR DESTROYS 40
SETZM VIRWRD ;CHECKING FOR FETCH
MOVE X1,N ;SEE IF N IS A VIRTUAL STRING ARRAY
PUSHJ P,CKVSTR
MOVE N,X1 ;RESET N TO FIXED POINTER
POP P,40 ;RESTORE 40
MOVE X1,40
MOVE X1,0(X1) ;SEE IF 40 POINTS TO VIRTUAL ARRAY
SETOM VIRWRD ;SET VIRTUAL ARRAY FLAG
PUSHJ P,CKVSTR
TLNN N,777777
JRST PUTST2
TLNE N,377777
JRST PUTST1
MOVE T,N
MOVE N,(T)
JRST PUTSTR
PUTST1: JUMPG N,PUTST4
PUTST2: HLRE G,N
JUMPN G,PUTST5
SKIPE VIRWRD ;VIRTUAL STRING?
JRST PUTXX9
PUSHJ P,PNTADR
SKIPE (X1)
SETZM VPAKFL
SETZM (X1)
POPJ P,
PUTST5: MOVM T,G
SKIPN VIRSIZ ;PUTTING A STRING IN VIRTUAL ARRAY?
JRST PUTST9 ;NO.
CAMLE G,VIRSIZ ;STRING BIGGER THAN PLACE TO PUT IT?
JRST RNERR2
PUTST9: PUSHJ P,MASTST ;CHECK ENOUGH SPACE
AOS F,MASAPP
MOVEM N,(F)
PUSHJ P,VCHCKC
MOVE N,(F)
SOS MASAPP
HRRZ F,N
HRLI F,440700
PUSHJ P,PNTADR
SKIPE (X1)
SETZM VPAKFL
HRRZM T,(X1)
HRLM G,(X1)
SKIPE VIRWRD
SKIPA T,VIRWRD
HRLI T,440700
PUTST3: ILDB C,F
IDPB C,T
SOS VIRSIZ ;DECREMENT VIRTUAL ARRAY ELEMENT SIZE TOO
AOJL G,PUTST3
SKIPN VIRWRD ;VIRTUAL STRING?
SETZM VIRSIZ ;NO, 0 VIRSIZ
SETZM VIRWRD
SKIPG VIRSIZ ;DO WE NEED TO NULL FILL VIRTUAL STR?
POPJ P,
;HERE TOO NULL FILL REST OF VIRTUAL STRING ELEMENT
SETZ C, ;NULL TO C
PSLAB1: IDPB C,T ;PUT NULL IN VIRTUAL STR.
SOS VIRSIZ ;DECREMENT COUNT OF VIRTUAL STRING SIZE
SKIPLE VIRSIZ ;MORE TO NULL FILL?
JRST PSLAB1 ;YES. KEEP NULL FILLING.
POPJ P, ;NO. RETURN
PUTST4: PUSHJ P,STRETR
MOVE T,N
SKIPE VIRWRD ;VIRTUAL ARRAY STORE
JRST PUTST2 ;HAS HANDLE DIFFERENTLY
PUSHJ P,PNTADR
SKIPE (X1)
SETZM VPAKFL
MOVEM T,(X1)
POPJ P,
PUTXX9: SETZ C, ;YES FILL VIRT. STR. WITH NULLS
MOVE T,VIRWRD ;PICK UP POINTER
MOVE G,VIRSIZ ;GET STRING SIZE
PSLAB2: JUMPN G,PUTXX1
POPJ P,
PUTXX1: IDPB C,T ;PUT IN NULL
SOJA G,PSLAB2
;COMSTR COMPARES TWO STRINGS. ONE HAS BEEN FETCHED. THE POINTER
;TO THE OTHER IS IN REG. THE COMPARE RELATION IS IN (P)
;COMSTR GETS A PAIR OF CHARS, ONE FROM EACH STRING, USING "GETPCH".
;WHEN IT REACHES THE END OF ONE OR BOTH STRINGS, OR WHEN IT FINDS
;AN UNEQUAL CHAR PAIR, THE ROUTINE USES THIS PAIR OF CHARACTERS
;WHILE EXECUTING THE RELATION (NOTE: FIRST, HOWEVER, A CHECK IS MADE
;FOR TRAILING BLANKS).
COMSTR: PUSH P,40
SETZM VIRWRD ;VIRTUAL STRING READ
MOVE X1,N
PUSHJ P,CKVSTR ;SEE IF N POINTS TO VIRTUAL STR
MOVE N,X1
POP P,40
TLNN N,777777
JRST COMST2
TLNE N,377777
JRST COMST1
MOVE T,N
MOVE N,(T)
JRST COMST2
COMST1: JUMPLE N,COMST2
PUSHJ P,STRETT
COMST2: PUSHJ P,MASTST ;CHECK ENOUGH SPACE
AOS F,MASAPP
MOVEM N,(F)
PUSHJ P,SPVIRS ;SETUP X1 WITH VIRTUAL STR POINTER
JRST [MOVE N,X1 ;RETURNS HERE IF IT IS
JRST COMST3]
PUSHJ P,PNTADR
MOVE N,(X1)
TLNN N,777777
JRST COMST3
JUMPLE N,COMST3
PUSHJ P,STRETT
COMST3: HRRZ F,N
HLRE G,N
HRLI F,440700
SOS T,MASAPP
MOVE T,1(T)
HLRE T1,T
HRLI T,440700
IFST1: PUSHJ P,GETPCH ;GET PAIR OF CHARS IN (A) AND (C)
JUMPG X2,IFST3 ;HAVE BOTH STRINGS ENDED?
JUMPE X2,IFST2 ;HAS ONE STRING ENDED?
CAMN C,A ;ARE THESE TWO CHARS THE SAME?
JRST IFST1 ;YES. LOOK AT NEXT PAIR
IFST2: SETOI X2, ;CHECK BOTH STRINGS FOR TRAILING BLANKS
IFLAB1: CAIN C," " ;IS THIS CHAR A BLANK?
PUSHJ P,IFST4 ;YES, GO CHECK STRING
PUSHJ P,EXCH6 ;LOOK AT OTHER STRING
AOJLE X2,IFLAB1
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: JUMPN G,IFLAB2 ;IS BLANK REALLY A TRAILING BLANK?
SETO C,
POPJ P,
IFLAB2: ILDB C,F
AOJ G,
CAIN C," " ;IS NEXT CHAR A BLANK?
JRST IFST4 ;YES KEEP LOOKING
IFST5: MOVEI C," " ;NO. USE BLANK FOR COMPARE
POPJ P,
;ROUTINE TO GET A PAIR OF CHARS
GETPCH: SETOI X2, ;COUNT TERMINATED STRINGS IN X2
PUSHJ P,GETCH
PUSHJ P,EXCH6 ;LOOK AT OTHER STRING
PUSHJ P,GETCH
EXCH6: EXCH T,F ;MOVE OTHER STRING INFO TO (C),(F),(G)
EXCH T1,G
EXCH A,C
POPJ P,
GETCH: JUMPE G,GCLAB1
ILDB C,F
AOJA G,CPOPJ
GCLAB1: SETO C,
AOJA X2,CPOPJ
;PRSTRR PRINTS A STRING WHOSE POINTER IS ADDRESSED IN (40)
PRSTRR: PUSHJ P,TABBR
PUSHJ P,FIRCHK
MOVEI X1,0
PUSHJ P,CHROOM
PUSHJ P,NUMINS
SKIPE QUOTBL(LP) ;QUOTE MODE?
JRST PRSTDS ;YES.
PUSH P,G ;SAVE G (FOR MAT READ AND PRINT)
SETZM VIRWRD ;FETCH A VIRTUAL STRING (MAYBE)
PUSHJ P,SPVIRS ;SEE IF VIRTUAL STRING
JRST PRST1 ;IT WAS. F HAS RIGHT POINTER
PUSHJ P,GETSTR ;SETUP STRING FETCH
JUMPLE G,PRST1
MOVE N,(X1)
PUSHJ P,STRETT
HLRE G,N
HRR F,N
HRLI F,440700
PRST1: JUMPE G,PRST2
SETZM ZONFLG(LP)
PRST3: ILDB C,F
PUSHJ P,OUCH0 ;PRINT CHAR
AOJL G,PRST3
PRST2: POP P,G
JRST FINPNT
PRSTDS: SETZM VIRWRD ;FETCH A VIRTUAL STRING (MAYBE)
PUSHJ P,SPVIRS ;SEE IF VIRTUAL STRING
JRST PRST4 ;IT WAS. F HAS RIGHT POINTER
PUSHJ P,GETSTR ;QUOTE MODE
JUMPLE G,PRST4
MOVE N,(X1)
PUSHJ P,STRETT
HLRE G,N
HRR F,N
HRLI F,440700
PRST4: MOVMS G,G
PUSH P,F
PUSH P,G
JRST PRTXD1
PRTXD8: MOVEI C," " ;OUTPUT A DELIMITER.
PUSHJ P,OUCH
PUSHJ P,PRTXD4
JUMPE G,PRTXD3
PRTXD5: ILDB C,F
PUSHJ P,OUCH
SOJG G,PRTXD5
PRTXD3: PUSHJ P,PRTXD4
JRST FINPNT
PRTXD4: SKIPN QUOFLG ;OUTPUT A QUOTE?
POPJ P, ;NO.
MOVEI C,42 ;YES.
JRST OUCH
PRTXD1: SETZM QUOFLG ;QUOFLG NE 0 SAYS MUST
SETZM ZONFLG(LP)
PRTXD9: MOVE X1,MARGIN(LP) ;WRITE THIS STRING WITH QUOTES.
SUBI X1,1
SUB X1,HPOS(LP)
JUMPG X1,PXLAB1
PUSHJ P,PCRLF
JRST PRTXD9
PXLAB1: SETO X2,
JUMPE G,PRTXD2
PRTXD7: SOJGE G,PXLAB2 ;SEE IF FINISHED
JRST PRTXD0 ;YES, RETURN
PXLAB2: ILDB C,F
CAIN C,42
JRST PTXER1
HLL C,CTTAB(C)
TRNE C,100
HRL C,CTTAB-100(C)
TLNE C,F.CR ;IF STR CONTAINS SPACE, TAB,
JRST PTXER1 ;OR COMMA, IT MUST BE WRITTEN WITH QUOTES.
TLNN C,F.SPTB+F.COMA
JRST PRTXD6
SKIPN QUOFLG
PRTXD2: SUBI X1,2 ;ONCE ONLY, SUBTRACT THE 2 SPACES
SETOM QUOFLG ;THE QUOTES TAKE UP.
PRTXD6: SOJGE X1,PRTXD7
JUMPE X2,PTXER2 ;STRING IS TOO LONG FOR LINE.
MOVE D,MARGIN(LP)
SUB D,HPOS(LP)
SUB D,X1
PUSHJ P,PCRLF
ADD D,HPOS(LP)
CAML D,MARGIN (LP)
JRST PTXER2
MOVE X1,MARGIN(LP)
SUB X1,D
SETZ X2,
JRST PRTXD7
PRTXD0: POP P,G
POP P,F
JRST PRTXD8
;ROUTINE TO PUT ADDRESS OF POINTER IN REG
PNTADR: HRRZ X1,40 ;GET UUO ADDRESS
MOVE X2,(X1)
JUMPGE X2,CPOPJ ;ALL DONE IF THIS IS 0 OR AN APP BLK.
TLNN X2,377777 ;ALL DONE IF THIS IS NEGATIVE COUNT
MOVEI X1,(X2)
POPJ P,
;STRRET IS A UTILITY ROUTINE WHICH RETRIEVES A STRING FROM
;AN APPEND BLOCK AND CREATES THE ACTUAL STRING EITHER IN THE
;TEMPORARY STRING AREA OR IN THE REAL STRING AREA, DEPENDING ON
;WHICH OF THE ENTRY POINTS STRETT AND STRETR IS USED. STRRET EXPECTS
;THE APPEND KEY IN AC N. IT RETURNS THE ANSWER KEY IN AC N. IT
;DESTROYS NO AC'S EXCEPT T.
STRETT: SETOM REATMP ;STORE IN TEMP SPACE.
JRST SRLAB1
STRETR: SETZM REATMP ;STORE IN REAL SPACE.
SRLAB1: PUSH P,X1
PUSH P,X2
PUSH P,T1
PUSH P,C
PUSH P,E
; Delete [3] MOVE X1,N ;SAVE APP KEY.
PUSHJ P,MASTST ;[3] CHECK FOR SPACE
AOS X1,MASAPP ;[3] AND PROTECT THE KEY
MOVEM N,(X1) ;[3] ON THE MASTER APP. LIST
PUSHJ P,LENAPB
MOVE T,N ;LENGTH TO T FOR CORE MANAGER.
SKIPN REATMP
JRST SRLAB2
PUSHJ P,VCHTSC ;GET SPACE FOR THE STRING.
JRST SRLAB3 ;LOWER BOUND IS RETURNED IN T.
SRLAB2: PUSHJ P,VCHCKC
SRLAB3: MOVN N,N
HRLZ N,N
HRRI N,(T) ;ALMOST ANSWER KEY.
MOVE X1,(X1) ;[3] GET BACK THE KEY
SOS MASAPP ;[3] ADJUST MASTER APP. LIST
HLRZ E,X1
HRLI T,440700 ;DESTINATION POINTER.
HRRZI X1,(X1)
STRET1: HRR X2,1(X1)
HRLI X2,440700 ;ORIGINAL POINTER.
HLRE T1,1(X1) ;LOOP COUNTER.
JUMPE T1,STRET2
SRLAB4: ILDB C,X2
IDPB C,T
AOJL T1,SRLAB4
STRET2: AOJ X1,
SOJG E,STRET1
POP P,E
POP P,C
POP P,T1
POP P,X2
POP P,X1
POPJ P, ;EXIT.
;UTILITY ROUTINE TO HANDLE THE "+" OPERATOR FOR STRINGS.
APPEND: MOVE T,MASAPP
MOVE T,(T)
MOVE X1,N
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING
PUSH P,X1 ;SAVE NEW N
MOVE X1,T
PUSHJ P,CKVSTR ;SEE IF T IS VIRTUAL STRING
MOVE T,X1
POP P,N
TLNN T,777777
JRST APPOU1 ;T IS NULL STR.
TLNN N,777777
JRST APPOU2 ;N IS NULL STR.
TLNE T,377777
JRST APPND1
MOVE T,(T)
TLNN T,777777
JRST APPOU1 ;T IS NULL STR.
APPND1: PUSH P,X1
TLNE N,377777
JRST APPND2
MOVE X1,N
MOVE N,(X1)
TLNN N,777777
JRST APPOU3 ;N IS NULL STR.
APPND2: JUMPG T,APPND3
JUMPG N,APPND4
PUSHJ P,MASTST ;CHECK ENOUGH SPACE
MOVE X1,MASAPP ;BOTH REAL.
MOVEM N,1(X1) ;PROTECT THE KEYS.
MOVEM T,(X1)
AOS MASAPP
PUSHJ P,VCHAPP ;GET AN APP BLK.
MOVE N,(X1) ;SET UP THE BLK.
MOVEM N,1(T)
MOVE N,1(X1)
MOVEM N,2(T)
HRLI N,2
HLRZM N,(T)
HRRI N,(T) ;KEY IN N.
SOS MASAPP
JRST APPOU0 ;EXIT.
APPND3: PUSH P,X2
JUMPG N,APPND5
HLRZ X1,T ;T IS APP BLK, N IS REAL.
CAIL X1,APBMAX-1 ;MAKE SURE NO OVERFLOW
JRST APPERR ;THERE WAS
HRRZ X2,T
ADDI X1,1(X2)
MOVEM N,(X1) ;STORE N.
AOS (X2)
HRL N,(X2) ;KEY IN N.
HRRI N,(T)
JRST APPOUT ;EXIT.
APPND4: PUSH P,X2 ;T IS REAL, N IS APP BLK.
HLRZ X1,N
CAIL X1,APBMAX-1 ;MAKE SURE NO OVERFLOW
JRST APPERR ;THERE WAS
HRRZ X2,N
ADDI X1,(X2)
MOVEM T,(X2) ;STORE T IN ZEROTH LOC IN N.
HLRZ T,N
AOJ T,
HRL N,T
APPN41: MOVE X2,(X1)
MOVEM X2,1(X1)
SOJ X1,
SOJG T,APPN41
HLRZM N,1(X1)
JRST APPOUT ;EXIT.
APPND5: HLRZ X1,T ;BOTH N AND T ARE APP BLKS.
HRRZ X2,T
ADDI X2,1(X1)
HRRZ X1,N
HRLI X2,1(X1)
HLRZ X1,N
ADDB X1,(T) ;UPDATE APP. BLK.
CAIL X1,APBMAX-1 ;MAKE SURE NO OVERFLOW
JRST APPERR ;THERE WAS
HRLM X1,T ;AND POINTER T
ADDI X1,(T)
BLT X2,(X1) ;MOVE BLOCK
MOVE N,T ;NEW POINTER TO KEY IN N
APPOUT: POP P,X2
APPOU0: POP P,X1
APPOU1: SOS MASAPP
POPJ P,
APPOU3: POP P,X1
APPOU2: MOVE N,T
SOS MASAPP
POPJ P,
MASTST: PUSH P,T
MOVEI T,MASAPP+MASMAX-1 ;ANY MORE AND WE OVERFLOW
CAMG T,MASAPP ;SAFE ?
JRST APPERR ;NO
POP P,T ;YES
POPJ P,
APPERR: INLERR(6,71,</
? Out of static list space/>)
JRST GOSR2
SUBTTL SUBSCRIPTED VARIABLE FETCH/STORE ROUTINES
;MATRIX ELEMENT FETCH/STORE UUO ROUTINES
SAD1ER: MOVE D,[JRST SADEND] ;FETCH ADR OF ARRAY ELEMENT
MOVE A,UUOH
HLRZ B,1(A)
TRZ B,100
CAIE B,(JUMP )
JRST AFT1ER+1
JRST AFT2ER+1
ASN1ER: MOVE D,[MOVNM N,(A)] ;NEGATIVE ARRAY STORE
JRST ASLAB1
AST1ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE
AFT1ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH
ASLAB1: 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 ASLAB2
AST2ER: SKIPA D,[MOVEM N,(A)] ;POSITIVE ARRAY STORE
AFT2ER: MOVSI D,A(MOVE N,) ;ARRAY FETCH
ASLAB2: 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
HLRZ X1,0(B)
TRZE X1,(1B0) ;VIRTUAL ARRAY?
JRST VIRST ;YES.GO DO VIRTUAL STUFF
ADD A,(B) ;ADD ARRAY ADDRS
XCT D ;DO THE OPERATION
POPJ P, ;RETURN
VIRST: ADD X1,FLVIR ;X1 POINTS TO VIRTUAL ARRAY ROLL
PUSH P,LP ;SAVE LP
HRRZ LP,1(X1) ;CHANNEL # TO LP FOR R.A.
HRRZ X2,ACTBL-1(LP) ;GET ACCESS CODE
CAIE X2,-2 ;IS THIS FOR A VIRTUAL ARRAY?
JRST FNMXER ;NO, GIVE ERROR
TLNE D,40000 ;JRST IN D?
JRST VIRGAR ;YES. MUST BE STRING (VIRTUAL)
ADD A,0(X1) ;STARTING WORD + ARRAY ELEMENT
MOVEM A,POINT-1(LP) ;MAKE LOOK LIKE RECORD # FOR R.A.
TLNE D,2000 ;MOVEM OR MOVNM?
JRST VIROUT ;YES. DO VIRTUAL OUTPUT
VIRGIN: SETZM 40 ;SO RANUM WILL STORE RESULT IN N
PUSHJ P,RANUM ;DO R.A. INPUT
VIRGEX: POP P,LP ;RESTORE LP
POPJ P, ;RETURN
VIROUT: PUSH P,A ;SAVE A
SETZ A,
XCT D ;MOVE N TO N
POP P,A ;RESTORE A
PUSHJ P,RNNUMO ;DO R.A. OUTPUT
JRST VIRGEX ;RESTORE LP AND RETURN
VIRGAR: HRRZ N,UUOH ;VIRTUAL STRING
SOJ N,
HRLI N,440000 ;VIRTUAL STRING IF 440000
JRST VIRGEX ;RESTORE LP AND RETURN
;CHECK IF VIRTUAL STRING REFERENCE
;IF IS CHANGE POINTERS TO POINT TO DSTRING IN TEMP ARREA
CKVSTR: PUSH P,X2
LDB X2,[POINT 6,X1,5]
CAIE X2,44 ;SET TO 440000 IF VIRTUAL STRING REFERENCE
JRST [SETZM VIRWRD ;CLEAR VIRTUAL STRING FLAG
SETZM VIRSIZ ;VIRSIZ NOT 0 MEANS VIRTUAL ARRAY
POP P,X2
POPJ P, ]
PUSH P,N
PUSH P,LP
PUSH P,T ;SAVE T
PUSH P,C ;SAVE C
HLRZ X2,2(X1) ;CHECK FOR JUMP T1, FOR 2 DIM
TRZ X2,100
CAIE X2,(JUMP ) ;2 DIM VIRTUAL STRING ARRAY?
JRST SUBVR1 ;NO, DO ONE DIM
MOVE B,(X1) ;POINT TO SVRROL
HLRZ C,1(B) ;GET FIRST DIMENSION
MOVE E,1(X1) ;GET FIRST SUBSCRIPT
PUSHJ P,SUBVIR ;CONVERT TO INTEGER AND CHECK
HRRZ X2,1(B) ;GET SECOND DIMENSION
IMUL X2,E ;TRANSLATE
HRRZ C,1(B) ;GET SECOND SUBSCRIPT
MOVE E,2(X1) ;GET ADDRESS OF SUBSCRIPT
JRST SUBVR2 ;CARRY ON AS 1 DIM
SUBVR1: MOVEI X2,0 ;BAS IS ZERO FOR ONE DIM
MOVE B,(X1) ;PUT TO SVRROL
HRRZ C,1(B) ;COLUMN VECTOR?
TRNN C,777776 ;IS IT 1?
HLRZ C,1(B) ;YES, ROW VECTOR
MOVE E,1(X1) ;ADDRESS OF SUBSCRIPT
SUBVR2: PUSHJ P,SUBVIR ;CONVERT TO INTEGER AND CHECK LIMIT
ADD X2,E ;ADD IN SUBSCRIPT
MOVE A,0(X1)
HLRZ X1,0(A)
TRZ X1,400000
ADD X1,FLVIR ;POINTS TO VIRTUAL ROLL ENTRY
HRRZ LP,1(X1) ;CHANNEL # TO LP
HLRZ A,1(X1) ;GET SIZE TO A
MOVEM A,VIRSIZ ;PUTSTR MIGHT NEED
IMUL A,X2 ;ELEMENT # TIMES SIZE
HLRZ X2,0(X1) ;GET BYTE #
ADD A,X2 ;POINTS TO BYTE IN ARRAY
IDIVI A,^D512
HRRZ X2,0(X1) ;GET BLOCK # OF START
SOJ X2,
ADD X2,A ;+ REL BLOCK # IN ARRAY
PUSH P,B ;SAVE REMAINDER
LSH X2,7 ;TIMES 128 TO LOOK LIKE R.A. POINTER
AOJ X2, ;
MOVEM X2,POINT-1(LP) ;SET UP R.A. RECORD #
PUSH P,X1 ;SAVE X1
SKIPE VIRWRD ;WRITING?
JRST [PUSHJ P,RNNUMO ;YES
JRST CKVIR2]
SETZM 40 ;SO INPUT WILL ONLY CLOBBER N
PUSHJ P,RANUM ;DO R.A. INPUT
CKVIR2: POP P,X1 ;GET X1 BACK
SKIPE VIRWRD ;WRITING?
JRST CKVIR5 ;YES
HLRZ T,1(X1) ;GET SIZE OF STRING
PUSH P,X1 ;SAVE X1
SKIPN VRFBOT ;CORE SET?
PUSHJ P,SETCOR ;NO, DO IT
PUSHJ P,VCHTSC ;GET THAT MANY BYTES FROM TEMP
POP P,X1 ;RESTORE X1
HRLI T,440700 ;7 BIT BYTE POINTER TO T
HLRZ X2,1(X1) ;SIZE TO X2
CKVIR5: POP P,B ;GET BACK REMAINDER
HLRZ A,BA-1(LP) ;GET BUFFER ADDRES FOR THIS CHANNEL
ADDI A,4 ;STRING BUFFER STARTS IN 3RD WORD
ADDI B,4 ;ADD 4 TO REMAINDER
IDIVI B,5 ;5 BYTES PER WORD
ADD A,B ;A NOW POINTS TO RIGHT WORD
HRLI A,440700 ;MAKE BYTE POINTER
CKVIR3: JUMPE C,CKVIR4 ;RIGHT POSITION?
IBP A ;NO. GO TO NEXT BYTE
SOJA C,CKVIR3 ;LOOP TILL GET TO RIGHT BYTE
CKVIR4: SKIPE VIRWRD ;WRITING?
JRST [MOVEM A,VIRWRD ;YES SETUP VIRWR WITH POINTER
JRST CKVEXT]
PUSH P,T ;SAVE POINTER
SETZ X1, ;ZERO TO COUNT OF NON NULL BYTES
CKVIR7: JUMPE X2,CKVIR6 ;X2 HAS SIZE ORIGINALLY
ILDB C,A
IDPB C,T
JUMPE C,CKVIR9 ;NULL BYTE? IGNORE IF YES
AOJ X1, ;+1 TO BYTE COUNT
CKVIR9: SOJA X2,CKVIR7 ;DO WHOLE STRING
CKVIR6: POP P,T ;GET BACK POINTER TO TEMP
MOVE X2,X1 ;GET + SIZ OF STRING
JUMPE X2,CKVIR8 ;NULL STRING?
MOVN X2,X2 ;MAKE NEGATIVE
CKVIR8: HRL T,X2 ;NEG COUNT TO T
MOVE X1,T ;REGULAR POINTER IN X1
CKVEXT: POP P,C ;RESTORE C
POP P,T ;RESTORE T
POP P,LP
POP P,N
POP P,X2
POPJ P,
SPVIRS: MOVE X1,40 ;PICK UP UUO
MOVE X1,0(X1) ;PICK UP WHAT UUO POINTS TO
PUSH P,40
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING
POP P,40
SKIPN VIRSIZ ;WAS IT ?
JRST CPOPJ1 ;NO
MOVN G,VIRSIZ ;NEG. STRING SIZE TO G
MOVE F,X1 ;POINTER TO F
SKIPE VIRWRD ;WRITING INTO VIRT. STRING?
JRST VIRPT ;YES
HRLI F,440700 ;JUST READING SO ADDRES POINTS TO TEMP
POPJ P,
VIRPT: MOVE X2,VIRWRD ;POINTER TO X2
SETZ X1, ;NULL CHAR.
VIRPT2: JUMPE G,VIRPT1 ;FINISHED?
IDPB X1,X2 ;NO. KEEP FILLING WITH NULLS
AOJA G,VIRPT2 ;DO G TIMES
VIRPT1: MOVN G,VIRSIZ ;SETUP G WITH NEG. COUNT
MOVE F,VIRWRD ;SETUP F WITH BYTE POINTER
POPJ P,
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 -1(P) ;SKIP ARGUMENT
SUBVIR: PUSHJ P,SUBCHK ;CHECK TYPE OF SUBSCRIPT
CAMGE E,C ;CHECK DIMENSION
POPJ P,
;DIMENSION ERR ROUTINE
DIMERR: INLERR(84,42,</
? DIMENSION error/>)
JRST GOSR2
SUBCHK: TLNN E,100 ;IS SUBSCRIPT REAL?
JRST SUBINT ;NO, JUST PICK IT UP
MOVE E,(E) ;GET THE VALUE
JUMPL E,DIMERR ;<0 IS AN ERROR
FAD E,FIXCON ;FIX IT
TLZ E,777400 ;
POPJ P, ;AND RETURN
SUBINT: MOVE E,(E) ;GET THE VALUE
JUMPL E,DIMERR ;<0 IS AN ERROR
POPJ P, ;AND RETURN
SUBTTL MATRIX OPERATION RUN-TIME ROUTINES
;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
;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 THAN 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 ;CALCULATE FIRST ELT OF RESLT
ADDI G,1
IMULI G,(E)
ADDI G,(T1)
POPJ P,
;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
SKIPN INVFLG
JRST MLP2
PUSH P,G
MOVM G,A
CAMLE G,INVLRG
MOVEM G,INVLRG
POP P,G
MLP2: ADDI G,1
CAMGE T1,SB2M1
AOJA T1,MLP
SKIPE SB2M1 ;MORE THAN A 0'TH COL?
AOJA G,MLLAB1 ;YES. SKIP 0'TH COL
TDZA T1,T1 ;NO. SET TO USE 0'TH COL
MLLAB1: 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
;MATRIX READ ROUTINE
;SET UP AND CALL MLP. FOR EACH ELEMENT, THE FOLLOWING
;ARE PERFORMED:
; TEMP1: PUSHJ P,MTRELT
; TEMP2: ... ;(SKIPPED)
; TEMP3: MOVEM N,<DEST>(G)
;MTRELT READS A NUMBER INTO N
MTRDER: SETZM IFIFG
SETZM FTYPE ;ASSUME REAL MATRIX
MOVE X1,40 ;CHECK TYPE BIT
TLNE X1,400 ;IS IT INTEGER?
SETOM FTYPE ;YES, MARK FOR READ
MOVE T1,[PUSHJ P,MTRELT]
PUSHJ P,DOREAD
HRRZ X1,@40 ;GET ADRESS 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 MTRD2 ;NO ACTION ON ROW
POPJ P,
;ROUTINE CALLED BY MTRDER TO PRINT AN ELEMENT
MTRELT: PUSHJ P,DATAER
JRST CPOPJ1 ;SKIP SECOND XCT
MTRDS: MOVSI T1,(SKIPA)
MOVSI B,G(STRIN)
JRST MTRD1
;MATRIX PRINT ROUTINE
;SET UP AND CALL MLP:
; TEMP1: PUSH P,T
; TEMP2: PRNM <FORMAT CODE>,<DEST>(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
SKIPN SB2M1 ;COLUMN VECTOR?
JRST MPLAB1 ;YES. ALLOW <CR> FORMAT
TLNN B,(Z 16,) ;OH, NO. TREAT <RET> FORMAT ==<COMA> FORMAT.
HRLI B,(Z 3,)
MPLAB1: 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
SETZM ODF
SETZB LP,HPOS
SETZM TABVAL
SETZM FMTPNT
MTP2D: PUSHJ P,MTP3D ;TWO BLANK LINES
MTP1D: SKIPE SB2M1 ;FOR THE SPECIAL CASE OF A COLUMN
JRST MTP5D ;VECTOR IN COMMA OR SEMICOLON
MOVE LP,TEMP2
TLNN LP,(Z 16,) ;FORMAT, DON'T ZERO THE FLAGS
JRST MTP5D ;BECAUSE WE ARE IN THE MIDDLE OF THE ROW.
SETZ LP,
JRST MTP4D
MTP5D: SETZB LP,HPOS
SETZM TABVAL
SETZM FMTPNT
MTP4D: PUSHJ P,MLP ;PRINT A ROW
JRST MTPRE1 ;NOW SEE WHETHER TO SPACE BETW ROWS
MTP3D: PUSHJ P,INLMES
ASCIZ /
/
OUTPUT
SETZM HPOS
SETZM TABVAL
SETZM FMTPNT
POPJ P,
MTPRE1: SKIPE SB1M1 ;VECTOR OR ARRAY?
SKIPN SB2M1
JRST MTP1D ;ARRAY... SPACE BETW ROWS
JRST MTP2D ;VECTOR...DONT SPACE BETW ROWS
;MATRIX ADD AND SUBTRACT ROUTINES
;SET UP AND CALL MLP:
; TEMP1: MOVE N,<ARG 2>(G) ;OR MOVN
; TEMP2: FADR N,<ARG 1>(G)
; TEMP3: MOVEM N,<DEST>(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
MOVE X1,40 ;CHECK THE TYPE
TLNE X1,400 ;IS IT INTEGER
HRLI T,G(ADD N,) ;YES, MAKE INTEGER ADD
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,<ARG 1>(G)
; TEMP2: FMPR A,N
; TEMP3: MOVEM A,<DEST>(G)
MTSCER: HRLI T1,G(MOVE A,)
MOVSI T,(FMPR A,N)
MOVE X1,40 ;CHECK THE TYPE
TLNE X1,400 ;IS IT INTEGER?
MOVSI T,(IMUL A,N) ;YES, MAKE INTEGER MULTIPLY
MTSC1: HRLI B,G(MOVEM A,)
MOVE A,1(T1)
PUSHJ P,MS1
JRST MTRD2
;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,<DEST>(G)......................
MTIDER: SKIPA T,[CAMN E,T1]
MTZRER: MOVSI T,(CAIA)
SKIPA T1,[SETZM @TEMP3]
MTCNER: MOVSI T1,(CAIA)
MTCN1: HRLI B,G(MOVEM D,)
MOVSI D,(DEC 1.0) ;CONSTANT 1.0 TO STORE
MOVE X1,40 ;CHECK THE TYPE
TLNE X1,400 ;IS IT INTEGER?
MOVEI D,1 ;USE INTEGER CONSTANT 1
JRST 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,A(MOVE N,)
HLRZ T,A ;E := ADDI A,<NBR ROWS>
HRLI T,(ADDI A,)
HRLI B,G(MOVEM N,)
PUSHJ P,MS1 ;SET UP AND CHK DIMENSION
MTTN1: MOVE A,SB1M1 ;A := <NBR ROWS>*COL + ROW
ADDI A,1
IMUL A,T1
ADD A,E
PUSHJ P,MLP ;MOVE A ROW
JRST MTTN1
POPJ P,
;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: CLEARM FTYPE ;ASSUME FLOATING MATRIX
MOVE X1,40 ;CHECK THE TYPE
TLNE X1,400 ;IS IT INTEGER?
SETOM FTYPE ;YES, MARK IT
MOVE A,1(T) ;CHECK DIMENSIONS
HLRZ D,1(T1) ;D := INNER DIMENSION
CAIE D,(A) ;SAME AS FIRST ARG?
JRST DIMERR ;NO
HRR A,1(T1)
HRLI T1,T1(MOVEI X2,) ;TO COMPUTE ADDRS 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 DOT PRODUCT
MOVEI C,-1(D) ;NUMBER OF ADDS= REAL INNER DIMENSION
MYEL1: PUSH P,R
MOVE R,(X1) ;PRODUCT OF 2 ELTS
SKIPGE FTYPE ;FLOATING MATRICES
JRST MYEL2 ;NO, DO INTEGER STUFF
FMPR R,(X2)
FADR N,R ;
JRST MYEL3 ;
MYEL2: IMUL R,(X2) ;
ADD N,R ;
MYEL3: ADDI X2,1(A) ;NEXT ROW OF 2ND ARG
POP P,R
SOJLE C,CPOPJ ;DONE?
AOJA X1,MYEL1 ;NO. TO NEXT ELT
SUBTTL RUN-TIME MATRIX INVERTER
;SUBROUTINE TO CALL MATRIX INVERTER
MTIVER: SETOM INVFLG
SETZM INVLRG
MOVS A,1(T1) ;MAKE SURE SQUARE MATRIX
CAME A,1(T1)
JRST 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 THINKING 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 IX,@TEMP1 ;A(I,J)=A(I,J)+A(NT,J)*A(I,NT)
FMPR IX,(KX) ;***
MOD: FADRM IX,0(JX) ;ADDR MODIFIED BY OUTER LOOP
JXIT: CAMGE JX,SB1M1 ;LOOP DONE?
AOJA JX,ZERO
JRST IXIT2 ;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 ; " " "
TAC1=16 ; " (MUST BE SAVE & RESTORED)
;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: SETZM LIBFLG
SETZM INVFLG
HRRZS TEMP3 ;MAKE SURE ADDR ONLY
PUSH P,TAC1
MOVE TAC1,SB1M1 ;GET ORDER
ADDI TAC1,1 ;ADD ONE FOR 0'TH ROW & COL
MOVEM TAC1,SB2M1 ;SAVE IN SB2
MOVSI TAC1,(1.0) ;INIT DETERM.
MOVEM TAC1,DETER
HRLZI TAC1,JX ;SET INDEX REG IN
HLLZM TAC1,TEMP1 ;TEMP1 FOR INDIRECT
MOVE TAC1,[XWD JLOOP,ZERO]
BLT TAC1,7 ;PUT JLOOP INTO ACS
MOVEI NT,1 ;INITIALIZE OUTER LOOP
MINVLP: MOVE TAC1,NT
IMUL TAC1,SB2M1 ;CALC (NT,NT) SUBSCR
ADD TAC1,NT
ADD TAC1,TEMP3 ;***
MOVEM TAC1,TEMP2 ;SAVE IT FOR LATER
CAMN NT,SB1M1 ;LAST ITER?
JRST FOUND1 ;SAVE SEARCH STUFF
MOVM TAC1,(TAC1) ;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,TAC1 ;IS IT LARGER THAN PRESENT
JRST LUPEND ;NO
MOVE TAC1,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
FOUND: CAMN NT,VECT1(NT)
MOVNS DETER
CAMN NT,VECT2(NT)
MOVNS DETER
PUSHJ P,FSWAP
FOUND1: SKIPN INVLRG ;TEST FOR SINGULARITY.
JRST SING
FOUND2: MOVE TAC1,@TEMP2 ;GET PIVOT ELEMENT
MOVEM TAC1,PIVOT ;SAVE IT
FMPRB TAC1,DETER ;PERPETUATE DETERM
JUMPE TAC1,SING
MOVSI TAC1,(1.0) ;1./A(NT,NT)
FDVRM TAC1,PIVOT ;***
MOVEI IX,1 ;SET UP I
ILOOP: CAMN IX,NT ;SKIP SAME ROW
JRST IXIT ;AS PIVOT ROW
MOVE LX,SB2M1 ;CALCULATE ALL ROW OFFSETS
IMUL LX,IX
ADD LX,TEMP3 ;LX= IX*N+A
MOVE KX,LX
ADD KX,NT ;KX=LX+NT
MOVN TAC1,PIVOT ;GET -PIVOT
FMPRM TAC1,(KX) ;A(I,NT)=A(I,NT)/(-A(NT,NT))
MOVEI JX,1 ;SET J LOOP START
MOVE TAC1,SB2M1
IMUL TAC1,NT
ADD TAC1,TEMP3 ;TAC=NT*N+A
HRRM TAC1,TEMP1 ;STORE FOR @TEMP1(JX)
HRR MOD,LX ;SAT ADDR IN INNER LOOP
PUSH P,IX
JRST ZERO ;GO
IXIT2: POP P,IX
IXIT: CAMGE IX,SB1M1 ;RETURN HERE FROM ACS
AOJA IX,ILOOP
MOVEI JX,1 ;SET LOOP FOR LAST COL
MOVE TAC1,PIVOT ;GET PIVOT
LCOL: FMPRM TAC1,@TEMP1 ;A(NT,J)=A(NT,J)/A(NT,NT)
CAMGE JX,SB1M1 ;DONE
AOJA JX,LCOL
MOVEM TAC1,@TEMP2 ;A(NT,NT)=PIVOT
CAMGE NT,SB1M1 ;INVERSE DONE?
AOJA NT,MINVLP ;NOPE, ITER AGAIN
;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
IMUL KX,SB2M1 ;CALC BOTH ROW OFFSETS
ADD TAC1,TEMP3
ADD KX,TEMP3 ;***
MOVEI JX,1
HRLI TAC1,JX
HRLI KX,JX
SWP1: MOVE IX,@TAC1
EXCH IX,@KX ;EXCHANGE ITEMS IN ROWS
MOVEM IX,@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 JX,@LX
EXCH JX,@TAC1
MOVEM JX,@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
NFERR (56,0)
PUSHJ P,INLMES
ASCIZ /
% Singular matrix inverted/
PUSHJ P,GOSR3
OUT: SKIPE LIBFLG
JRST OUT2
OUT3: POP P,TAC1
POPJ P,0
OUT2: NFERR (95,0)
PUSHJ P,INLMES
ASCIZ /
% Over or underflow occurred during MAT INV/
PUSHJ P,GOSR3
JRST OUT3
XLIST
IFN BASTEK,<
LIST
SUBTTL PLOT FUNCTIONS
OPDEF IMAGE [TTCALL 15,]
EXTERN XORG,YORG,XABS,YABS,PLTTMP,PLTOUT,PLTIN
EXTERN XMAX,YMAX
EXTERN INCNT,INDSK,INPT,STADSK
PAGPLT: MOVEI N,33 ;SETUP ESC CHARACTER
PUSHJ P,PLTSAV ;OUTPUT IT IN IMAGE
MOVEI N,14 ;SETUP FORM FEED
PUSHJ P,PLTSAV ;OUTPUT IT IN IMAGE
MOVEI N,1 ;SLEEP FOR PAGE
SLEEP N, ;GOOD NIGHT
POPJ P, ;RETURN
INIPLT: SETZM XORG ;CLEAR X ORIGIN
SETZM YORG ;CLEAR Y ORIGIN
SETZM XABS ;CLEAR X ABSOLUTE
SETZM YABS ;CLEAR Y ABSOLUTE
POPJ P, ;RETURN
STRPLT: MOVEI N,35 ;SETUP GRAPHICS MODE
PUSHJ P,PLTSAV ;OUTPUT AS IMAGE
MOVEI N,^D767 ;SET HIGH VALUE
MOVEM N,YMAX ;FOR YMAX
MOVEI N,^D1014 ;SET HIGH VALUE
MOVEM N,XMAX ;FOR XMAX
JRST LINPL1 ;MOVE TO (X,Y)
ORGPLT: POP Q,X1 ;GET Y ORGIN
ADDM X1,YORG ;SAVE IT
POP Q,X1 ;GET X ORIGIN
ADDM X1,XORG ;SAVE IT
POPJ P, ;RETURN
MOVPLT: OUTPUT ;OUTPUT ANYTHING IN TTY BUFFER
MOVEI X1,5 ;ENQ FOR MOVING
JRST FNDPNT ;FIND OUT WHERE WE ARE
WHRPLT: PUSHJ P,MOVPLT ;MOVE WITHOUT OUTPUT
PUSHJ P,RETPNT ;
JRST 2(A) ;AND RETURN HOME
CURPLT: OUTPUT ;
MOVEI X1,32 ;
PUSHJ P,FNDPNT ;
MOVE N,PLTTMP ;
MOVE X1,2(A) ;INTEGER OF FLOATING
TLNE X1,100 ;FLOAT BIT SET
FSC N,233 ;
MOVEM N,@2(A) ;
PUSHJ P,RETPNT ;
JRST 3(A) ;
LINPLT: MOVEI N,35 ;SETUP GRAPHICS MODE
PUSHJ P,PLTSAV ;OUTPUT AS IMAGE
MOVEI N,^D781 ;SET HIGH VALUE
MOVEM N,YMAX ;FOR Y
MOVEI N,^D1023 ;SET HIGH VALUE
MOVEM N,XMAX ;FOR X
POP Q,N ;GET UP-DOWN INDICATOR
CAILE N,0 ;INVISIBLE LINE?
PUSHJ P,LASTPT ;NO, MOVE TO LAST POINT
LINPL1: POP Q,X1 ;Y-COORDINATE
ADD X1,YORG ;ADD IN Y ORIGIN
SKIPGE X1 ;TOO SMALL?
SETZ X1, ;YES, MIN VALUE IS ZERO
CAMLE X1,YMAX ;TOO BIG?
MOVE X1,YMAX ;YES, MAKE LARGEST
MOVMM X1,YABS ;SAVE IT
POP Q,X1 ;X COORDINATE
ADD X1,XORG ;ADD IN X ORIGIN
SKIPGE X1 ;TOO SMALL?
SETZ X1, ;YES, MIN VALUE IS ZERO
CAMLE X1,XMAX ;WITHIN BOUNDS
MOVE X1,XMAX ;NO, MAKE LARGEST
MOVMM X1,XABS ;SAVE IT
PUSHJ P,LASTPT ;OUTPUT IT
MOVEI N,37 ;BACK TO ALPHA
PUSHJ P,PLTSAV ;OUTPUT AS IMAGE
POPJ P, ;RETURN
LASTPT: MOVE X1,YABS ;Y COORDINATE
IDIVI X1,^D32 ;MODULO 32
MOVE N,X1 ;PUT INTEGRAL PART IN N
ADDI N,^D32 ;CONVERT TO TEK
PUSHJ P,PLTSAV ;OUT IN IMAGE
MOVE N,YABS ;Y COORDINATE
ADDI N,140 ;
IMULI X1,^D32 ;
SUB N,X1 ;
PUSHJ P,PLTSAV ;OUT IN IMAGE
MOVE X1,XABS ;X COORDINATE
IDIVI X1,^D32 ;MODULO 32
MOVE N,X1 ;INTEGRAL PART TO N
ADDI N,^D32 ;
PUSHJ P,PLTSAV ;OUTPUT IN IMAGE
MOVE N,XABS ;X COORDINATE
ADDI N,100 ;TEK SCALE
IMULI X1,^D32 ;
SUB N,X1 ;
PUSHJ P,PLTSAV ;OUTPUT AS IMAGE
POPJ P, ;RETURN
FNDPNT: MOVEI N,33 ;ESC
IMAGE N ;OUTPUT AS IMAGE
IMAGE X1 ;OUTPUT CONTROL CHARACTER
CLRBFI ;CLEAR INPUT BUFFER
INCHWL PLTTMP ;INPUT AND WAIT
SETZ X1, ;INIT COUNTER
FNDPN1: INCHSL X2 ;INPUT AND SKIP IF NONE
JRST FNDPN2 ;
AOJ X1, ;UP ONE
CAIG X1,4 ;ONLY WANT FOUR
MOVEM X2,PLTTMP(X1) ;SAVE VALUE
JRST FNDPN1 ;DO MORE
FNDPN2: MOVE X1,PLTTMP+1 ;HIGH X
MOVE N,PLTTMP+2 ;LOW X
PUSHJ P,CLCPNT ;CALULATE X
SUB X1,XORG ;PLUS X ORIGIN
MOVEM X1,XABS ;SAVE IT
PUSH Q,X1 ;PUSH FOR LINPLT
MOVE X1,PLTTMP+3 ;HIGH Y
MOVE N,PLTTMP+4 ;LOW Y
PUSHJ P,CLCPNT ;CALCULATE Y
SUB X1,YORG ;PLUS Y ORIGIN
MOVEM X1,YABS ;SAVE IT
PUSH Q,X1 ;PUSH FOR LINPLT
SETZ X1, ;CLEAR X1
PUSH Q,X1 ;
JRST LINPLT ;MOVE IT
RETPNT: MOVE N,XABS ;X LOCATION
SUB N,XORG ;LESS ORIGIN
MOVE X1,0(A) ;
TLNE X1,100 ;
FSC N,233 ;FLOAT IT
MOVEM N,@0(A) ;RETURN X VALUE
MOVE N,YABS ;Y LOCATION
SUB N,YORG ;LESS ORIGIN
MOVE X1,1(A) ;
TLNE X1,100 ;
FSC N,233 ;FLOAT IT
MOVEM N,@1(A) ;RETURN IT
POPJ P, ;RETURN
CLCPNT: SUBI X1,^D32 ;
IMULI X1,^D32 ;
ADD X1,N ;
SUBI X1,^D32 ;
POPJ P, ;
PLTSAV: IMAGE N ;OUTPUT AS IMAGE
SKIPN L,PLTOUT ;SAVING PLOT
POPJ P, ;RETURN
SETOM ODF ;SETUP FOR DISK OUTPUT
MOVE C,N ;GET THE CHARACTER
PUSHJ P,OUCH ;OUTPUT IT
POPJ P, ;RETURN
SAVPLT: CAME LP,PLTIN ;CHANNEL OPENED FOR INPUT PLOTTING
JRST FNR ;TOO BAD
SETOM IFIFG ;SETUP FOR DISK INPUT
PUSHJ P,DOINPT ;DO INPUT
SVPLT1: SOSGE @INCNT-1(LP) ;ROOM FOR CHARACTER
JRST PLTFIL ;NO, FILLED BUFFER
ILDB C,@INPT-1(LP) ;GET THE CHARACTER
IMAGE C ;OUTPUT AS IMAGE
CAIE C,33 ;POSSIBLE PAGE?
JRST SVPLT1 ;NO, GO FOR NEXT
SOSGE @INCNT-1(LP) ;ANOTHER CHARACTER READY
JRST PLTFIL ;NO, FILL BUFFER
ILDB C,@INPT-1(LP) ;GET A CHARACTER
IMAGE C ;OUTPUT ASRIMAGEPAGE
JRST SVPLT1 ;NO, GO FOR NEXT
MOVEI C,1 ;SETUP FOR SLEEP
SLEEP C, ;SLEEP FOR PAGE
JRST SVPLT1 ;GO FOR NEXT
PLTFIL: DPB LP,[POINT 4,INDSK,12] ;DISK INPUT
XCT INDSK ;
DPB LP,[POINT 4,STADSK,12]
XCT STADSK
POPJ P,
DPB LP,[POINT 4,STODSK,12]
XCT STODSK
JRST SVPLT1
SETZM ACTBL-1(LP)
INLEMS(1,70,INLSYS)
JRST GOSR2
XLIST
>
LIST
SUBTTL INTRINSIC FUNCTIONS (ADAPTED FROM LIB40)
;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 0.LT.X.LE.1
;IF X.GT.1, THEN ATAN(X) = PI/2 - ATAN(1/X)
;IF X.GT.1, THEN RH(A) =-1, AND LH(A) = -SGN(X)
;IF X.LT.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.LT.2^-33, THEN RETURN WITH...
POPJ P, ;ATAN(X)=X
HLLO B, N ;SAVE SIGN, SET RH(A) = -1
CAML T, A2 ;IF A.GT.2^33, THEN RETURN WITH
JRST AT4 ;ATAN(X) = PI/2
MOVSI T1, (1.0) ;FORM 1.0 IN T1
CAMG T, T1 ;IS ABSF(X).GT.1.0?
TRZA B, -1 ;IF T .LE. 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)
JRST NEGANS ;SKIP
AT4: MOVE N, PIOT ;GET PI/2 AS ANSWER
NEGANS: SKIPGE B ;LH(A)= -SGN(T) IF B.GT.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.
INTB1: CAML N,MOD1 ;IS ARGUMENT.LE.2**26?
JRST INTB2 ;YES; IT MUST BE AN INTEGER ALREADY
FAD N,MOD1
FSB N,MOD1 ;NOW FRACTIONAL PART HAS BEEN LOST
INTB2: PUSHJ P,FIXPNT ;MAKE IT INTEGER INTEGER
JRST NEGANS ;CHECK SIGN AND EXIT.
MOD1: XWD 233400,000000 ; 2**26
ALMST1: XWD 200777,777777 ;1.0-<SMALLEST QUANTITY>
;FIX FUNCTION
FIXPNT: MULI N,400
EXCH N,T
JUMPGE T,FIXPT1
TRC T,-1
MOVNS N
FIXPT1: ASH N,-243(T)
SKIPGE T
MOVNS N
POPJ P,
FLTPNT: HLRE T,N
HLL N,T
FSC N,233
SKIPGE N
AOJE T,CPOPJ
FSC T,255
FADR N,T
POPJ P,
;
; ECHO FUNCTION
;
GL.NEC==1B15 ;ECHO/NO ECHO BIT
ECHOB: PUSH P,X1 ;SAVE X1
PUSH P,X2 ;SAVE X2
SETO X1, ;WANT LINE CHARACTERISTICS OF USER TTY
GETLCH X1 ;ASK THE MONITOR
MOVE X2,X1 ;SAVE TO RETURN OLD ECHO VALUE
TLO X1,(GL.NEC) ;ASSUME NO ECHO
SKIPN N ;IS THAT WHAT HE WANTS?
TLZ X1,(GL.NEC) ;NO, TURN ON ECHO
SETLCH X1 ;SET LINE CHARACTERISTICS
CLEAR N, ;ASSUME ECHO WAS CURRENT SETTING
TLNE X2,(GL.NEC) ;WAS ECHO OFF?
MOVEI N,1 ;YES, RETURN 1
POP P,X2 ;RESTORE X2
POP P,X1 ;RESTORE X1
POPJ P, ;RETURN FROM ECHO
;
; FIX FUNCTION
;
FIXB: MOVE B,N ;ARGUMENT
MOVMS N ;ABS
JRST INTB1 ;LET INTB HANDLE
;PI
PIB: EXP 3.14159265
;LINE #
ERRB: MOVE N,ERR ;PICK UP ERROR #
POPJ P, ;FLOAT IT
ERLB: PUSH P,X1 ;SAVE X1
MOVE X1,ERL ;PICK UP LINE # OF ERROR (POINTER)
JRST LINEB1 ;HANDLE LIKE LINEB
LINEB: PUSH P,X1 ;SAVE X1
MOVE X1,SORCLN ;SOURCE CODE LINE
LINEB1: SETZ N, ;IN CASE SAVFILNL
SKIPN NOTLIN
HRRZ N,0(X1)
POP P,X1 ;RESTORE X1
POPJ P,
;PRINT HEAD POSITION
POSB: SKIPL N ;MUST BE POSITIVE
CAILE N,^D9 ;AND LESS THAN 9
JRST CNER1 ;IS WASN'T
MOVE B,N
MOVE N,HPOS(B) ;HEAD POSN
JRST IFLOAT
;COMMON LOG FUNCTION (LOG TO THE BASE 10).
CLOGB: JUMPE N,LZERO
PUSHJ P,LOGB2 ;GET LOGE(N).
FMPR N,[XWD 177674,557305] ;MULTIPLY BY LOG10(E).
POPJ P,
;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: JUMPE N, LZERO ;CHECK FOR ZERO ARGUMENT
LOGB2: JUMPG N,LOGB3
JRST ALOGB1 ;SEND ERROR MESSAGE, GET ABS(ARG).
LOGB3: 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 EXPONENT 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 FROM 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, LZ ;STORE NEW VARIABLE IN LZ
FMP T, T ;CALCULATE 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, LZ ;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: NFERR (53,0)
PUSHJ P,INLMES
ASCIZ /
% LOG of zero/
PUSHJ P,GOSR3 ;PRINT LINE NUMBER.
MOVE N, MIFI ;PICK UP MINUS INFINITY
POPJ P, ;EXIT
;COMMON EXITS:
ZERANS: SETZI N, ;MAKE ARG ZERO
POPJ P, ;EXIT
;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
NFERR (53,0)
PUSHJ P,INLMES
ASCIZ /
% LOG of negative number/
PUSHJ P,GOSR3 ;PRINT LINE NUMBER
POP P,N ;GET ARG
MOVMS N,N
JRST LOGB3 ;USE ABS VALUE.
L7: 200542710300 ;0.69314718056
MIFI: XWD 400000,000001 ;GOAL POSTS. LARGEST NEGATIVE NUMBER.
;
; SLEEP FUNCTION
;
HB.RWJ==1B15 ;ONLY THIS JOB CAN WAKE ITSELF
HB.RTL==1B13 ;WAKE ON TTY LINE READY
SLEEPB: OUTPUT ;DUMP TTY BUFFER
PUSH P,X1 ;SAVE X1
SETO X1, ;SET UP CORRECT WAKE UP PRIVS.
WAKE X1, ;WAKE ME UP
JFCL ;DON'T CARE
MOVSI X1,(HB.RWJ!HB.RTL) ;WAKE UP PRIVS.
HIBER X1, ;HIBER TO SET
JFCL ;DON'T CARE AGAIN
POP P,X1 ;RESTORE X1
IMULI N,^D1000 ;CONVERT TO MSEC.
HRLI N,(HB.RWJ!HB.RTL) ;SET WAKE UP CODES
HIBER N, ;GOODNIGHT
JFCL ;IGNORE HIBER NOT THERE
SETO N, ;ASSUME WOKEN BY TTY INPUT LINE
SKPINL ;IS THERE A LINE READY?
CLEAR N, ;NO, WAKE UP BY TIMEOUT
POPJ P, ;RETURN
;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: SETZM LIBFLG ;ENTRY TO COSINE RADIANS ROUTINE
FADR N,PIOT ;ADD PI/2
SKIPE LIBFLG ;FALL INTO SINE ROUTINE.
JRST SINLRG
;
; SIN FUNCTION
;
SINB: ;ENTRY TO SINE RADIANS ROUTINE
MOVEM N, SX ;SAVE THE ARG
MOVM T,N ;GET ABS OF ARGUMENT
CAMG T, SP2 ;SINX = X IF X.LT.2^-10
POPJ P, ;EXIT WITH ANS=ARG
FDVR T, PIOT ;DIVIDE X BY PI/2
CAMG T, ONE ;IS X/(PI/2) .LT. 1.0?
JRST S2 ;YES, ARG IN 1ST QUADRANT ALREADY
MULI T, 400 ;NO, SEPARATE FRACTION AND EXP.
CAILE T,232
JRST SINLRG
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 RANGE (-1,1)
FADRI T,0 ;NORMALIZE THE ARGUMENT
JUMPE T1, S2 ;REDUCED TO FIRST QUAD IF BITS 00
TLCE T1, 1000 ;SUBTRACT 1.0 FROM ARG IF BITS ARE
FSBRI T,201400 ;01 OR 11
TLCE T1, 3000 ;CHECK FOR FIRST QUADRANT, 01
TLNN T1, 3000 ;CHECK FOR THIRD QUADRANT, 10
MOVNS T ;01,10
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
S2B: 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
SINLRG: NFERR (96,0)
PUSHJ P,INLMES
ASCIZ /
% Magnitude of SIN or COS arg too large to be significant/
PUSHJ P,GOSR3
SETZ N,
POPJ P,
;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 0.LT.F.LT.1
;SQRT(X) IS THEN CALCULATED AS (SQRT(X))*(2**B)
;SQRT(F) IS CALCULATED BY N LINEAR APPROXIMATION, THE NATURE
;OF WHICH DEPENDS ON WHETHER 1/4 .LT. F .LT. 1/2 OR 1/2 .LT. F .LT. 1,
;FOLLOWED BY TWO ITERATIONS OF NEWTON'S METHOD.
SQRTB: MOVE T, N ;PICK UP THE ARGUMENT IN T
JUMPL T,SQRMIN ;SQRT OF NEGATIVE NUMBER?
JUMPE T,SQRT1 ;CHECK FOR ARGUMENT OF ZERO
SQRTB0: ASHC T, -33 ;PUT EXPONENT IN T, FRACTION IN T1
SUBI T, 201 ;SUBTRACT 201 FROM EXPONENT
ROT T, -1 ;CUT EXP IN HALF, SAVE ODD BIT
HRRM T,EX1 ;SAVE FOR FUTURE SCALING OF ANS
;IN FSC N,. INSTRUCTION
LSH T, -43 ;GET BIT SAVED BY PREVIOUS INST.
ASH T1, -10 ;PUT FRACTION IN PROPER POSITION
FSC T1, 177(T) ;PUT EXPONENT OF FRACT TO -1 OR 0
MOVEM T1, N ;SAVE IT. 1/4 .LT. F .LT. 1
FMP T1, SQCON1(T) ;LINEAR FIRST APPROX,DEPENDS ON
FAD T1, SQCON2(T) ;WHETHER 1/4.LT.F.LT.1/2 OR 1/2.LT.F.LT.1.
MOVE T, N ;START NEWTONS METHOD WITH FRAC
FDV T, T1 ;CALCULATE X(0)/X(1)
FAD T1, T ;X(1) + X(0)/X(1)
FSC T1, -1 ;1/2(X(1) + X(0)/X(1))
FDV N, T1 ;X(0)/X(2)
FADR N, T1 ;X(2) + X(0)/X(2)
XCT EX1
SQRT1: POPJ P, ;EXIT
SQCON1: 0.8125 ;CONSTANT, USED IF 1/4.LT.FRAC.LT.1/2
0.578125 ;CONSTANT, USED IF 1/2.LT.FRAC.LT.1
SQCON2: 0.302734 ;CONSTANT, USED IF 1/4.LT.FRAC.LT.1/2
0.421875 ;CONSTANT, USED IF 1/2.LT.FRAC.LT.1
SQRMIN: PUSH P,T ;SAVE ARG
NFERR (54,0)
PUSHJ P,INLMES
ASCIZ /
% SQRT of negative number/
PUSHJ P,GOSR3 ;PRINT LINE NUMBER
POP P,T ;GET ARG
MOVMS T
JRST SQRTB0 ;USE ABSOLUTE VALUE
;TAN - SINGLE PRECISION TANGENT ROUTINE.
;
;BASED ON ACM ALGORITHM 229, (COMM. ACM, 7, MAY 1964, J. MORELOCK).
;METHOD:
;
;TAN(N*(PI/2)+A) = -(1/TAN(A)) IF N IS ODD,
;TAN(N*(PI/2)+A) = TAN(A) IF N IS EVEN.
;
;/A/ IS .LE. 0.5*(PI/2).
;ON ENTRY, THE ARG IS IN AC N.
;ON EXIT, THE ANSWER IS IN AC N.
;COTAN (X)=TAN(PI/2-X)
COTB: JUMPE N,TANB1
MOVNS N ;CALCULATE -X...
FADR N,PIOT ;PLUS PI/2
TANB: PUSH P,T1
MOVM T1,N
CAMG T1,[3.464102E-4] ;A CHECK FOR TAN(X)=X,
JRST TAN55 ;MORE OR LESS.
PUSH P,T
PUSH P,A
FDVR T1,PIOT
MOVEI T,1
CAMGE T1,[XWD 200400,000000] ;REDUCE ARG?
JRST TAN2 ;NO NEED.
TAN0: MOVE T,T1 ;YES.
MULI T1,400
SETZM LIBFLG
ASH A,-243(T1)
SKIPN LIBFLG
JRST TAN05
SETZ N,
JRST TAN52
TAN05: MOVE T1,T
ANDI A,1 ;A POINTS TO QUADRANT.
JUMPE A,TALAB1
MOVN N,N
TALAB1: FSBRI T1,200400
MULI T1,400
EXCH T1,A
MOVEI T,0
CAIL A,233
TDZA T1,T1
ASHC T,-200(A)
ANDI T,1 ;T POINTS TO INVERSION.
LSH T1,-10
TLO T1,200000
FSBRI T1,200400
MOVM T1,T1
TAN1: JUMPGE N,TALAB2 ;ORIGINAL ARG OR QUADRANT
MOVN T1,T1 ;REQUIRES NEGATIVE.
TALAB2: MOVE N,T1
FMPR N,PIOT
MOVM A,N
CAMGE A,[3.464102E-4]
JRST TAN6
TAN2: PUSH P,B ;ROUTINE TO CALC TAN(A),
MOVE A,N ;BASED ON ACM ALGORITHM
FMPR A,A ;REFERENCED ABOVE.
MOVE B,A
FDVRI B,572340 ;-18.
FADRI B,204700 ;14.
MOVN T1,A
FDVR T1,B
FADRI T1,204500 ;10.
MOVN B,A
FDVR B,T1
FADRI B,203600 ;6.
MOVN T1,A
FDVR T1,B
FADRI T1,202400 ;2.
FMPRI N,202400
FMPR N,T1
FMPR T1,T1
FSBR T1,A
FDVR N,T1
POP P,B
TAN6: SETZM LIBFLG
JUMPN T,TAN52 ;IF T =0, INVERT.
HRLZI T,201400
FDVRM T,N
SKIPE LIBFLG
PUSHJ P,TANB1
TAN52: POP P,A
POP P,T
TAN55: POP P,T1
TAN4: POPJ P,
TANB1: PUSH P,N
NFERR (97,0)
PUSHJ P,INLMES
ASCIZ ?
% TAN of PI/2 or COTAN of zero?
PUSHJ P,GOSR3 ;PRINT LINE NUMBER AND EXIT WITH LARGE ANSWER.
POP P,N
JUMPL N,TALAB3
HRLOI N,377777
POPJ P,
TALAB3: MOVE N,MIFI
POPJ P,
;FLOATING POINT SINGLE PRECISION EXPONENTIAL FUNCTION
;THE ARGUMENT IS RESTRICTED TO THE FOLLOWING RANGE
; -88.028.LT.X.LT.88.028
;IF X.LT.-88.028, THE PROGRAM RETURNS ZERO AS THE ANSWER
;IF X.GT.88.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 EXTOLG ;EXP TOO LARGE.;##MSG +CON OR STOP?
EXP1: SETZM 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, EX1 ;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 EX1 ;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: JUMPG T,EXTOL1
NFERR (98,0)
PUSHJ P,INLMES
ASCIZ /
% Underflow in EXP/
PUSHJ P,GOSR3
SETZ N,
POPJ P,
EXTOL1: NFERR (99,0)
PUSHJ P,INLMES
ASCIZ /
% Overflow in EXP/
PUSHJ P,GOSR3 ;PRINT LINE NUMBER
HRLOI N,377777 ;GET LARGEST ANSWER AND RETURN.
POPJ P,
;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 T,EXP3A
JUMPN N,EXP2A0
JUMPL T,EXPB3
POPJ P,
EXP2A0: PUSH P,T ;SAVE FOR OVER/UNDERFLOW CHECKING.
PUSH P,N
SETZM LIBFLG ;CLEAR THE OVER/UNDERFLOW FLAG.
MOVSI T1,(1.0)
JUMPGE T,FEXP2
MOVMS T
FDVRM T1,N
MOVSI T1,(1.0)
JRST FEXP2
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 THROUGH
MOVE N, T1 ;PICK UP RESULT FROM T1
SKIPE LIBFLG ;IF OVER/UNDERFLOW,
JRST FEXP4 ;GO TO FEXP4.
POP P,T ;CLEAR OFF PLIST. DO NOT POP INTO N!!!!
POP P,T ;(BECAUSE THE ANSWER IS IN N).
POPJ P, ;EXIT
FEXP4: POP P,N ;OVER/UNDERFLOW ROUTINE.
POP P,T
MOVM T1,N
CAMG T1,ONE
JRST FXLAB1 ;/BASE/.GT.1,EXP.GT.0 MEANS OVER.
JUMPG T,FXLAB2 ;/BASE/.GT.1,EXP.LT.0 MEANS UNDER.
JRST EXP3D3 ;/BASE/.LT.1,EXP.GT.0 MEANS UNDER.
FXLAB1: JUMPG T,EXP3D3 ;/BASE/.LT.1,EXP.LT.0 MEANS OVER.
FXLAB2: JUMPG N,FXLAB3 ;THIS IS OVER. WHAT IS THE SIGN?
TRNE T,1
JRST FEXP5
FXLAB3: PUSHJ P,EXP3D2
HRLOI N,377777
POPJ P,
FEXP5: PUSHJ P,EXP3D2
MOVE N,MIFI
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?
JUMPN N,EXP3A0 ;IS BASE ZERO?
JUMPL T,EXPB3 ;ERROR IF BASE=0, EXP .LT.0.
POPJ P, ;IMMED. RETURN IF BASE=0, EXP.GE.0.
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 ;IS T1 .GT. 0
HRRZ B,T1 ;SET UP B AS AN INDEX REG.
CAILE B,43
JRST EXP3GO
MOVEI T1,0 ;CLEAR OUT AC T1
LSHC T1,(B) ;SHIFT LFT BY CONTENTS OF B
JUMPN A,EXP3GO ;IS EXPONENT AN INTEGER ?
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
SETZM LIBFLG ;CLEAR THE OVER/UNDERFLOW FLAG.
FMPR N,(P) ;CALCULATE B*LOG(N)
POP P,T ;RESTORE EXP.
SKIPE LIBFLG ;EXP3D AND EXP3D1 ARE ERROR ROUTINES.
JRST EXP3D
MOVM T,N
CAMLE T,E7
JRST EXP3D1
PUSHJ P, EXPB ;CALCULATE EXP(B*LOG(N))
POPJ P, ;RETURN
EXP3D: MOVM T,N
CAML T,ONE
JRST EXP3A ;UNDERFLOW IN ARG TO EXP MEANS ANS=1.
EXP3D1: JUMPL N,EXP3D3 ;OVERFLOW MEANS OVER/UNDER IN ANS.
EXP3D2: NFERR (100,0)
PUSHJ P,INLMES
ASCIZ /
% Overflow/
JRST LRGNS1
EXP3D3: NFERR (101,0)
PUSHJ P,INLMES
ASCIZ /
% Underflow/
PUSHJ P,GOSR3
SETZ N,
POPJ P,
EXP3A: MOVSI N,(1.0) ;ANSWER IS 1.0
POPJ P,
EXPB3: NFERR (102,0)
PUSHJ P,INLMES
ASCIZ /
% Zero to a negative power/
LRGNS1: PUSHJ P,GOSR3
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
NFERR (103,0)
PUSHJ P,INLMES
ASCIZ /
% Absolute value raised to power/
PUSHJ P,GOSR3
POP P,T
POP P,N
EXP3C0: MOVMS N
JRST EXP3A0
EXP1.0: JUMPE T,[MOVEI N,1
POPJ P,]
JUMPN N,BASNT0 ;GO IF BASE NE 0
JUMPL T,EXPB3 ;OVER FLOW
POPJ P,
BASNT0: JUMPL T,[TRNN T,1
MOVMS N
CAIE N,1
CAMN N,[-1]
POPJ P,
MOVEI N,0
POPJ P,]
MOVEI T1,1
PUSH P,T1
JUMPG N,IEXP2 ;
TRNN T,1
JRST IEXP2 ;
SETCMM (P) ;
JRST IEXP2 ;
;
IEXP1: IMUL N,N ;
SKIPE LIBFLG ;
JRST IOVER ;
LSH T,-1 ;
IEXP2: TRZE T,1 ;
IMUL T1,N ;
SKIPE LIBFLG ;
JRST IOVER ;
JUMPG T,IEXP1 ;
MOVE N,T1 ;
IEXP3: POP P,T1 ;
POPJ P,
IOVER: SETZM LIBFLG ;
PUSHJ P,EXP3D2 ;
SKIPL (P) ;
JRST IEXP3 ;
MOVNS N,N ;
SUBI N,1 ;
JRST IEXP3 ;
SUBTTL INTRINSIC FUNCTIONS
;ASCIIB IS THE LIBRARY ROUTINE FOR ASCII
ASCIIB: SOS T,MASAPP
HRRZ X1,+1(T)
MOVE N,0(X1)
LSH N,-^D29
POPJ P,
;CHRB IS THE LIBRARY ROUTINE FOR CHR$.
CHRB: CAIGE N,^D128
CAIGE N,0 ;
JRST CHRERR ;ERROR
CAIG N,^D13
CAIGE N,^D10
JRST CHRB1 ;OK
SKIPN CRTVAL ;USER MAKE 10-13 LEGAL?
JRST PTXER1 ;ILLEGAL LF, FF, VT CHARACTER.
CHRB1: MOVEI T,1
PUSHJ P,VCHTSW ;GET SPACE FOR STRING.
LSH N,^D29
MOVEM N,(T)
HRRZI N,(T)
HRLI N,777777
POPJ P,
CHRERR: INLERR(85,43,</
? CHR$ argument/>)
JRST OUTBND
;INSTRB IS THE LIBRARY ROUTINE FOR INSTR.
INSTRB: MOVEI N,1 ;ENTRY POINT.
JRST INSTR1
JUMP
POP P,T
POP P,N
PUSH P,T
CAIGE N,1
JRST INSERR
INSTR1: PUSH P,X1
PUSH P,X2
PUSH P,F
MOVE F,N ;START POSITION IN F.
SETZM VIRWRD
MOVE X2,MASAPP
MOVE X1,0(X2)
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STR
MOVEM X1,0(X2)
MOVE X1,-1(X2)
PUSHJ P,CKVSTR
MOVEM X1,-1(X2)
SOS N,MASAPP
PUSHJ P,LENBF ;GET LEN OF 1ST STR.
AOS MASAPP
AOS X2,MASAPP
CAMG F,N ;LEN .LT. START POSITION?
JRST INSTR3 ;NO.
INSOUT: SETZ N,
INSOU1: POP P,F
POP P,X2
POP P,X1
SOS MASAPP
SOS MASAPP
POPJ P,
INSTR3: MOVE X1,-1(X2)
PUSH P,C
MOVE C,N ;FIRST LEN IN C.
MOVE N,MASAPP
PUSH P,X1 ;LENBF DESTROYS X1
PUSHJ P,LENBF ;GET LENGTH OF 2ND STR.
POP P,X1
AOS MASAPP
JUMPN N,INSTR4 ;NULL?
POP P,C ;YES.
MOVEI N,(F)
JRST INSOU1
INSTR4: MOVE X2,(X2)
PUSH P,G
PUSH P,A
PUSH P,B
PUSH P,E
PUSH P,T1
MOVE G,N ;2ND LEN IN G.
MOVE A,MASAPP ;GET ANY APPD STRS
TLNN X1,777777 ;IN TEMP. SPACE.
JRST INSTR6 ;ALSO KEYS IN THE
TLNE X1,377777 ;FORM -N,LOC.
JRST INSTR5
MOVE X1,(X1)
TLNN X1,777777
JRST INSTR6
INSTR5: JUMPLE X1,INSTR6
MOVE N,X1
PUSHJ P,STRETT
MOVE X1,N
MOVE X2,(A)
INSTR6: TLNN X2,777777
JRST INSTR8
TLNE X2,377777
JRST INSTR7
MOVE X2,(X2)
TLNN X2,777777
JRST INSTR8
INSTR7: JUMPLE X2,INSTR8
MOVEM X1,-1(A)
MOVE N,X2
PUSHJ P,STRETT
MOVE X2,N
MOVE X1,-1(A)
INSTR8: MOVEI A,(F) ;SEARCH.
MOVEI B,1
INST85: MOVEI N,-1(A) ;GET C(A)TH CHAR OF 1ST
IDIVI N,5 ;STR TO T1 AND C(B)TH
ADDI N,(X1) ;CHAR OF 2ND STR TO E.
HLL N,INSPTR(T)
LDB T1,N
MOVEI N,-1(B)
IDIVI N,5
ADDI N,(X2)
HLL N,INSPTR(T)
LDB E,N
CAIE T1,(E) ;CHARS EQUAL?
JRST INST11 ;NO.
AOJ B, ;YES.
CAIG B,(G) ;FINISHED WITH 2ND STR?
JRST INSTR9 ;NO.
MOVEI N,(F) ;YES.
INSOU2: POP P,T1
POP P,E
POP P,B
POP P,A
POP P,G
POP P,C
JRST INSOU1
INSTR9: AOJ A,
CAIG A,(C) ;AT END OF 1ST STR?
JRST INST85 ;NO.
INST11: AOJ F, ;YES. TRY AGAIN FROM NEXT PLACE.
CAIG F,(C) ;NO MORE PLACES?
JRST INSTR8
SETZ N, ;NO MORE. FAIL.
JRST INSOU2
440700000000
INSPTR: 350700000000
260700000000
170700000000
100700000000
010700000000
INSERR: INLERR(86,44,</
? INSTR argument/>)
JRST OUTBND
;LEFTB IS THE LIBRARY ROUTINE FOR LEFT$.
LEFTB: CAIGE N,1 ;ARG MUST BE .GE. 1.
JRST LEFERR
SOS T,MASAPP
MOVE T,1(T) ;STRING KEY TO AC 1.
MOVE X1,T
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING
MOVE T,X1
TLNE T,777777
JRST LEFTB1
LEFOU1: SETZ N, ;NULL ANSWER.
POPJ P,
LEFTB1: JUMPL T,LEFTB2
EXCH T,N ;APP BLK. IS KEY.
JRST LEFTB4
LEFTB2: TLNE T,377777
JRST LEFTB3
MOVE T,(T)
TLNN T,777777
JRST LEFOU1
LEFTB3: PUSH P,T1
HLRE T1,T
EXCH N,T
MOVN T,T
CAMLE T,T1
HRL N,T
POP P,T1
POPJ P, ;EXIT.
LEFTB4: PUSH P,T1
PUSH P,X1
MOVE T1,N ;SAVE KEY IN T1.
MOVE X1,T ;SAVE REQ. LEN IN X1.
PUSHJ P,LENAPB
CAILE N,(X1)
JRST LEFTB5
MOVE N,T1
JRST LEFOU2
LEFTB5: HRRZ T,T1
LEFTB6: HLRE N,1(T) ;SUCCESSIVELY "SUBTRACT"
ADD X1,N ;SUBSTRINGS UNTIL
JUMPLE X1,LEFTB7 ;X1 BECOMES .LE. 0.
AOJA T,LEFTB6
LEFTB7: JUMPE X1,LEFTB8
SUB X1,N ;TRUNCATE THE SUBSTRING KEY.
MOVN X1,X1
HRLM X1,1(T)
LEFTB8: SUBI T,-1(T1) ;TRUNCATE THE BLOCK.
MOVEM T,(T1)
HRLM T,T1
MOVE N,T1
LEFOU2: POP P,X1
POP P,T1
POPJ P, ;EXIT.
LEFERR: INLERR(87,45,</
? LEFT$ argument/>)
JRST OUTBND
;LEN ROUTINE.
LENB:
LENBF:
SOS T,MASAPP
MOVE N,+1(T)
MOVE X1,N
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING
MOVE N,X1
TLNE N,777777 ;NULL STRING?
JRST LENB4 ;NO.
LENB2: SETZ N, ;YES, NULL STRING.
POPJ P,
LENB4: JUMPG N,LENAPP ;APPEND KEY?
TLNE N,377777 ;NO. REAL KEY?
JRST LENB3 ;YES, REAL KEY.
MOVE T,N ;NO, NOT REAL KEY, SO
MOVE N,(T) ;RETRIEVE THE REAL KEY.
JUMPGE N,LENB2 ;MUST BE EITHER NULL STRING OR
LENB3: HLRE N,N ;LENGTH IN LH.
MOVM N,N
JRST LENAP2
LENAPP: PUSHJ P,LENAPB ;APPEND KEY.
LENAP2: POPJ P,
LENAPB: PUSH P,X1 ;LENGTH OF STRING IN APP BLK ROUTINE.
PUSH P,X2
HLRZ T,N
HRRZ X1,N
SETZ N,
LNLAB1: SOJL T,LENAP1 ;T HAS NUMBER OF KEYS.
HLRE X2,1(X1)
SUB N,X2 ;ADD UP THE LENGTHS
AOJA X1,LNLAB1
LENAP1: CAILE N,^D132 ;CHECK LENGTH .LE. 132.
JRST LENERR
POP P,X2
POP P,X1
POPJ P,
LENERR: INLERR(7,46,</
? String formula more than 132 characters/>)
JRST GOSR2
;MIDB IS THE LIBRARY ROUTINE FOR MID$.
MIDB: HRLOI T,377777 ;ENTRY POINT.
MOVEM T,MIDSAV
JRST MIDB1
CAIGE N,1 ;ENTRY POINT.
JRST MIDERR
MOVEM N,MIDSAV ;REQUESTED LENGTH.
POP P,T ;CLEAR PLIST AND ALSO GET ARG.
POP P,N
PUSH P,T
MIDB1: CAIGE N,1
JRST MIDERR
SOJ N,
PUSH P,C
MOVE C,N
PUSHJ P,LENBF
AOS MASAPP
SUBI N,(C) ;TOTAL LENGTH + 1 - STARTING POINT.
JUMPLE N,MIDB2
CAMLE N,MIDSAV
MOVE N,MIDSAV
EXCH N,C
MOVE T,MASAPP ;C HAS LEN OF SUBSTR, N HAS START POINT.
JRST RIENTY ;GO TO RIGHT$ ROUTINE.
MIDB2: SETZ N,
JRST RIGOU1
MIDERR: INLERR(88,47,</
? MID$ argument/>)
JRST OUTBND
;RIGHTB IS THE LIBRARY ROUTINE FOR RIGHT$. IT IS ALSO
;USED BY MID$.
RIGHTB: CAIGE N,1 ;ARG MUST BE .GE. 1.
JRST RIGERR
PUSH P,C
MOVE C,N ;TOTAL LENGTH REQ. IN C.
PUSHJ P,LENBF
AOS T,MASAPP
CAILE N,(C) ;REQ. LEN .GE. ACTUAL LEN?
JRST RIGHT1 ;NO.
MOVE N,(T) ;YES. RETURN THE ENTIRE STR.
MOVE X1,N
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING
MOVE N,X1
JRST RIGOU1
RIGHT1: SUBI N,(C) ;START PLACE -1 IN N.
RIENTY: PUSH P,T1 ;MID$ ENTERS HERE.
PUSH P,A
PUSH P,X1
PUSH P,X2
MOVE T1,(T) ;ORIGINAL KEY IN T1.
MOVE X1,T1
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STR
MOVE T1,X1
JUMPLE T1,RIGHT3
MOVE X1,N ;APPEND KEY.
MOVE X2,T
MOVE N,T1
PUSHJ P,STRETT ;GET APPENDED STRING
MOVE T1,N ;INTO TEMP. SPACE.
MOVE T,X2
MOVE N,X1
JRST RIGHT2
RIGHT3: TLNN T1,377777 ;NON-APP KEY.
MOVE T1,(T1)
HRRZI T1,(T1)
CAML T1,VARFRE ;CAN THIS STR BE WRITTEN OVER?
JRST RIGHT2 ;YES.
MOVEI T,(C) ;NO.
PUSHJ P,VCHTSC ;GET ROOM FOR NEW STR.
HRRZI A,(T) ;NEW LOW WORD TO A.
MOVE T1,MASAPP ;GET KEY
MOVE T1,(T1) ;AGAIN IN T1.
MOVE X1,T1
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STR
MOVE T1,X1
TLNE T1,377777
JRST RIGH15
SKIPA T1,(T1)
RIGHT2: MOVEI A,(T1) ;NEW LOW WORD IS OLD LOW WORD.
RIGH15: IDIVI N,5 ;N HAS START CHAR -1.
ADDI N,(T1) ;T1 HAS OLD START WORD.
JUMPN T,RIGH16 ;BLT OR ILDB?
HRL N,N ;BLT.
HRRI N,(A) ;A HAS NEW START WORD.
MOVEI X1,4(C) ;C HAS TOTAL SUBSTR. LENGTH.
IDIVI X1,5 ;MOVE THIS MANY WORDS.
ADDI X1,-1(A)
PUSH P,N
BLT N,(X1)
POP P,N
MOVN C,C
HRL N,C ;KEY TO N.
JRST RIGOUT
RIGH16: HLL N,INSPTR-1(T) ;ILDB.
HRRZI T,(A)
HRLI A,440700
MOVN C,C
HRL T,C ;KEY TO T.
RGLAB1: ILDB T1,N
IDPB T1,A
AOJL C,RGLAB1
MOVE N,T ;KEY TO N.
RIGOUT: POP P,X2
POP P,X1
POP P,A
POP P,T1
RIGOU1: POP P,C
SOS MASAPP
POPJ P,
RIGERR: INLERR(89,48,</
? RIGHT$ argument/>)
JRST OUTBND
;SPACEB IS THE LIBRARY ROUTINE FOR SPACE$.
SPACEB: CAIL N,1
CAIL N,^D133
JRST SPACER
PUSH P,X1
PUSH P,X2
MOVE T,N
PUSHJ P,VCHTSC ;GET SPACE FOR STRING.
MOVE X1,N ;SAVE NEGATIVE STRING LENGTH.
SUBI X1,1
IDIVI X1,5
ADDI X1,(T)
MOVE X2,[ASCIZ / /]
MOVN N,N
HRL N,N
HRR N,T
SPLAB1: MOVEM X2,(T)
AOJ T,
CAIG T,(X1)
JRST SPLAB1
POP P,X2
POP P,X1
POPJ P, ;EXIT.
SPACER: INLERR(90,49,</
? SPACE$ argument/>)
JRST OUTBND
;TIMEB IS THE LIBRARY FUNCTION FOR TIME OF DAY AS HH:MM:SS
TIMEB: MOVEI T,10 ;SET UP FOR
HRLOI N,-10 ;AN 8-CHAR STRING
PUSHJ P,TIMDAT
MSTIME X1, ;GET TIME
IDIVI X1,^D1000 ;TO SECONDS
IDIVI X1,^D60 ;TO MINS
PUSH P,X2 ;SAVE SECONDS
IDIVI X1,^D60 ;TO HOURS
PUSH P,X2 ;SAVE MINS
PUSHJ P,TWOTIM ;PUT OUT HOURS
POP P,X1 ;GET MINS
PUSHJ P,COLTIM ;PUT 'EM OUT
POP P,X1 ;GET SECS
PUSHJ P,COLTIM ;DO LIKEWISE
RETTIM: POP P,X2 ;RESTORE
POP P,X1 ;THE ACS
POPJ P, ;AND RETURN
COLTIM: MOVEI X2,":" ;PUT OUT COLON
IDPB X2,T
TWOTIM: IDIVI X1,^D10 ;DIGITS TO X1,X2
ADDI X1,"0" ;TO ASCII
IDPB X1,T
ADDI X2,"0" ;TO ASCII
IDPB X2,T ;OUT
POPJ P, ;RETURN
;DATEB IS THE LIBRARY FUNCTION FOR DATE AS DD-MON-YY
;
; DAY$ FUNCTION
;
DAYB: PUSH P,X1 ;SAVE X1
PUSH P,X2 ;SAVE X2
DATE X1, ;ASK MONITOR FOR DEC'S DATE
IDIVI X1,^D31 ;# MONTHS IN X1, # DAYS-1 IN X2
PUSH P,X1+1 ;SAVE DAY-1 FOR LATER
IDIVI X1,^D12 ;YEAR+1964 IN X1, # MONTHS-1 IN X2
PUSH P,X1 ;SAVE YEAR
MOVE N,X2 ;SAVE MONTH-1 IN N
IDIVI X1,4 ;# OF LEAP YEARS SINCE 1964
SKIPN X2 ;IS THIS A LEAP YEAR?
CAILE N,1 ;YES, JANUARY OF FEBRUARY?
AOJ X1, ;LEAP DAY HAS PASSED, CORRECT FOR IT
POP P,X2 ;RETURN YEARS SINCE 1964
SOJ X2, ;THIS IS NUMBER OF FULLYEARS
IMULI X2,^D365 ;# DAYS (LESS LEAP DAYS)
ADD X2,X1 ;ACCOUNT FOR LEAP DAYS
MOVE X1,N ;GET MONTH-1
IMULI N,^D31 ;# DAYS IN 31 DAY MONTH
ADD X2,N ;ADD TO TOTAL DAYS
IMULI X1,-3 ;NEED SHIFT FACTOR FOR FUDGE
MOVE N,[OCT 766555443300] ;FUDGE FACTOR
LSH N,(X1) ;GET NUMBER OF EXTRA DAYS ADDED
ANDI N,7 ;BECAUSE OF INCONSISTENT MONTHS
SUB X2,N ;# DAYS IN FULL MONTHS
POP P,X1 ;RETURN DAY-1
ADDI X1,1(X2) ;# DAYS SINCE 1-JAN-64
IDIVI X1,7 ;# WEEKS SINCE 1-JAN-64 IN X1
;DAY NUMBER OF TODAY IN X2
MOVE T,[OCT 071431014411] ;NUMBER CHARACTERS IN DAY
MOVE X1,X2 ;DAY NUMBER TO X1
IMULI X1,-5 ;SHIFT FACTOR
LSH T,(X1) ;MOVE NUMBER OF CHARACTERS
ANDI T,37 ;REMOVE GARBAGE
MOVN N,T ;WILL NEED THIS MANY CHARACTERS
MOVSS N ;FOR THE DAY
PUSHJ P,VCHTSC ;GET THE SPACE
HRR N,T ;ADDRESS OF STRING, RETURN IN N
HRLI T,440700 ;BYTE POINTER TO SPACE
LSH X2,1 ;CONVERT DAY NUMBER
ADDI X2,MNEDAY ;INTO BYTE POINTER
HRLI X2,440700 ;TO CORRECT DAY
DAYB1: ILDB X1,X2 ;GET A CHARACTER OF THE DAY
JUMPE X1,RETTIM ;NULL ENDS THE STRING
IDPB X1,T ;MOVE TO SPACE
JRST DAYB1 ;CONTINUE
MNEDAY: ASCIZ /WEDNESDAY/
ASCIZ /THURSDAY/
ASCIZ /FRIDAY/
ASCIZ /SATURDAY/
ASCIZ /SUNDAY/
ASCIZ /MONDAY/
ASCIZ /TUESDAY/
;
; DATE$ FUNCTION
;
DATEB: MOVEI T,11 ;SET UP FOR
HRLOI N,-11 ;A 9-CHAR STRING
PUSHJ P,TIMDAT
DATE X1, ;GET DATE
IDIVI X1,^D31 ;GET DAYS
PUSH P,X1 ;SAVE REST
MOVEI X1,1(X2) ;DAY OF MONTH
PUSHJ P,TWOTIM ;PUT IT OUT
MOVEI X1,"-" ;-
IDPB X1,T
POP P,X1 ;GET BACK REST
IDIVI X1,^D12 ;MONTH & YEAR
PUSH P,X1 ;SAVE YEAR
MOVEI X1,DATTBL(X2) ;MAKE BYTE
HRLI X1,440700 ;FOR MONTH
DATEB1: ILDB X2,X1 ;PUT OUT THREE
IDPB X2,T ;CHAR MONTH
JUMPN X2,DATEB1 ;DATTBL IS ASCIZ
MOVEI X1,"-" ;-
DPB X1,T ;OVERWRITES NULL
POP P,X1 ;GET BACK YEAR
ADDI X1,^D64 ;ADJUST
PUSHJ P,TWOTIM ;PUT IT OUT
JRST RETTIM ;GO RETURN
TIMDAT: PUSHJ P,VCHTSC ;GET STRING SPACE
HRR N,T ;GET ADDRESS
HRLI T,440700 ;MAKE BYTE POINTER
EXCH X1,(P) ;SAVE X1, GET RETURN P.C.
PUSH P,X2 ;SAVE X2
JRST (X1) ;RETURN
;STRB IS THE LIBRARY ROUTINE FOR STR$.
STRB: MOVEI T,3
PUSHJ P,VCHTSW ;GET SPACE FOR A THREE WORD
HRLI T,440700 ;STRING.
MOVEM T,STRPTR ;SET UP BYTE POINTER.
SETZM STRCTR
MOVEI X2,STLAB1
JRST SAVCS1
STLAB1: PUSH P,Q
PUSH P,T
PUSHJ P,OUTSRF ;FORM STRING
POP P,N
HRL N,STRCTR ;SET UP ADDRESS KEY.
POP P,Q
MOVEI X2,STLAB2 ;RESTORE AC'S.
JRST RESACS
STLAB2: POPJ P, ;EXIT.
;VALB IS THE LIBRARY ROUTINE FOR VAL.
VALB: PUSHJ P,STRPL1
JRST VALERR
PUSHJ P,EVANUM ;EVALUATE THE NUMBER
JRST VALERR ;BAD FORMAT
CAME T,VALPTR ;STOPPED AT RIGHT PLACE
JRST VALERR ;NO
POP P,Q ;RESTORE Q LIST
MOVEI X2,VALAB1 ;SET RETURN FROM RESACS
JRST RESACS ;RESTORE AC'S
VALAB1: SOS MASAPP ;REMOVE ARGUMENT FROM LIST
SKIPN TYPE ;DID NUMBER EVALUATE TO FLOATING POINT?
POPJ P, ;YES, EXIT
JRST FLTPNT ;NO, INTEGER, VAL IS FLOATING, CONVERT
STRPL1: MOVE T,MASAPP
MOVE T,(T)
MOVE X1,T
SETZM VIRWRD
PUSHJ P,CKVSTR ;CHECK IF VIRTUAL STRING ARGUMENT
MOVE T,X1
TLNN T,777777
POPJ P,
TLNE T,377777 ;REAL KEY?
JRST VALB2
MOVE T,(T)
TLNN T,777777
POPJ P,
VALB2: POP P,N
PUSHJ P,SAVACS
PUSH P,Q
MOVE Q,N
MOVE N,T
HLRE T,N
JUMPG N,VALB4
MOVM T,T ;NON-APP KEY.
MOVEI X1,(T) ;SAVE NO. OF CHARS. IN X1.
IDIVI T,5
ADDI T,1 ;TRANSFER THE STRING AND
HRRZ X2,N ;GUARANTEE ROOM FOR "$"
CAML X2,VARFRE ;TERMINATING CHARACTER.
JUMPN T1,VALB5 ;NO NEED TO TRANSFER IF IT IS
MOVE X2,MASAPP
MOVEM N,(X2)
PUSHJ P,VCHTSW ;ALREADY IN TEMP SPACE WITH
HRLI T,440700 ;ROOM FOR "$".
MOVE X2,MASAPP
MOVE X2,(X2)
HRLI X2,440700
HRRI N,(T) ;NEW KEY IN N.
VALB3: ILDB T1,X2 ;TRANSFER.
IDPB T1,T
SOJG X1,VALB3
JRST VALB5 ;STRING IS SET UP, GO TO EVANUM.
VALB4: HRRZ X2,N ;APP. KEY.
ADDI T,(X2)
HLRE X1,(T)
SOJ X1,
HRLM X1,(T)
PUSHJ P,STRETT ;TRANSFER THE STRING.
HLRE X1,N
CAMN X1,[-1]
JRST VALERR
AOJ X1,
HRLI N,(X1)
VALB5: HRRZ T1,N ;GET BYTE POINTER TO LAST
HLRE X1,N ;CHAR + 1 INTO T.
MOVM X1,X1
IDIVI X1,5
ADDI T1,(X1)
HRLI T1,440700
VALAB2: IBP T1
SOJGE X2,VALAB2
MOVEI X2,"$"
DPB X2,T1 ;DEPOSIT "$" TO GUARANTEE
MOVEM T1,VALPTR ;THAT EVANUM STOPS.
HRR T,N
HRLI T,440700
PUSHJ P,NXCH ;FIRST CHAR TO C.
MOVEI T1,1(Q)
POP P,Q
PUSH P,Q
JRST (T1)
VALB6: PUSHJ P,EVANUM
JRST VALERR ;FAIL.
CAME T,VALPTR ;STOPPED AT RIGHT PLACE?
JRST VALERR ;NO.
POP P,Q ;YES. RESTORE AC'S.
MOVEI X2,VALAB3
JRST RESACS
VALAB3: SOS MASAPP
POPJ P, ;EXIT.
VALERR: INLERR(91,50,</
? VAL argument not in correct form/>)
JRST GOSR2
SUBTTL RANDOM NUMBER ROUTINES.
;THIS IS THE RANDOMIZE STATEMENT ROUTINE.
RANDER: MSTIME N,
CAME N,RANTST
JRST RANDR2
AOS RANCNT
MOVE T1,RANCNT
RZLAB1: ADDI N,117
SOJG T1,RZLAB1
JRST RZLAB2
RANDR2: MOVEM N,RANTST
SETZM RANCNT
RZLAB2: IMUL N,N ;USE THE 31 LOW ORDER BITS OF MILLISECS IN DAY
TLZ N,760000 ;FALL INTO THE DATA SETUP.
;THIS ROUTINE INITIALIZES THE RANDOM NUMBER GENERATOR DATA LOCATIONS
;(RNDDAT TO RNDDAT+6) AT THE START OF EXECUTION AND IS ALSO USED BY
;THE RANDOMIZE STATEMENT ROUTINE RANDER TO RESET THE LOCATIONS.
;ITS ALGORITHM IS UNKNOWN.
;IT EXPECTS AN ARGUMENT IN AC N.
RANDOM: XOR N,[013702175435] ;MAGIC STARTING NUMBER.
TLZ N,760000
JUMPE N,RANDOM
MOVSI T1,-7 ;OUTER LOOP INDEX.
RAND2: MOVNI A,6 ;INNER LOOP INDEX.
RAND3: MOVE T,N
ROT T,13
XOR T,N
ROT T,-6
LSHC N,6
AOJN A,RAND3
MOVEM N,RNDDAT(T1)
ADD T1,[000001000001]
JUMPL T1,RAND2
MOVE N,[-7,,-4] ;INITIALIZE INDEX LOCATION FOR
MOVEM N,RNDIDX ;RND FUNCTION.
POPJ P,
;RND FUNCTION.
;N.B. THIS IS DEC CODE !!!!! THE AOBJN @ RNDB+5 CAN GIVE DIFFERENT
;RESULTS ON KA VS KI PROCESSORS. SINCE THE ALGORITHM IS UNKNOWN, SEE
;ABOVE, IT IS UNSURE WHICH IS RIGHT. WE SUSPECT KI, DESPITE THE FACT
;THAT THIS IS PDP-6 CODE !
RNDB: MOVE T1,RNDIDX ;GET INDEX TO DATA LOCATIONS.
MOVE N,RNDDAT+7(T1)
TRNN T1,400000 ;IF RH .GE. 0, GO BACK TO START OF TABLE.
MOVE N,RNDDAT(T1)
ADDB N,RNDDAT+4(T1)
AOBJN T1,RNDB1
MOVE T1,[-7,,-4]
RNDB1: MOVEM T1,RNDIDX
LSH N,-9
JUMPE N,RNDB
TLO N,200000
FADRI N,200000 ;NORMALIZE.
POPJ P,
;
;SGN FUNCTION
;
SGNB: MOVEI T,1 ;ASSUME POSITIVE, SET VAL=1
SKIPG N ;IS ARGUMENT POSITIVE?
SETO T, ;NO, VAL=-1
MOVE N,T ;RETURN ANSWER IN N
POPJ P, ;AND EXIT
IFE BASDDT,<
INTERN NPANIC,DPANIC
DPANIC:
>
NPANIC: PUSH P,.JBREL
POP P,.USREL
POPJ P,
END