Trailing-Edge
-
PDP-10 Archives
-
decuslib10-01
-
43,50205/alglib.mac
There are 11 other files named alglib.mac in the archive. Click here to see a list.
00100 TITLE %LOW -- ALGOLW LOW CORE TABLES -- MICHAEL GREEN
00200 ENTRY %SREG,%LREG,%NREG,%ANREG,%ALREG,%AVIOB,%UUO
00300 ENTRY %IOOPN,%IOLEB,%IOBFH,%IOPRO,%IOREG,%IOSIZ,%IOEND
00400 ENTRY %HDBLK,%SAVE,%PDL,%ENTRY,%STAT,%STEND,%DYNAM
00500 ENTRY %ARITH,%APRSV,%ERRPT,%IOBRK,%DCSAV,%IOPP,%OPNSW
00600 EXTERN %RESET
00700
00800 JOB41= 41
00900 LOC JOB41
01000 JSP 1,%RESET ;UUO HANDLER SETUP
01100 RELOC
01200
01300 %SREG: BLOCK ^D16 ;START OF REGION TABLE
01400 %LREG: BLOCK ^D16 ;AVAILABLE LENGTH IN REGION TABLE
01500 %NREG: BLOCK ^D16 ;NEXT AVAILABLE LOCATION IN REGION TABLE
01600 %ALREG: BLOCK ^D16 ;ALLOCATOR AVAILABLE LENGTH IN REGION
01700 %ANREG: BLOCK ^D16 ;ALLOCATOR NEXT AVAILABLE LOCATION
01800
01900 %AVIOB: BLOCK 1 ;NEXT AVAILABLE I/O REGION
02000
02100 %IOOPN: BLOCK 3 ;OPEN CONTROL BLOCK
02200 %IOLEB: BLOCK 4 ;LOOKUP/ENTER CONTROL BLOCK
02300 %IOBFH: BLOCK 3 ;BUFFER HEADER
02400 %IOPP: BLOCK 1 ;PROJECT-PROGRAMMER NUMBER FOR CLOSE
02500 %IOPRO: BLOCK 1 ;PROTECTION CODE FOR CLOSE ON OUTPUT FILE
02600 %IOREG: BLOCK 1 ;INDEX TO I/O REGION
02700 %IOBRK: BLOCK 10 ;USED BY BREAK FUNCTION
02800 %IOSIZ= .-%IOOPN ;SIZE OF CHANNEL CONTROL BLOCKS
02900 BLOCK ^D15*%IOSIZ
03000 %IOEND= .-1 ;END OF I/O CONTROL BLOCKS
03100
03200 %HDBLK: BLOCK 6 ;USED BY GARBAGE COLLECTOR AND RECORD I/O
03300
03400 %SAVE: BLOCK 10 ;SAVE AREA FOR AC'S 0 THROUGH 7
03500
03600 %APRSV: BLOCK 2 ;SAVE AREA FOR APR INTERRUPTS
03700
03800 %ENTRY: BLOCK 1 ;0-NORMAL ENTRY, -1-ALTERNATE ENTRY TO CUSP
03900
04000 %PDL: BLOCK ^D128 ;PUSH DOWN LIST
04100
04200 %STAT: BLOCK 1 ;+0 RUNTIM AT END OF LAST ALLOC
04300 BLOCK 1 ;+1 RUNTIM AT END OF LAST COLLE
04400 %DYNAM: BLOCK 1 ;+2 START OF DYNAMIC STORAGE
04500 BLOCK 1 ;+3 # TIMES ALLOC CALLED
04600 BLOCK 1 ;+4 # TIMES COLLE CALLED
04700 BLOCK 1 ;+5 TOTAL CORE REQUESTED
04800 BLOCK 1 ;+6 MAX CORE REQUESTED
04900 BLOCK 1 ;+7 CUMULATIVE AVERAGE CORE REQUESTED
05000 BLOCK 1 ;+10 TOTAL TIME BETWEEN ALLOC CALLS
05100 BLOCK 1 ;+11 MAX TIME BETWEEN ALLOC CALLS
05200 BLOCK 1 ;+12 TOTAL TIME IN ALLOC
05300 BLOCK 1 ;+13 MAX TIME IN ALLOC
05400 BLOCK 1 ;+14 TOTAL CORE FREED BY COLLECTION
05500 BLOCK 1 ;+15 MAX CORE FREED BY COLLECTION
05600 BLOCK 1 ;+16 CUMULATIVE AVERAGE CORE FREED
05700 BLOCK 1 ;+17 TOTAL TIME BETWEEN COLLE CALLS
05800 BLOCK 1 ;+20 MAX TIME BETWEEN COLLE CALLS
05900 BLOCK 1 ;+21 TOTAL TIME IN COLLE
06000 BLOCK 1 ;+22 MAX TIME IN COLLE
06100 BLOCK 1 ;+23 STARTING TIME OF RUN
06200 BLOCK 1 ;+24 RUNTIM AT START OF RUN
06300 BLOCK 1 ;+25 CORE REQUESTED SINCE LAST COLLE
06400 BLOCK 1 ;+26 MAX CORE REQUESTED SINCE LAST COLLE
06500 BLOCK 1 ;+27 CUMULATIVE AVERAGE SINCE LAST COLLE
06600 BLOCK 1 ;+30 # TIMES ALLOC CALLED SINCE LAST COLLE
06700 %STEND= .-1
06800
06900 %ERRPT: BLOCK 1 ;USED BY %ERROR ROUTINE
07000
07100 %DCSAV: BLOCK 1 ;USED TO SAVE %UUO FOR CALL ON %ARITH
07200
07300 %UUO: BLOCK 2 ;JOB41 CONTAINS JSR %UUO
07400
07500 %ARITH: BLOCK 1 ;CONTROL OF FLOATING POINT UNDERFLOWS
07600
07700 %OPNSW: BLOCK 10 ;USED TO HOLD DTA AND MTA SWITCHES DURING OPEN
00100 PRGEND
00200 TITLE %RESET -- ALGOLW INITIALIZATION -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %RESET
00500 EXTERN %PDL,%HDBLK,%ENTRY,JOBFF,JOBREN,JOBAPR,%ERROR,%STEND
00600 EXTERN %SREG,%NREG,%AVIOB,%IOOPN,%IOLEB,%IOBFH,%IOEND,%STAT
00700 EXTERN JOBCNI,JOBTPC,%DYNAM,JOBOPC,JOB41,%UUO,%DCSAV,%IOBRK
00800 EXTERN %APRSV,%UUOTB,%ARITH,%BLOCK,JOBSYM,JOBUSY,JOBSA
00900 %T= 14
01000 %TB= 15
01100 %B= 16
01200 %P= 17
01300 ENTRY= 0
01400 RETURN= 1
01500 TEMP= 2
01600 TEMP2= 3
01700 TEMP3= 4
01800 ERROR= 14
01900 INFLG= 040000 ;FLAGS IN LH OF %IOOPN
02000 OUTFLG= 020000
02100 STRFLG= 004000
02200 LNEFLG= 200000
02300 SYMPAT= 2*^D32 ;ROOM FOR NEW SYMBOLS IN DDT TABLE
02400
02500 %RESET: MOVEM RETURN,%UUO ;INITIAL SETUP
02600 SETZB %T,%DCSAV ;MARK NOT IN %ARITH CALLING %ARITH
02700 SETZB %TB,%B ;RESET BLOCK POINTERS
02800 RESET ;RESET I/O AND STORAGE LIMITS
02900 HRREM ENTRY,%ENTRY ;SET ENTRY CODE
03000 SETZM JOBUSY ;NO GLOBAL UNDEFINED SYMBOL TABLE
03100 MOVE TEMP,JOBSYM
03200 JUMPE TEMP,NOSYM ;NO SYMBOLS LOADED
03300 HRLE TEMP2,TEMP
03400 SUBM TEMP,TEMP2 ;SEE IF JOBSA IS ABOVE TABLE
03500 HLRZ TEMP3,JOBSA
03600 CAIL TEMP3,(TEMP2) ;IF SO, WE ALREADY MOVED IT
03700 JRST NOSYM
03800 ADDI TEMP3,SYMPAT
03900 CAIL TEMP3,(TEMP) ;HAS IT ALREADY BEEN MOVED BY LOADER
04000 JRST NOMOVE
04100 HRLI TEMP3,(TEMP) ;NO, SET UP TO MOVE IT
04200 HRRM TEMP3,JOBSYM
04300 HRLE TEMP2,TEMP
04400 SUBM TEMP3,TEMP2
04500 BLT TEMP3,-1(TEMP2)
04600 NOMOVE: HRLM TEMP2,JOBSA
04700 HRRM TEMP2,JOBFF
04800 NOSYM: MOVE %P,[IOWD ^D108,%PDL] ;SET PDL POINTER
04900 MOVE [XWD 400000+INFLG+OUTFLG+STRFLG+LNEFLG,1]
05000 MOVEM %IOOPN
05100 HRLZI (SIXBIT/TTY/)
05200 MOVEM %IOOPN+1 ;INITIALIZE CHANNEL 0 - TTY
05300 MOVE [XWD %IOBFH,%IOLEB]
05400 MOVEM %IOOPN+2
05500 SETZM %IOOPN+3 ;CLEAR REST OF CONTROL BLOCKS
05600 MOVE [XWD %IOOPN+3,%IOOPN+4]
05700 BLT %IOEND
05800 SETZM %AVIOB
05900 SETZM %SREG
06000 MOVE [XWD %SREG,%SREG+1]
06100 BLT %SREG+5*^D16-1 ;CLEAR STORAGE ALLOCATION BLOCKS
06200 MOVE [XWD 000014,176400] ;INITIALIZE BREAK TABLE
06300 MOVEM %IOBRK
06400 MOVSI 3
06500 MOVEM %IOBRK+1 ;IGNORE CARRIAGE RETURN
06600 MOVEI 3
06700 MOVEM %IOBRK+6 ;BREAK ON VERTICAL MOTION CHARS
06800 MOVEI -1
06900 MOVEM %IOBRK+7 ;AND BELL AND ^Z AND ALTMODE
07000 OPEN %IOOPN ;OPEN TTY - CHANNEL 0
07100 HALT ;FATAL ERROR IF CANNOT
07200 INBUF 2 ;GET BUFFER SPACE
07300 OUTBUF 2
07400 HRRZ JOBFF ;GET NEW STORAGE LIMIT
07500 MOVEM %SREG
07600 MOVEM %NREG ;SET IN TABLES
07700 MOVEM %DYNAM ;SET START OF DYNAMIC STORAGE
07800 SETZM %ARITH ;INITIALIZE ARITH ERROR CONTROL
07900 MOVE [XWD 400005,400001]
08000 MOVEM %HDBLK ;INITIALIZE %HDBLK
08100 SETZM %HDBLK+3 ;SET EXTRA POINTERS TO NULL
08200 SETZM %HDBLK+4
08300 MOVE [JSR %UUO] ;SET UP FOR UUOS
08400 MOVEM JOB41
08500 MOVE [JRST %UUOTB]
08600 MOVEM %UUO+1
08700 MOVEI %REENT ;SET UP FOR REENTER
08800 HRRM JOBREN ; FOR ERROR RECOVERY
08900 MOVEI %APRER
09000 HRRM JOBAPR ;SET UP FOR INTERRUPTS
09100 MOVEI 200110 ; ON PDL OVF,OVF,EXP OVF
09200 APRENB
09300 SETZM %STAT+3
09400 MOVE [XWD %STAT+3,%STAT+4]
09500 BLT %STEND ;INITIALIZE STATISTICS TABLE
09600 MOVEI 0
09700 RUNTIM
09800 MOVEM %STAT ;INITIALIZE TIMES
09900 MOVEM %STAT+1
10000 MOVEM %STAT+24
10100 MSTIME ;GET MS TIME OF DAY
10200 MOVEM %STAT+23
10300 JRST %BLOCK ;TREAT NOW LIKE %BLOCK UUO
10400
10500 %REENT: MOVE JOBOPC ;INDICATE PROPER ERROR POINT
10600 SKIPN %UUO
10700 MOVEM %UUO
10800 MOVEI ERROR,[ASCIZ/REENTER/]
10900 PUSHJ %P,%ERROR ;REENTER, CALL ERROR ROUTINE
11000 EXIT ;AND QUIT
11100
11200 %APRER: MOVEM %APRSV
11300 MOVE JOBTPC ;INDICATE PROPER ERROR POINT
11400 SKIPN %UUO
11500 MOVEM %UUO
11600 MOVE JOBCNI ;APR ERROR, DECODE IT
11700 TRNE 200000
11800 JRST PUSHER ;PUSHDOWN OVERFLOW
11900 TRNE 100
12000 JRST FLTOVF ;FLOATING OVERFLOW
12100 MOVE JOBTPC ;DECODE INTEGER OVERFLOW
12200 TLNE 40
12300 JRST FIXDIV ;FIXED POINT DIVIDE BY ZERO
12400 MOVEI ERROR,[ASCIZ/INTEGER OVERFLOW/]
12500 ERRPRT: PUSHJ %P,%ERROR ;ERROR PRINTOUT
12600 EXIT ;AND QUIT
12700
12800 ERRRTN: MOVE %UUO ;SEE IF SHOULD RESET %UUO
12900 CAMN JOBTPC
13000 SETZM %UUO ;IF %UUO=INTERRUPT POINT
13100 MOVEM ERROR,%APRSV+1 ;SAVE ERROR
13200 MOVE ERROR,JOBTPC ;SEE WHAT KIND OF INSTRUCTION
13300 HLRZ -1(ERROR)
13400 ANDI 777000 ;GET OPCODE
13500 CAIN 140000
13600 JRST UFA ;UFA
13700 CAIN 142000
13800 JRST AC ;FSC
13900 ANDI 007000 ;GET MODE
14000 CAIN 001000
14100 JRST LONG ;LONG MODE
14200 ANDI 003000 ;WHAT DESTINATION
14300 CAIN 003000
14400 JRST BOTH ;XXXXB
14500 CAIN 002000
14600 JRST MEMORY ;XXXXM
14700 AC: HLRZ ERROR,-1(ERROR) ;XXXX OR XXXXI, SET AC
14800 LSH ERROR,-5
14900 ANDI ERROR,17
15000 STORE: JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
15100 SETZM (ERROR)
15200 JRST DONE
15300 SETZM %APRSV
15400 JRST DONE
15500 UFA: HLRZ ERROR,-1(ERROR) ;GET AC+1
15600 ADDI ERROR,40
15700 JRST AC+1
15800 MEMORY: MOVE -1(ERROR) ;GET INSTRUCTION
15900 MOVE ERROR,%APRSV+1 ;RESET ERROR
16000 MOVEI ERROR,@0 ;GET ADDRESS
16100 JRST STORE
16200 BOTH: MOVE -1(ERROR) ;GET INSTRUCTION
16300 MOVE ERROR,%APRSV+1 ;RESET ERROR
16400 MOVEI ERROR,@0 ;GET ADDRESS
16500 JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
16600 SETZM (ERROR)
16700 JRST .+2
16800 SETZM %APRSV
16900 MOVE ERROR,JOBTPC ;SET UP AGAIN FOR STORE IN AC
17000 JRST AC
17100 LONG: HLRZ ERROR,-1(ERROR) ;GET AC
17200 LSH ERROR,-5
17300 ANDI ERROR,17
17400 JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
17500 SETZM (ERROR)
17600 JRST .+2
17700 SETZM %APRSV
17800 SETZM 1(ERROR) ;TAKE CARE OF AC+1 ALSO
17900 DONE: MOVE ERROR,%APRSV+1
18000 MOVEI 200110 ;RESET APRENB
18100 APRENB
18200 MOVE %APRSV ;RESTORE REGISTER
18300 JRSTF @JOBTPC ;AND RETURN
18400
18500 FIXDIV: MOVEI ERROR,[ASCIZ/INTEGER DIVISION BY ZERO/]
18600 JRST ERRPRT
18700
18800 FLTOVF: MOVE JOBTPC ;DECODE FLOATING OVERFLOW
18900 TLNE 40
19000 JRST FLTDIV ;FLOATING POINT DIVIDE BY ZERO
19100 TLNE 100
19200 JRST FLTUNF ;FLOATING POINT UNDERFLOW
19300 MOVEI ERROR,[ASCIZ/REAL OR COMPLEX OVERFLOW/]
19400 JRST ERRPRT
19500
19600 FLTDIV: MOVEI ERROR,[ASCIZ/REAL OR COMPLEX DIVISION BY ZERO/]
19700 JRST ERRPRT
19800
19900 FLTUNF: AOSE %ARITH ;KEEP ERROR COUNT
20000 JRST ERRRTN
20100 MOVEI ERROR,[ASCIZ/REAL OR COMPLEX UNDERFLOW/]
20200 JRST ERRPRT
20300
20400 PUSHER: MOVEI ERROR,[ASCIZ/INTERNAL ERROR (STACK OVF)/]
20500 SUB %P,[XWD ^D20,0]
20600 JRST ERRPRT ;ALLOW ACCESS TO EXTRA STACK SPACE
00100 PRGEND
00200 TITLE %UUOTB -- ALGOLW UUO DISPATCH TABLE -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %UUOTB,%XUUO
00500 EXTERN %CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE,%SMOVE,%SUBST
00600 EXTERN %ARECD,%AARRY,%RARRY,%ASTRA,%DADD,%DSUB,%DMULT,%DDIV
00700 EXTERN %CMULT,%CDIV,%DCMUL,%DCDIV,%RDLST,%WRLST,%READ,%WRITE
00800 EXTERN %BRK0,%BRK1,%GETBK,%GETLN,%PUTLN,%CLRBK,%EFILE,%ASTRG
00900 EXTERN %BLOCK,%THUNK,%FIX,%FLOAT,%DFIX,%DFLOT,%CLOSE,%RESET
01000 EXTERN %ERROR,JOBUUO,%UUO,%USRER,%SUBSC,%PROC,%OPEN,%IS,%HDBLK
01100 %P= 17
01200 UUOPTR= 14 ;NOTE: IS ALSO %T (SEE %ALLOC)
01300
01400 %UUOTB: MOVEM UUOPTR,%HDBLK+3 ;SAVE %T IN %HDBLK
01500 HLRZ UUOPTR,JOBUUO
01600 LSH UUOPTR,-^D9 ;GET TABLE INDEX
01700 HRLI UUOPTR,%HDBLK+3 ;SETUP FOR REGISTER RESTORE
01800 JRA UUOPTR,.(UUOPTR);JUMP INTO TABLE
01900
02000 JRST %CSTE ;COMPARE STRING EQUAL
02100 JRST %CSTN ;COMPARE STRING NOT EQUAL
02200 JRST %CSTL ;COMPARE STRING LESS THAN
02300 JRST %CSTLE ;COMPARE STRING LESS THAN OR EQUAL
02400 JRST %CSTG ;COMPARE STRING GREATER THAN
02500 JRST %CSTGE ;COMPARE STRING GREATER THAN OR EQUAL
02600 JRST %SMOVE ;MOVE STRING
02700 JRST %SUBST ;SUBSTRING
02800 JRST %ARECD ;RECORD ALLOCATE
02900 JRST %AARRY ;NON-REFERENCE ARRAY ALLOCATE
03000 JRST %RARRY ;REFERENCE ARRAY ALLOCATE
03100 JRST %ASTRA ;STRING ARRAY ALLOCATE
03200 JRST %DADD ;LONG REAL ADD
03300 JRST %DSUB ;LONG REAL SUBTRACT
03400 JRST %DMULT ;LONG REAL MULTIPLY
03500 JRST %DDIV ;LONG REAL DIVIDE
03600 JRST %CMULT ;COMPLEX MULTIPLY
03700 JRST %CDIV ;COMPLEX DIVIDE
03800 JRST %DCMUL ;LONG COMPLEX MULTIPLY
03900 JRST %DCDIV ;LONG COMPLEX DIVIDE
04000 JRST %OPEN ;OPEN FILE
04100 JRST %IS ;REFERENCE IS RECORD TEST
04200 JRST %READ ;READ
04300 JRST %WRITE ;WRITE
04400 JRST %GETLN ;GET INPUT LINE NUMBER
04500 JRST %PUTLN ;PUT OUTPUT LINE NUMBER
04600 JRST %BRK0 ;BREAK NOACTION, IGNORE
04700 JRST %BRK1 ;BREAK INCLUDE, DEFER
04800 JRST %GETBK ;GET BREAK CHARACTER
04900 JRST %SUBSC ;ARRAY SUBSCRIPT CHECKING
05000
05100 HLRZ UUOPTR,JOBUUO ;FURTHER UUO DECODE
05200 LSH UUOPTR,-5 ;USE AC FIELD
05300 HRLI UUOPTR,%HDBLK+3 ;SETUP FOR RESTORE AGAIN
05400 JRA UUOPTR,.-757(UUOPTR) ;ALLOW FOR OPCODE=37
05500
05600 JRST %ASTRG ;STRING ALLOCATE
05700 JRST %PROC ;PROCEDURE ENTRY
05800 JRST %BLOCK ;BLOCK ENTRY
05900 JRST %THUNK ;THUNK ENTRY
06000 JRST %FIX ;REAL TO INTEGER
06100 JRST %FLOAT ;INTEGER TO REAL
06200 JRST %DFIX ;LONG REAL TO INTEGER
06300 JRST %DFLOT ;INTEGER TO LONG REAL
06400 JRST %CLOSE ;CLOSE FILE
06500 JRST %EFILE ;END FILE TEST
06600 JRST CALLUO ;ENTER INTERNAL ROUTINE
06700 JRST %USRER ;USER ERROR TRACEBACK
06800 JRST %CLRBK ;RESET BREAK TABLE
06900 JRST %RDLST ;READ LIST STRUCTURE
07000 JRST %WRLST ;WRITE LIST STRUCTURE
07100 JRST %RESET+1 ;RESET SYSTEM, ENTER OUTER BLOCK
07200
07300 CALLUO: PUSHJ %P,@JOBUUO ;SET TRACEBACK POINT ON ERROR
07400
07500 %XUUO: PUSH %P,%UUO ;RETURN TO POINT OF CALL
07600 SETZM %UUO ;RESET TRACEBACK POINT
07700 MOVE UUOPTR,%HDBLK+3 ;RESTORE REGISTER
07800 POPJ %P,
00100 PRGEND
00200 TITLE %OPEN -- ALGOLW OPEN ROUTINE -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %OPEN,%OPENT
00500 EXTERN %IOOPN,%IOSIZ,%IOLEB,%IOPRO,%IOREG,%AVIOB
00600 EXTERN %SREG,%NREG,%LREG,%COLLE,%ERROR,%ERRNM
00700 EXTERN %XUUO,%IOEND,%SAVE,JOBUUO,JOBFF,%ERRSB
00800 EXTERN %IOBFH,%IOBRK,%IOPP,%OPNSW,%UUO
00900 %P= 17
01000 CHAN= 10
01100 CINDEX= 11
01200 TEMP= 12
01300 BUFFCT= 13
01400 TEMP2= 13
01500 ERROR= 14
01600 REGPT= 14
01700 TEMP3= 14
01800 OPNFLG= 400000 ;OPNFLG MUST BE SIGN BIT FOR %OPENT
01900 LNEFLG= 200000
02000 RECFLG= 100000
02100 INFLG= 040000 ;FLAGS IN LH OF %IOOPN
02200 OUTFLG= 020000
02300 BITFLG= 010000
02400 STRFLG= 004000
02500 REWFLG= 002000
02600 CONFLG= 001000
02700
02800 OPENI: TLNN TEMP,2 ;DEVICE CAN DO INPUT
02900 JRST NOINPT
03000 MOVEI TEMP,%IOBFH(CINDEX) ;SET POINTER TO BUFF HEADER
03100 HRRZM TEMP,%IOOPN+2(CINDEX)
03200 MOVE TEMP,[OPEN %IOOPN(CINDEX)]
03300 DPB CHAN,[POINT 4,TEMP,^D12]
03400 XCT TEMP ;OPEN CHANNEL
03500 JRST OPENER
03600 MOVE TEMP,[LOOKUP %IOLEB(CINDEX)]
03700 DPB CHAN,[POINT 4,TEMP,^D12]
03800 XCT TEMP ;LOOKUP FILE
03900 JRST LOOKER
04000 MOVE TEMP,%IOOPN(CINDEX)
04100 TLNE TEMP,RECFLG
04200 JRST FORCEI ;IF LIST I/O, LEAVE BINARY BYTE PTR
04300 ANDI TEMP,17 ;IF BINARY, SET BYTE SIZE OF 1 BIT
04400 JUMPE TEMP,FORCEI
04500 MOVEI TEMP,1
04600 DPB TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
04700 FORCEI: PUSHJ %P,MTASW ;PROCESS DTA AND MTA SWITCHES
04800 PUSH %P,CHAN ;SAVE REGISTERS
04900 PUSH %P,CINDEX
05000 PUSH %P,BUFFCT
05100 PUSHJ %P,%COLLE ;FORCE COLLECTION
05200 POP %P,BUFFCT ;AND RESTORE REGISTERS
05300 POP %P,CINDEX
05400 POP %P,CHAN
05500 MOVE REGPT,%AVIOB
05600 MOVE TEMP,%NREG(REGPT)
05700 HRRM TEMP,JOBFF ;SET AREA FOR BUFFERS
05800 MOVE TEMP,[INBUF (BUFFCT)]
05900 DPB CHAN,[POINT 4,TEMP,^D12]
06000 XCT TEMP ;ALLOCATE THEM
06100 PUSHJ %P,BUFFER ;ADJUST STORAGE CONTROL TABLES
06200 MOVSI TEMP,OPNFLG+INFLG ;MARK NOW AS OPEN
06300 ORM TEMP,%IOOPN(CINDEX)
06400 AOS %UUO ;SKIP RETURN
06500 JRST %XUUO ;DONE, EXIT
06600
06700 OPENO: TLNN TEMP,1 ;DEVICE CAN DO OUTPUT
06800 JRST NOOUT
06900 MOVEI TEMP,%IOBFH(CINDEX) ;SET POINTER TO BUFF HEADER
07000 HRLZM TEMP,%IOOPN+2(CINDEX)
07100 MOVE TEMP,[OPEN %IOOPN(CINDEX)]
07200 DPB CHAN,[POINT 4,TEMP,^D12]
07300 XCT TEMP ;OPEN CHANNEL
07400 JRST OPENER
07500 MOVE TEMP,[ENTER %IOLEB(CINDEX)]
07600 DPB CHAN,[POINT 4,TEMP,^D12]
07700 XCT TEMP ;CREATE FILE
07800 JRST ENTRER
07900 MOVE TEMP,%IOOPN(CINDEX)
08000 TLNE TEMP,RECFLG
08100 JRST FORCEO ;IF LIST I/O, LEAVE BINARY BYTE PTR
08200 ANDI TEMP,17 ;IF BINARY, SET BYTE SIZE TO 1 BIT
08300 JUMPE TEMP,FORCEO
08400 MOVEI TEMP,1
08500 DPB TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
08600 FORCEO: PUSHJ %P,MTASW ;PROCESS DTA AND MTA SWITCHES
08700 PUSH %P,CHAN ;SAVE REGISTERS
08800 PUSH %P,CINDEX
08900 PUSH %P,BUFFCT
09000 PUSHJ %P,%COLLE ;FORCE COLLECTION
09100 POP %P,BUFFCT
09200 POP %P,CINDEX
09300 POP %P,CHAN
09400 MOVE REGPT,%AVIOB
09500 MOVE TEMP,%NREG(REGPT)
09600 HRRM TEMP,JOBFF
09700 MOVE TEMP,[OUTBUF (BUFFCT)] ;SET AREA FOR BUFFERS
09800 DPB CHAN,[POINT 4,TEMP,^D12]
09900 XCT TEMP ;ALLOCATE THEM
10000 PUSHJ %P,BUFFER ;ADJUST STORAGE CONTROL TABLES
10100 MOVSI TEMP,OPNFLG+OUTFLG ;MARK NOW AS OPEN
10200 ORM TEMP,%IOOPN(CINDEX)
10300 AOS %UUO ;SKIP RETURN
10400 JRST %XUUO ;DONE, EXIT
10500
10600 NOINPT: MOVEI ERROR,[ASCIZ/OPEN - INPUT NOT POSSIBLE FOR $:/]
10700 JRST OPENER+1
10800
10900 NOOUT: MOVEI ERROR,[ASCIZ/OPEN - OUTPUT NOT POSSIBLE FOR $:/]
11000 JRST OPENER+1
11100
11200 OPENER: MOVEI ERROR,[ASCIZ@OPEN - $: I/O ERROR DURING OPEN@]
11300 MOVE TEMP,%IOOPN(CINDEX)
11400 TLNE TEMP,CONFLG ;ERROR ON CONDITIONAL OPEN
11500 JRST %XUUO ;ERROR RETURN
11600 PUSHJ %P,%ERROR
11700 MOVE ERROR,%IOOPN+1(CINDEX)
11800 PUSHJ %P,%ERRSB
11900 EXIT
12000
12100 ENTRER: MOVEI ERROR,[ASCIZ/OPEN OUTPUT - $:$.$ CAN NOT BE CREATED/]
12200 JRST OPNEDT
12300
12400 LOOKER: MOVEI ERROR,[ASCIZ/OPEN INPUT - $:$.$ DOES NOT EXIST/]
12500 OPNEDT: MOVE TEMP,%IOOPN(CINDEX)
12600 TLNE TEMP,CONFLG ;ERROR ON CONDITIONAL OPEN
12700 JRST %XUUO ;ERROR RETURN
12800 PUSHJ %P,%ERROR
12900 MOVE ERROR,%IOOPN+1(CINDEX)
13000 PUSHJ %P,%ERRSB
13100 MOVE ERROR,%IOLEB(CINDEX)
13200 PUSHJ %P,%ERRSB
13300 HLLZ ERROR,%IOLEB+1(CINDEX)
13400 PUSHJ %P,%ERRSB
13500 EXIT
13600
13700 BUFFER: SETZM %LREG(REGPT) ;OLD REGION ZERO AVAILABLE SPACE
13800 AOS REGPT,%AVIOB ;GET NEW REGION
13900 HRRZ TEMP,JOBFF ;START OF AVAILABLE STORAGE
14000 MOVEM TEMP,%SREG(REGPT) ;STORE IN TABLES
14100 MOVEM TEMP,%NREG(REGPT)
14200 SETZM %LREG(REGPT) ;NEW REGION ZERO LENGTH
14300 MOVEI REGPT,0 ;FIND OUT HOW MUCH ALREADY FREE
14400 MOVEI TEMP,0
14500 ADD TEMP,%LREG(REGPT)
14600 CAMGE REGPT,%AVIOB ;ALL ALLOCATED REGIONS
14700 AOJA REGPT,.-2
14800 CAIGE TEMP,2000 ;YES, IF LESS THAN 1K AVAILABLE
14900 SKIPA TEMP,[2000] ;MAKE 1K MORE AVAILABLE
15000 MOVEI TEMP,0
15100 ADD TEMP,%NREG(REGPT)
15200 ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
15300 MOVE TEMP2,%NREG(REGPT)
15400 SUBM TEMP,TEMP2 ;FIND THE LENGTH OF AVAILABLE SPACE
15500 ADDI TEMP2,1
15600 MOVEM TEMP2,%LREG(REGPT) ;SAVE IT
15700 CORE TEMP, ;ASK FOR CORE
15800 JRST TIGHT
15900 POPJ %P,
16000
16100 TIGHT: MOVNI TEMP,2000 ;SEE IF WE REMOVE 1K PADDING
16200 ADDB TEMP,%LREG(REGPT)
16300 ADD TEMP,%NREG(REGPT)
16400 SUBI TEMP,1 ;SHOULD BE ABLE TO GET THAT MUCH
16500 CORE TEMP,
16600 HALT
16700 POPJ %P,
16800
16900 MTASW: MOVE TEMP,[POINT 7,%OPNSW]
17000 ILDB TEMP3,TEMP ;PROCESS DTA OR MTA SWITCHES
17100 JUMPN TEMP3,.+2
17200 POPJ %P, ;ZERO BYTE ENDS LIST
17300 CAIE TEMP3,"Z"
17400 JRST .+5 ;Z IS ZERO DECTAPE DIRECTORY
17500 MOVE TEMP3,[UTPCLR]
17600 DOSW: DPB CHAN,[POINT 4,TEMP3,^D12]
17700 XCT TEMP3 ;DO IT
17800 JRST MTASW+1 ;AND GET NEXT SWITCH
17900 CAIE TEMP3,"A"
18000 JRST .+3 ;A IS ADVANCE ONE FILE
18100 DOASW: MOVE TEMP3,[MTAPE 16]
18200 JRST DOSW
18300 CAIE TEMP3,"C"
18400 JRST .+3 ;C IS IBM COMPATIBLE MODE
18500 MOVE TEMP3,[MTAPE 101]
18600 JRST DOSW
18700 CAIE TEMP3,"W"
18800 JRST .+3 ;W IS REWIND TAPE
18900 MOVE TEMP3,[MTAPE 1]
19000 JRST DOSW
19100 CAIE TEMP3,"T"
19200 JRST .+3 ;T IS GO TO LOGICAL END OF TAPE
19300 MOVE TEMP3,[MTAPE 10]
19400 JRST DOSW
19500 MOVE TEMP3,[MTAPE 17];ELSE ASSUME B - BACKSPACE FILE
19600 DPB CHAN,[POINT 4,TEMP3,^D12]
19700 XCT TEMP3 ;BACKSPACE IT
19800 HRRI TEMP3,0
19900 XCT TEMP3 ;WAIT TIL DONE
20000 MOVE TEMP3,[STATO 4000]
20100 DPB CHAN,[POINT 4,TEMP3,^D12]
20200 XCT TEMP3 ;IS BEGINNING OF TAPE
20300 JRST DOASW ;NO, MOVE PAST TAPE MARK
20400 JRST MTASW+1 ;YES, GET NEXT SWITCH
20500
20600 PAGE
20700 ; FILE DESCRIPTOR SCANNER
20800
20900 CHAR= 0
21000 ASSEMB= 1
21100 BYTEPT= 2
21200 LENGTH= 3
21300 FLAG= 4
21400 SWPTR= 5
21500 LOOKNM= 400000 ;FLAG BITS
21600 FINDNM= 200000
21700 LOOKDG= 100000
21800 OCTAL= 040000
21900 FINDDG= 020000
22000 LOOKDV= 010000
22100 LOOKFL= 004000
22200 PASTFL= 002000
22300 LOOKPP= 001000
22400 LOOKPR= 000400
22500 LOOKPG= 000200
22600 LOOKBN= 000100
22700 FINDBN= 000040
22800 FINDPP= 000020
22900 FINDPR= 000010
23000 FINDMD= 000004
23100 SWSKIP= 000002
23200 GOTSW= 000001
23300
23400 %OPEN: MOVEI TEMP,%SAVE ;SAVE WORK REGISTERS
23500 BLT TEMP,%SAVE+5
23600 MOVE CHAN,@JOBUUO ;GET CHANNEL NUMBER
23700 JUMPG CHAN,CHANOK ;MUST BE 0 < CHAN < 16
23800 CHANER: MOVEI ERROR,[ASCIZ/OPEN - ILLEGAL CHANNEL - $/]
23900 OPNERM: PUSHJ %P,%ERROR
24000 MOVE ERROR,CHAN
24100 PUSHJ %P,%ERRNM
24200 EXIT ;QUIT
24300 CHANOK: CAIL CHAN,^D16
24400 JRST CHANER
24500 MOVEI CINDEX,(CHAN) ;GET INDEX INTO TABLES
24600 IMULI CINDEX,%IOSIZ
24700 SKIPL %IOOPN(CINDEX) ;SEE IF ALREADY OPEN
24800 JRST NOTOPN
24900 MOVEI ERROR,[ASCIZ/OPEN - CHANNEL $ ALREADY OPEN/]
25000 JRST OPNERM
25100 NOTOPN: SETZB FLAG,%IOOPN(CINDEX) ;INITIALIZE TABLES
25200 MOVEI TEMP,%IOOPN+1(CINDEX)
25300 HRLI TEMP,%IOOPN(CINDEX)
25400 MOVEI TEMP2,%IOOPN(CINDEX)
25500 BLT TEMP,%IOSIZ-1(TEMP2)
25600 MOVSI TEMP,(SIXBIT/DSK/) ;DEFAULT DEVICE
25700 MOVEM TEMP,%IOOPN+1(CINDEX)
25800 MOVEI BUFFCT,2 ;DEFAULT BUFFER COUNT = 2
25900 SETOM %IOPRO(CINDEX) ;NO PROTECTION RENAME
26000 MOVE TEMP,%AVIOB ;SET REGION NUMBER
26100 MOVEM TEMP,%IOREG(CINDEX)
26200 SETZM %OPNSW
26300 LDB TEMP,[POINT 4,JOBUUO,^D12]
26400 TRZ TEMP,1 ;EITHER INPUT OR OUTPUT
26500 CAIG TEMP,SWPTR ;GET DESCRIPTOR DOPE VECTOR
26600 ADDI TEMP,%SAVE
26700 MOVE BYTEPT,(TEMP)
26800 MOVE TEMP,1(TEMP)
26900 HLRZ LENGTH,TEMP
27000 ADDI BYTEPT,(TEMP) ;MAKE BYTEPTR ABSOLUTE
27100
27200 NEWITM: SETZ ASSEMB, ;START OF NEW ITEM
27300 JUMPL LENGTH,SETXIT ;DONE
27400
27500 NEXTCH: SOJL LENGTH,ENDFLD ;END OF STRING, FINISH UP
27600 ILDB CHAR,BYTEPT ;GET CHARACTER
27700 CAIN CHAR,")"
27800 JRST ENDSW ;END OF DTA OR MTA SWITCHES
27900 TLNE FLAG,SWSKIP
28000 JRST SWTEST ;PROCESS DTA OR MTA SWITCH
28100 CAIN CHAR,"("
28200 JRST STRTSW ;START OF DTA OR MTA SWITCHES
28300 CAIN CHAR,"?"
28400 JRST CONDOP ;CONDITIONAL OPEN
28500 CAIN CHAR,":"
28600 JRST DEVCHK ;END OF DEVICE SPECIFICATION
28700 CAIN CHAR,"."
28800 JRST NAMCHK ;END OF FILE NAME
28900 CAIN CHAR,"["
29000 JRST STRTPP ;START OF PROJECT-PROGRAMMER
29100 CAIN CHAR,"<"
29200 JRST STRTPR ;START OF PROTECTION CODE
29300 CAIN CHAR,"*"
29400 JRST STRTMD ;START OF MODE CODE
29500 CAIN CHAR,"#"
29600 JRST STRTBN ;START OF BUFFER COUNT
29700 CAIN CHAR,","
29800 JRST COMMA ;END OF PROJECT START PROGRAMMER
29900 CAIN CHAR,"]"
30000 JRST ENDPP ;END OF PROGRAMMER
30100 CAIN CHAR,">"
30200 JRST ENDPR ;END OF PROTECT CODE
30300 CAIN CHAR,"^" ;DELETE FILE CODE
30400 JRST DELCOD
30500 CAIGE CHAR,"0"
30600 JRST .+3 ;DIGIT
30700 CAIG CHAR,"9"
30800 JRST DIGIT
30900 CAIGE CHAR,"A"
31000 JRST .+3 ;UPPER CASE LETTER
31100 CAIG CHAR,"Z"
31200 JRST LETTER
31300 CAIGE CHAR,"A"+40
31400 JRST .+3 ;LOWER CASE LETTER
31500 CAIG CHAR,"Z"+40
31600 JRST LOWERC
31700 JRST UNKNOW
31800
31900 LOWERC: TRZ CHAR,40 ;CONVERT TO UPPER CASE
32000 LETTER: TLNE FLAG,LOOKNM ;ARE WE LOOKING FOR A NAME?
32100 JRST UNKNOW
32200 TLO FLAG,FINDNM ;INDICATE WE FOUND ONE
32300 TLNE ASSEMB,770000 ;ONLY FIRST SIX CHARACTERS
32400 JRST NEXTCH
32500 TRC CHAR,40 ;CONVERT TO SIXBIT
32600 ROT CHAR,-6
32700 ROTC CHAR,6 ;PACK INTO ASSEMB
32800 JRST NEXTCH
32900
33000 DIGIT: TLNN FLAG,LOOKDG ;ARE WE LOOKING FOR A NUMBER?
33100 JRST LETTER ;MAYBE PART OF A NAME
33200 TLO FLAG,FINDDG ;INDICATE WE FOUND ONE
33300 TLNE FLAG,OCTAL ;IS IT DECIMAL
33400 JRST POCTAL
33500 CAIL ASSEMB,^D1000 ;MAXIMUM 9999
33600 JRST UNKNOW
33700 IMULI ASSEMB,^D10 ;PACK IN DIGIT
33800 ADDI ASSEMB,-"0"(CHAR)
33900 JRST NEXTCH
34000
34100 POCTAL: CAIL CHAR,"8" ;IS LEGAL OCTAL CHARACTER
34200 JRST UNKNOW
34300 CAIL ASSEMB,100000 ;CHECK HALFWORD ONLY
34400 JRST UNKNOW
34500 ROT CHAR,-3
34600 ROTC CHAR,3 ;PACK IN ASSEMB
34700 JRST NEXTCH
34800
34900 DEVCHK: TLOE FLAG,LOOKDV ;ARE WE LOOKING FOR A DEVICE NAME
35000 JRST UNKNOW
35100 TLZN FLAG,FINDNM ;HAVE WE FOUND A NAME
35200 JRST UNKNOW
35300 TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
35400 JRST .+3
35500 LSH ASSEMB,6
35600 JRST .-3
35700 MOVEM ASSEMB,%IOOPN+1(CINDEX)
35800 JRST NEWITM ;STORE DEVICE AND LEAVE LOOKNM SET
35900
36000 NAMCHK: TLOE FLAG,LOOKFL ;ARE WE LOOKING FOR A FILE NAME
36100 JRST UNKNOW
36200 TLZN FLAG,FINDNM ;HAVE WE FOUND A NAME
36300 JRST UNKNOW
36400 TLO FLAG,LOOKDV
36500 STORFL: TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
36600 JRST .+3
36700 LSH ASSEMB,6
36800 JRST .-3
36900 MOVEM ASSEMB,%IOLEB(CINDEX)
37000 JRST NEWITM ;STORE FILE NAME AND LEAVE LOOKNM SET
37100
37200 ENDFLD: TLNE FLAG,SWSKIP ;END OF STRING IN SWITCH SCAN MODE
37300 JRST UNKNOW
37400 TLOE FLAG,PASTFL ;HAVE WE FINISHED WITH FILE NAME.EXT
37500 JRST CHKBFN
37600 STOEXT: TLO FLAG,LOOKNM ;NO, NO MORE NAMES
37700 TLZN FLAG,FINDNM ;HAVE WE FOUND NAME
37800 JRST NEWITM
37900 TLNN FLAG,LOOKFL ;HAVE WE FOUND FILE NAME
38000 JRST STORFL
38100 TLNE ASSEMB,770000 ;YES, LEFT JUSTIFY EXTENSION
38200 JRST .+3
38300 LSH ASSEMB,6
38400 JRST .-3
38500 HLLM ASSEMB,%IOLEB+1(CINDEX)
38600 JRST NEWITM ;STORE EXTENSION
38700
38800 STRTPP: TLNE FLAG,LOOKPP+FINDPP+LOOKPR+LOOKPG
38900 JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND P-P
39000 TLO FLAG,LOOKDG+OCTAL+LOOKPP
39100 JRST ENDFLD ;LOOKING FOR OCTAL PROJECT NO.
39200
39300 STRTPR: TLNE FLAG,FINDPR+LOOKPR+LOOKPP+LOOKPG
39400 JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND PROT
39500 TLO FLAG,LOOKDG+OCTAL+LOOKPR
39600 JRST ENDFLD ;LOOKING FOR OCTAL PROTECTION
39700
39800 CHKBFN: TLZN FLAG,LOOKBN ;WERE WE PACKING BUFFER NUMBER
39900 JRST NEWITM
40000 TLZN FLAG,FINDDG ;HAD WE FOUND A NUMBER
40100 JRST UNKNOW
40200 JUMPE ASSEMB,UNKNOW ;MUST BE > 0
40300 TLO FLAG,FINDBN ;WE FOUND IT
40400 MOVE BUFFCT,ASSEMB ;SAVE VALUE
40500 JRST NEWITM
40600
40700 STRTBN: TLNE FLAG,LOOKBN+FINDBN
40800 JRST UNKNOW ;ONLY ONE BUFFER NUMBER SPEC.
40900 TLO FLAG,LOOKDG+LOOKBN
41000 TLZ FLAG,OCTAL ;LOOKING FOR DECIMAL BUFFER COUNT
41100 TLOE FLAG,PASTFL ;ARE WE ENDING FILE NAME OR EXT.
41200 JRST NEWITM
41300 JRST STOEXT ;YES, LOOKBN ALREADY SET
41400
41500 STRTMD: TLOE FLAG,FINDMD ;ALREADY FOUND MODE
41600 JRST UNKNOW
41700 TLZ FLAG,LOOKDG
41800 SOJL LENGTH,UNKNOW ;NO, GET NEXT CHARACTER
41900 ILDB CHAR,BYTEPT
42000 CAIN CHAR,"S"
42100 JRST STRMOD ;ASCII MODE
42200 CAIN CHAR,"L"
42300 JRST LINEMD ;NUMBERED LINES (ASCII)
42400 CAIN CHAR,"R"
42500 JRST RECORD ;RECORD I/O
42600 CAIE CHAR,"B"
42700 JRST UNKNOW
42800 MOVSI TEMP,BITFLG ;SET BITS MODE FLAG
42900 ORM TEMP,%IOOPN(CINDEX)
43000 SETBIN: MOVEI TEMP,14 ;BINARY, SET MODE
43100 ORM TEMP,%IOOPN(CINDEX)
43200 JRST ENDFLD
43300
43400 RECORD: MOVSI TEMP,RECFLG ;SET RECORD I/O MODE
43500 ORM TEMP,%IOOPN(CINDEX)
43600 JRST SETBIN
43700
43800 LINEMD: MOVSI TEMP,LNEFLG+STRFLG ;SET NUMBERED LINE MODE
43900 ORM TEMP,%IOOPN(CINDEX)
44000 HLLOS %IOBRK+7(CINDEX) ;SET NO LINE NUMBERS YET
44100 JRST ENDFLD
44200
44300 STRMOD: MOVSI TEMP,STRFLG ;SET STRING MODE
44400 ORM TEMP,%IOOPN(CINDEX)
44500 JRST ENDFLD
44600
44700 ENDPR: TLZN FLAG,LOOKPR ;WERE WE LOOKING FOR PROTECT CODE
44800 JRST UNKNOW
44900 TLZN FLAG,FINDDG ;DID WE FIND NUMBER
45000 JRST UNKNOW
45100 CAIL ASSEMB,1000 ;IS LEGAL CODE
45200 JRST UNKNOW
45300 TLO FLAG,FINDPR ;MARK AS FOUND
45400 TLZ FLAG,LOOKDG
45500 HRRZM ASSEMB,%IOPRO(CINDEX)
45600 JRST NEWITM ;STORE IT
45700
45800 COMMA: TLZN FLAG,LOOKPP ;WERE WE LOOKING FOR PROJECT
45900 JRST UNKNOW
46000 TLZN FLAG,FINDDG ;DID WE FIND NUMBER
46100 JRST UNKNOW
46200 TLO FLAG,LOOKPG ;MARK LOOKING FOR PROGRAMMER
46300 HRLZM ASSEMB,%IOLEB+3(CINDEX)
46400 HRLZM ASSEMB,%IOPP(CINDEX)
46500 JRST NEWITM ;STORE IT
46600
46700 ENDPP: TLZN FLAG,LOOKPG ;WERE WE LOOKING FOR PROGRAMMER
46800 JRST UNKNOW
46900 TLZN FLAG,FINDDG ;DID WE FIND NUMBER
47000 JRST UNKNOW
47100 TLO FLAG,FINDPP ;MARK FOUND
47200 TLZ FLAG,LOOKDG
47300 HRRM ASSEMB,%IOLEB+3(CINDEX)
47400 HRRM ASSEMB,%IOPP(CINDEX)
47500 JRST NEWITM ;STORE IT
47600
47700 DELCOD: TLNE FLAG,LOOKPP+LOOKPR+FINDPR+LOOKPG
47800 JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND PROT
47900 TLZ FLAG,LOOKDG
48000 TLO FLAG,FINDPR
48100 HRRZS %IOPRO(CINDEX) ;MARK FILE TO BE DELETED
48200 JRST ENDFLD
48300
48400 CONDOP: TLNE FLAG,LOOKPP+LOOKPR+LOOKPG
48500 JRST UNKNOW ;NOT IN P-P OR IN PROT
48600 TLZ FLAG,LOOKDG
48700 MOVSI TEMP,CONFLG
48800 ORM TEMP,%IOOPN(CINDEX)
48900 JRST ENDFLD ;SET CONDITIONAL MODE
49000
49100 STRTSW: TLNE FLAG,LOOKPP+LOOKPG+LOOKPR+GOTSW
49200 JRST UNKNOW ;NOT IN P-P OR IN PROT OR GOT SWITCHES
49300 TLZ FLAG,LOOKDG
49400 TLO FLAG,SWSKIP
49500 MOVE SWPTR,[POINT 7,%OPNSW]
49600 JRST ENDFLD+2 ;SET UP FOR SWITCHES
49700
49800 ENDSW: TLZN FLAG,SWSKIP ;BETTER HAVE BEEN PROCESSING SWITCHES
49900 JRST UNKNOW
50000 TLO FLAG,GOTSW
50100 MOVEI TEMP,0
50200 IDPB TEMP,SWPTR ;MARK END OF SWITCHES
50300 JRST NEWITM
50400
50500 SWTEST: MOVE TEMP,SWPTR ;CHECK SWITCHES
50600 CAIN CHAR,"Z"
50700 IDPB CHAR,SWPTR
50800 CAIN CHAR,"A"
50900 IDPB CHAR,SWPTR ;CONDITIONALLY STORE
51000 CAIN CHAR,"B"
51100 IDPB CHAR,SWPTR ;JUST STORE DEFERRED ONES
51200 CAIN CHAR,"C"
51300 IDPB CHAR,SWPTR
51400 CAIN CHAR,"W"
51500 IDPB CHAR,SWPTR
51600 CAIN CHAR,"T"
51700 IDPB CHAR,SWPTR
51800 CAMN SWPTR,[POINT 7,%OPNSW+7,^D34]
51900 JRST UNKNOW ;CHECK LIMIT
52000 CAME TEMP,SWPTR
52100 JRST NEWITM ;IF WE STORED ONE, DONE
52200 CAIN CHAR,"U"
52300 JRST UNLOAD ;SPECIAL SWITCH
52400 CAIN CHAR,"2"
52500 MOVE ASSEMB,[XWD 000200,777177] ;200 BPI
52600 CAIN CHAR,"5"
52700 MOVE ASSEMB,[XWD 000400,777177] ;556 BPI
52800 CAIN CHAR,"8"
52900 MOVE ASSEMB,[XWD 000600,777177] ;800 BPI
53000 CAIN CHAR,"E"
53100 HRLOI ASSEMB,001000 ;EVEN PARITY
53200 CAIN CHAR,"O"
53300 HRRZI ASSEMB,776777 ;ODD PARITY
53400 JUMPE ASSEMB,UNKNOW ;ERROR, UNKNOWN SWITCH
53500 HRROI TEMP,(ASSEMB)
53600 ANDM TEMP,%IOOPN(CINDEX) ;SET MODE
53700 HLRZ TEMP,ASSEMB
53800 ORM TEMP,%IOOPN(CINDEX)
53900 JRST NEWITM ;GET NEXT
54000
54100 UNLOAD: MOVSI TEMP,REWFLG ;SET UNLOAD ON CLOSE
54200 ORM TEMP,%IOOPN(CINDEX)
54300 JRST NEWITM
54400
54500 SETXIT: TLNE FLAG,FINDMD ;HAVE WE FOUND MODE SET
54600 JRST .+12
54700 MOVSI TEMP,STRFLG+LNEFLG
54800 ORM TEMP,%IOOPN(CINDEX) ;NO, SET DEFAULT
54900 HLLOS %IOBRK+7(CINDEX)
55000 MOVE TEMP,[XWD 000014,176400]
55100 MOVEM TEMP,%IOBRK(CINDEX)
55200 MOVSI TEMP,3
55300 MOVEM TEMP,%IOBRK+1(CINDEX)
55400 MOVEI TEMP,3
55500 MOVEM TEMP,%IOBRK+6(CINDEX)
55600 MOVSI TEMP,%SAVE ;DONE, RESTORE REGISTERS
55700 BLT TEMP,5
55800 MOVE TEMP,%IOOPN+1(CINDEX) ;WHAT ARE DEVICE CHARACTERISTICS
55900 DEVCHR TEMP,
56000 TLNN TEMP,40 ;IS DEVICE AVAILABLE TO JOB
56100 JRST NOTAV
56200 MOVE TEMP3,%IOOPN(CINDEX)
56300 TRNE TEMP3,17 ;CHECK I/O MODE POSSIBLE
56400 JRST .+6
56500 TRNN TEMP,1 ;STRING I/O
56600 JRST NOSTRG
56700 JRST .+3
56800 TRNN TEMP,10000 ;BITS I/O
56900 JRST NOBITS
57000 MOVE TEMP3,JOBUUO ;GO TO PROPER ROUTINE
57100 TLNE TEMP3,40
57200 JRST OPENO
57300 JRST OPENI
57400
57500 NOTAV: MOVEI ERROR,[ASCIZ/OPEN - $: NOT AVAILABLE/]
57600 JRST OPENER+1
57700
57800 NOSTRG: MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO STRING I/O@]
57900 JRST OPENER+1
58000
58100 NOBITS: MOVE TEMP,%IOOPN(CINDEX)
58200 TLNE TEMP,RECFLG ;IS RECORD I/O
58300 JRST NORECD
58400 MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO BITS I/O@]
58500 JRST OPENER+1
58600
58700 NORECD: MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO RECORD I/O@]
58800 JRST OPENER+1
58900
59000 UNKNOW: MOVEI ERROR,[ASCIZ/OPEN - UNRECOGNIZABLE FILE DESCRIPTOR/]
59100 PUSHJ %P,%ERROR
59200 EXIT
59300
59400 %OPENT: MOVE CHAN,-1(%P) ;GET CHANNEL NUMBER
59500 POP %P,-1(%P) ;CLOSE UP STACK
59600 JUMPL CHAN,CHANER
59700 CAIL CHAN,^D16 ;0 <= CHAN < 16
59800 JRST CHANER
59900 IMULI CHAN,%IOSIZ ;GET INDEX INTO TABLES
60000 SKIPGE %IOOPN(CHAN) ;OPEN FLAG IS SIGN BIT
60100 AOS %UUO ;TRUE RETURN IF CHANNEL OPEN
60200 POPJ %P,
00100 PRGEND
00200 TITLE %INOUT -- ALGOLW INPUT/OUTPUT ROUTINES -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %READ,%WRITE,%EFILE,%BRK0,%BRK1,%GETLN,%PUTLN
00500 ENTRY %GETBK,%CLRBK,%RDLST,%WRLST
00600 EXTERN %IOOPN,%IOSIZ,%IOBRK,%ERROR,%ERRNM,%ERRSB,%IOLEB
00700 EXTERN %ERRST,%SAVE,%XUUO,%UUO,JOBUUO,%ERROC,%IOBFH
00800 %P= 17
00900 CHAN= 10
01000 CINDEX= 11
01100 BYTEPT= 12
01200 LENGTH= 13
01300 LINENO= 12
01400 DIGIT= 13
01500 TEMP2= 12
01600 TEMP= 14
01700 ERROR= 14
01800 CHAR= 6
01900 BFHD= 7
02000 BYTE= 7
02100 LNEFLG= 200000 ;FLAGS IN LH OF %IOOPN
02200 INFLG= 040000
02300 OUTFLG= 020000
02400 BITFLG= 010000
02500 STRFLG= 004000
02600
02700 INCHK: MOVE CINDEX,@JOBUUO ;GET CHANNEL NUMBER
02800 JUMPGE CINDEX,INCHK2 ;CHECK FOR VALIDITY
02900 ILLCHN: MOVEI ERROR,[ASCIZ/$ - ILLEGAL CHANNEL - $/]
03000 PUSHJ %P,%ERROR
03100 HLRZ ERROR,CHAN
03200 PUSHJ %P,%ERRST
03300 MOVE ERROR,CINDEX
03400 PUSHJ %P,%ERRNM
03500 EXIT
03600 INCHK2: CAIL CINDEX,^D16
03700 JRST ILLCHN
03800 HRRI CHAN,(CINDEX) ;SET CHANNEL NUMBER
03900 IMULI CINDEX,%IOSIZ ;GET INDEX INTO TABLES
04000 SKIPGE TEMP,%IOOPN(CINDEX)
04100 JRST .+4 ;CHECK CHANNEL OPEN
04200 NOTOPN: MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN/]
04300 MOVEI CINDEX,(CHAN)
04400 JRST ILLCHN+1
04500 TLNE TEMP,INFLG ;CHECK OPEN FOR INPUT
04600 POPJ %P,
04700 MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR INPUT/]
04800 JRST NOTOPN+1
04900
05000 OUTCHK: MOVE CINDEX,@JOBUUO ;GET CHANNEL NUMBER
05100 JUMPL CINDEX,ILLCHN ;CHECK FOR VALIDITY
05200 CAIL CINDEX,^D16
05300 JRST ILLCHN
05400 HRRI CHAN,(CINDEX) ;SET CHANNEL NUMBER
05500 IMULI CINDEX,%IOSIZ ;GET INDEX INTO TABLES
05600 SKIPL TEMP,%IOOPN(CINDEX)
05700 JRST NOTOPN ;CHECK CHANNEL OPEN
05800 TLNE TEMP,OUTFLG
05900 POPJ %P, ;CHECK OPEN FOR OUTPUT
06000 MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR OUTPUT/]
06100 JRST NOTOPN+1
06200
06300 %EFILE: HRLZI CHAN,[ASCIZ/ENDFILE/]
06400 PUSHJ %P,INCHK ;SET UP
06500 MOVE TEMP,[STATZ 020000]
06600 DPB CHAN,[POINT 4,TEMP,^D12]
06700 XCT TEMP ;TEST FOR END OF FILE
06800 AOS %UUO ;IF SO, SKIP RETURN
06900 JRST %XUUO
07000
07100 %CLRBK: HRLZI CHAN,[ASCIZ/SETBREAK/]
07200 PUSHJ %P,INCHK ;SET UP
07300 TLNE TEMP,STRFLG ;CHECK STRING I/O
07400 JRST .+3
07500 BRKERR: MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
07600 JRST NOTOPN+1
07700 HRLI CINDEX,-7 ;SETUP FOR AOBJN THROUGH %IOBRK
07800 SETZM %IOBRK(CINDEX)
07900 AOBJN CINDEX,.-1 ;CLEAR BREAK TABLE
08000 HRLOI TEMP,37777
08100 ANDM TEMP,%IOBRK(CINDEX) ;ADDRESS NOW %IOBRK+7
08200 JRST %XUUO ;EXIT
08300
08400 BRKSUP: HRLZI CHAN,[ASCIZ/SETBREAK/]
08500 PUSHJ %P,INCHK ;SET UP
08600 TLNN TEMP,STRFLG ;CHECK STRING I/O
08700 JRST BRKERR
08800 MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
08900 MOVEM BYTE,%SAVE+BYTE
09000 LDB TEMP,[POINT 4,JOBUUO,^D12]
09100 HRLI TEMP,(TEMP) ;SAVE COPY OF AC FIELD
09200 ANDCMI TEMP,1
09300 MOVE BYTEPT,(TEMP) ;GET DV
09400 MOVE LENGTH,1(TEMP)
09500 ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
09600 HLRZ LENGTH,LENGTH ; AND GET LENGTH
09700 POPJ %P, ;DONE WITH BREAK SETUP
09800
09900 BRKCON: SOJL LENGTH,BRKXIT ;ACTUALLY FILL BREAK TABLE
10000 ILDB CHAR,BYTEPT
10100 IDIVI CHAR,^D18 ;GET WORD AND BYTE #
10200 ADDI CHAR,%IOBRK(CINDEX)
10300 DPB TEMP,BRKTBL(BYTE)
10400 JRST BRKCON ;PROCESS NEXT
10500 BRKXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
10600 MOVE BYTE,%SAVE+BYTE
10700 JRST %XUUO ;DONE
10800
10900 .TEMP== 1 ;SET UP BYTE POINTER TABLE
11000 BRKTBL: REPEAT ^D18,
11100 < POINT 2,(CHAR),.TEMP
11200 .TEMP== .TEMP+2>
11300
11400 %BRK0: PUSHJ %P,BRKSUP ;SETUP
11500 TLNN TEMP,1 ;AC ODD OR EVEN
11600 SKIPA TEMP,[0]
11700 MOVEI TEMP,2
11800 JRST BRKCON ;SET VALUE ACCORDINGLY
11900
12000 %BRK1: PUSHJ %P,BRKSUP ;SETUP
12100 TLNN TEMP,1 ;AC ODD OR EVEN
12200 SKIPA TEMP,[1]
12300 MOVEI TEMP,3
12400 JRST BRKCON ;SET VALUE ACCORDINGLY
12500
12600 %RDLST:%WRLST:
12700 MOVEI ERROR,[ASCIZ@RECORD I/O NOT IMPLEMENTED YET@]
12800 PUSHJ %P,%ERROR
12900 EXIT
13000
13100 %GETBK: HRLZI CHAN,[ASCIZ/BREAK/]
13200 PUSHJ %P,INCHK ;SETUP
13300 TLNN TEMP,STRFLG
13400 JRST BRKERR ;CHECK STRING I/O
13500 LDB TEMP,[POINT 4,JOBUUO,^D12]
13600 TRZ TEMP,1
13700 MOVE BYTEPT,(TEMP) ;GET DV
13800 MOVE LENGTH,1(TEMP)
13900 ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
14000 HLRZ LENGTH,LENGTH ;GET LENGTH
14100 LDB TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
14200 SOJL LENGTH,%XUUO ;NULL STRING
14300 IDPB TEMP,BYTEPT
14400 JRST BREAK2+2 ;STORE IT AND ADJUST LENGTH OR PAD OUT
14500
14600 %GETLN: HRLZI CHAN,[ASCIZ/LINENO/]
14700 PUSHJ %P,INCHK ;SETUP
14800 TLNE TEMP,LNEFLG ;CHECK LINE NUMBER MODE
14900 JRST .+3
15000 LNEERR: MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN WITH LINE NUMBERING/]
15100 JRST NOTOPN+1
15200 HRRE TEMP2,%IOBRK+7(CINDEX)
15300 LDB TEMP,[POINT 4,JOBUUO,^D12]
15400 MOVEM TEMP2,(TEMP) ;STORE VALUE
15500 JRST %XUUO ;DONE
15600
15700 OUTPUT: SOSG 2(BFHD) ;OUTPUT A CHARACTER
15800 JRST .+3
15900 IDPB CHAR,1(BFHD)
16000 POPJ %P, ;AND RETURN
16100 MOVE TEMP,[OUT] ;OR GET BUFFER AND TRY AGAIN
16200 DPB CHAN,[POINT 4,TEMP,^D12]
16300 XCT TEMP
16400 JRST OUTPUT+2
16500 JUMPG CINDEX,.+2 ;ERROR ON TTY, FATAL
16600 HALT
16700 MOVEI ERROR,[ASCIZ/$ - $:$$$ OUTPUT ERROR - STATUS $/]
16800 EDTSTS: PUSHJ %P,%ERROR
16900 HLRZ ERROR,CHAN
17000 PUSHJ %P,%ERRST
17100 MOVE ERROR,%IOOPN+1(CINDEX)
17200 PUSHJ %P,%ERRSB
17300 MOVE ERROR,%IOLEB(CINDEX)
17400 JUMPE ERROR,.+7 ;EDIT MESSAGE WITH OR WITHOUT FILE NAME
17500 PUSHJ %P,%ERRSB
17600 MOVEI ERROR,[ASCIZ/./]
17700 PUSHJ %P,%ERRST
17800 HLLZ ERROR,%IOLEB+1(CINDEX)
17900 PUSHJ %P,%ERRSB
18000 JRST .+7
18100 MOVEI ERROR,0
18200 PUSHJ %P,%ERRSB
18300 MOVEI ERROR,0
18400 PUSHJ %P,%ERRSB
18500 MOVEI ERROR,0
18600 PUSHJ %P,%ERRSB
18700 MOVE ERROR,[GETSTS ERROR]
18800 DPB CHAN,[POINT 4,ERROR,^D12]
18900 XCT ERROR ;GET STATUS
19000 PUSHJ %P,%ERROC
19100 EXIT
19200
19300 %PUTLN: HLRZI CHAN,[ASCIZ/OUTLINE/]
19400 PUSHJ %P,OUTCHK ;SETUP
19500 TLNN TEMP,LNEFLG ;CHECK LINE NUMBERING
19600 JRST LNEERR
19700 MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
19800 MOVEM BFHD,%SAVE+BFHD
19900 LDB LINENO,[POINT 4,JOBUUO,^D12]
20000 SKIPL LINENO,(LINENO) ;GET AND CHECK LINE NUMBER
20100 JRST LNEOK
20200 LNEVAL: MOVEI ERROR,[ASCIZ/OUTLINE - $ < 0 OR > 99999/]
20300 PUSHJ %P,%ERROR
20400 MOVE ERROR,LINENO
20500 PUSHJ %P,%ERRNM
20600 EXIT
20700 LNEOK: CAILE LINENO,^D99999
20800 JRST LNEVAL
20900 HLRZ BFHD,%IOOPN+2(CINDEX)
21000 LDB TEMP,[POINT 6,1(BFHD),5]
21100 CAIE TEMP,1 ;GET OUTPUT ON WORD BOUNDARY
21200 CAIN TEMP,^D36
21300 JRST .+4
21400 MOVEI CHAR,0
21500 PUSHJ %P,OUTPUT ;OUTPUT NULLS UNTIL SO
21600 JRST LNEOK+3
21700 PUSHJ %P,LNEEDT ;OUTPUT LINE NUMBER
21800 ORM LINENO,@1(BFHD) ;LINENO LEFT AS 1
21900 MOVEI CHAR,011
22000 PUSHJ %P,OUTPUT ;OUTPUT TAB AT END
22100 JRST OUTXIT ;FORCE BUFFER OUT AND EXIT
22200
22300 LNEEDT: ADDI LINENO,^D100000 ;TO FORCE FIVE DIGITS
22400 IDIVI LINENO,^D10
22500 CAIN LINENO,1
22600 JRST .+4
22700 HRLM DIGIT,(%P) ;REGULAR EDITOR
22800 PUSHJ %P,LNEEDT+1
22900 HLRZ DIGIT,(%P)
23000 MOVEI CHAR,"0"
23100 ADDI CHAR,(DIGIT) ;MAKE ASCII
23200 JRST OUTPUT ;OUTPUT WILL RETURN
23300
23400 %WRITE: HRLZI CHAN,[ASCIZ/OUT/]
23500 PUSHJ %P,OUTCHK ;SETUP
23600 MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
23700 MOVEM BFHD,%SAVE+BFHD
23800 LDB CHAR,[POINT 4,JOBUUO,^D12]
23900 MOVE BYTEPT,(CHAR)
24000 MOVE LENGTH,1(CHAR) ;GET DV
24100 ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
24200 HLRZ LENGTH,LENGTH ;GET LENGTH
24300 HLRZ BFHD,%IOOPN+2(CINDEX)
24400 LDB CHAR,[POINT 6,BYTEPT,^D11]
24500 CAIN CHAR,1 ;SEE WHAT KIND OF BYTES
24600 JRST CHKBIT
24700 TLNE TEMP,STRFLG ;WANTS CHARACTERS
24800 JRST OUTLP
24900 MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
25000 JRST NOTOPN+1
25100 CHKBIT: TLNE TEMP,BITFLG ;WANTS BITS
25200 JRST OUTLP
25300 MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
25400 JRST NOTOPN+1
25500 OUTLP: SOJL LENGTH,OUTXIT ;DO ONE CHARACTER
25600 ILDB CHAR,BYTEPT
25700 PUSHJ %P,OUTPUT ;OUTPUT IT
25800 JRST OUTLP
25900 OUTXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
26000 MOVE BFHD,%SAVE+BFHD
26100 JUMPG CINDEX,%XUUO ;IF NOT CHANNEL 0, DONE
26200 OUT 0,
26300 AOSA %IOBFH+2 ;IF TTY, FORCE OUTPUT
26400 HALT ;ERROR ON TTY FATAL
26500 JRST %XUUO ;NOW DONE
26600
26700 INPUT: MOVE TEMP,[STATZ 020000]
26800 DPB CHAN,[POINT 4,TEMP,^D12]
26900 XCT TEMP ;CHECK END FILE ALREADY
27000 JRST FORCEF
27100 SOSG 2(BFHD) ;INPUT A CHARACTER
27200 JRST .+3
27300 ILDB CHAR,1(BFHD)
27400 POPJ %P, ;AND EXIT
27500 MOVE TEMP,[IN] ;OR GET A BUFFER AND TRY AGAIN
27600 DPB CHAN,[POINT 4,TEMP,^D12]
27700 XCT TEMP
27800 JRST INPUT+6
27900 MOVE TEMP,[STATZ 020000]
28000 DPB CHAN,[POINT 4,TEMP,^D12]
28100 XCT TEMP ;CHECK END FILE
28200 JRST .+5
28300 JUMPG CINDEX,.+2
28400 HALT ;ERROR ON TTY, FATAL
28500 MOVEI ERROR,[ASCIZ/$ - $:$$$ INPUT ERROR - STATUS $/]
28600 JRST EDTSTS
28700 JUMPG CINDEX,FORCEF ;IF NOT TTY, FORCE END FILE CHAR
28800 GETSTS 0,ERROR ;ELSE RESET END FILE
28900 ANDI ERROR,757777
29000 SETSTS 0,(ERROR)
29100 JRST INPUT+4 ;^Z ALREADY RECEIVED
29200 FORCEF: POP %P,TEMP ;DISCARD RETURN
29300 MOVEI TEMP,032 ;FORCE ^Z BREAK CHARACTER
29400 AOJA LENGTH,BREAK2+1
29500
29600 %READ: HRLZI CHAN,[ASCIZ/IN/]
29700 PUSHJ %P,INCHK ;SETUP
29800 MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
29900 MOVEM BFHD,%SAVE+BFHD
30000 HRRZ BFHD,%IOOPN+2(CINDEX)
30100 LDB CHAR,[POINT 4,JOBUUO,^D12]
30200 ANDI CHAR,16
30300 MOVE BYTEPT,(CHAR) ;GET DV
30400 MOVE LENGTH,1(CHAR)
30500 ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
30600 HLRZ LENGTH,LENGTH ;AND GET LENGTH
30700 LDB CHAR,[POINT 6,BYTEPT,^D11]
30800 CAIE CHAR,1 ;SEE WHAT KIND OF BYTES
30900 JRST RDCHAR
31000 TLNE TEMP,BITFLG ;BITS EXPECTED
31100 JRST .+3
31200 MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
31300 JRST NOTOPN+1
31400 BITLP: SOJL LENGTH,INXIT ;PROCESS BITS
31500 PUSHJ %P,INPUT ;GET A BIT
31600 IDPB CHAR,BYTEPT ;STORE IT
31700 JRST BITLP
31800 INXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
31900 MOVE BFHD,%SAVE+BFHD
32000 JRST %XUUO ;DONE, EXIT
32100 RDCHAR: TLNE TEMP,STRFLG ;CHARACTERS EXPECTED
32200 JRST .+3
32300 MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
32400 JRST NOTOPN+1
32500 HRLZI TEMP,177 ;RESET BREAK CHARACTER
32600 ANDCAM TEMP,%IOBRK+7(CINDEX)
32700 CHARLP: SOJL LENGTH,INXIT
32800 PUSHJ %P,INPUT ;GET A CHARACTER
32900 JUMPE CHAR,.-1 ;IGNORE NULLS
33000 MOVE TEMP,@1(BFHD) ;SEE IF LINE NUMBER
33100 TRNN TEMP,1
33200 JRST NOLINE ;NOPE
33300 MOVE TEMP,%IOOPN(CINDEX)
33400 TLNN TEMP,LNEFLG ;LINE NUMBER MODE
33500 JRST NOLINE ;NOPE, JUST CHARACTERS
33600 SUBI CHAR,"0"
33700 HRRM CHAR,%IOBRK+7(CINDEX)
33800 REPEAT 4,
33900 < PUSHJ %P,INPUT
34000 HRRZ TEMP,%IOBRK+7(CINDEX)
34100 IMULI TEMP,^D10
34200 ADDI TEMP,-"0"(CHAR)
34300 HRRM TEMP,%IOBRK+7(CINDEX)>
34400 PUSHJ %P,INPUT ;GOT LINE NUMBER, THROW AWAY TAB
34500 JRST CHARLP+1 ;GET NEXT CHARACTER
34600 NOLINE: MOVE TEMP,BFHD ;SAVE FOR DIVIDE
34700 HRLI TEMP,(CHAR) ;SAVE POSSIBLE BREAK CHAR
34800 IDPB CHAR,BYTEPT ;ASSUME WE WANT CHARACTER
34900 IDIVI CHAR,^D18
35000 EXCH TEMP,BFHD
35100 ADDI CHAR,%IOBRK(CINDEX)
35200 LDB TEMP,BRKTBL(TEMP)
35300 JRST .+1(TEMP) ;GOT BREAK TYPE, DO IT
35400 JRST CHARLP ;NORMAL CHARACTER
35500 JRST BACKUP ;IGNORE CHARACTER
35600 JRST BREAK2 ;IS BREAK CHARACTER
35700 IBP BYTEPT ;IS BREAK CHARACTER TOO
35800 IBP BYTEPT ; BUT BACKUP STUFF SO
35900 IBP BYTEPT ; WILL NOT BE READ
36000 IBP BYTEPT
36100 SOJ BYTEPT,
36200 AOJA LENGTH,BREAK2
36300 BACKUP: IBP BYTEPT ;IGNORE CHARACTER
36400 IBP BYTEPT
36500 IBP BYTEPT
36600 IBP BYTEPT
36700 SOJA BYTEPT,CHARLP+1 ;GET NEXT
36800 BREAK2: HLRZ TEMP,BFHD ;GET BREAK CHARACTER
36900 DPB TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
37000 LDB TEMP,[POINT 4,JOBUUO,^D12]
37100 TRZN TEMP,1 ;AFTER STORING CHARACTER,
37200 JRST PADOUT ;SEE IF SHOULD ADJUST LENGTH
37300 HLRZ TEMP2,1(TEMP) ;OR PAD OUT WITH BLANKS
37400 SUBI TEMP2,(LENGTH)
37500 HRLM TEMP2,1(TEMP)
37600 JRST INXIT ;ADJUSTED LENGTH, EXIT
37700 PADOUT: MOVEI CHAR," "
37800 SOJL LENGTH,INXIT ;PAD OUT WITH BLANKS
37900 IDPB CHAR,BYTEPT
38000 JRST PADOUT+1
00100 PRGEND
00200 TITLE %CLOSE -- ALGOLW FILE CLOSE ROUTINE -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %CLOSE
00500 EXTERN %IOOPN,%IOLEB,%IOPRO,%IOREG,%AVIOB
00600 EXTERN %SREG,%NREG,%LREG,%ERROR,%ERRNM,%COLLE,%IOSIZ
00700 EXTERN JOBUUO,%XUUO,%ERRSB,%IOPP,%ERRST
00800 %P= 17
00900 CHAN= 10
01000 CINDEX= 11
01100 TEMP1= 12
01200 TEMP2= 11
01300 REGPT= 13
01400 ERROR= 14
01500 REWFLG= 002000 ;FLAGS IN LH OF %IOOPN
01600
01700 %CLOSE: MOVE CHAN,@JOBUUO ;GET CHANNEL NUMBER
01800 JUMPG CHAN,CHANGR ;CHECK CHAN>0
01900 MOVEI ERROR,[ASCIZ/CLOSE - ILLEGAL CHANNEL - $/]
02000 PUSHJ %P,%ERROR
02100 MOVE ERROR,CHAN
02200 PUSHJ %P,%ERRNM ;EDIT ERROR MESSAGE
02300 EXIT ;QUIT
02400
02500 CHANGR: CAIL CHAN,^D16 ;CHECK CHAN<16
02600 JRST %CLOSE+2
02700 MOVEI CINDEX,(CHAN) ;INDEX INTO TABLES
02800 IMULI CINDEX,%IOSIZ
02900 SKIPGE %IOOPN(CINDEX) ;IS CHANNEL OPEN?
03000 JRST CHANOK
03100 MOVEI ERROR,[ASCIZ/CLOSE - CHANNEL $ NOT OPEN/]
03200 PUSHJ %P,%ERROR
03300 MOVE ERROR,CHAN
03400 PUSHJ %P,%ERRNM ;EDIT ERROR MESSAGE
03500 EXIT ;QUIT
03600
03700 CHANOK: MOVE TEMP1,[CLOSE] ;CLOSE CHANNEL
03800 DPB CHAN,[POINT 4,TEMP1,^D12]
03900 XCT TEMP1
04000 MOVE TEMP1,[STATZ 740000] ;CHECK CLOSE STATUS
04100 DPB CHAN,[POINT 4,TEMP1,^D12]
04200 XCT TEMP1
04300 JRST CLOSER ;ERROR ON CLOSE
04400 MOVE TEMP1,%IOOPN(CINDEX)
04500 TLNN TEMP1,REWFLG ;UNLOAD ON CLOSE?
04600 JRST RENAME
04700 MOVE TEMP1,[MTAPE 11]
04800 DPB CHAN,[POINT 4,TEMP1,^D12]
04900 XCT TEMP1 ;YES, DO IT
05000
05100 RENAME: SKIPGE TEMP1,%IOPRO(CINDEX)
05200 JRST NORENA ;SEE IF RENAME AFTER CLOSE
05300 MOVE ERROR,%IOLEB(CINDEX)
05400 MOVEM ERROR,%IOPRO(CINDEX) ;SAVE FILE NAME
05500 CAIG TEMP1,777 ;IS FILE TO BE DELETED
05600 JRST .+3
05700 SETZM %IOLEB(CINDEX) ;YES
05800 JRST .+2 ;ELSE JUST CHANGE PROTECTION
05900 DPB TEMP1,[POINT ^D9,%IOLEB+2(CINDEX),^D8]
06000 MOVE TEMP1,%IOPP(CINDEX)
06100 MOVEM TEMP1,%IOLEB+3(CINDEX) ;RESTORE PROJ-PROG
06200 RERE: MOVE TEMP1,[RENAME %IOLEB(CINDEX)]
06300 DPB CHAN,[POINT 4,TEMP1,^D12]
06400 XCT TEMP1
06500 JRST RENERR ;ERROR ON RENAME
06600
06700 NORENA: MOVE TEMP1,[RELEAS] ;NOW RELEASE CHANNEL
06800 DPB CHAN,[POINT 4,TEMP1,^D12]
06900 XCT TEMP1
07000 HRLOI TEMP1,377777 ;MARK AS CLOSED
07100 ANDM TEMP1,%IOOPN(CINDEX)
07200 MOVE REGPT,%IOREG(CINDEX) ;MERGE ADJACENT REGIONS
07300 MOVE TEMP1,%NREG(REGPT)
07400 MOVE TEMP2,%SREG(REGPT)
07500 EXCH TEMP2,%SREG+1(REGPT)
07600 SUBI TEMP2,1(TEMP1) ;SET UP BUFFER AS STORAGE BLOCK
07700 HRLI TEMP2,400000
07800 MOVSM TEMP2,(TEMP1)
07900 MOVEI TEMP1,0
08000 MOVEI TEMP2,^D16 ;ADJUST I/O REGION POINTERS
08100 CAMGE REGPT,%IOREG(TEMP1)
08200 SOS %IOREG(TEMP1) ;IS ABOVE MERGED REGION
08300 ADDI TEMP1,%IOSIZ
08400 SOJG TEMP2,.-3 ;DO NEXT
08500
08600 CLOREG: CAML REGPT,%AVIOB ;NOW MOVE OTHER AREAS DOWN
08700 JRST ENDCLO
08800 MOVE TEMP1,%SREG+1(REGPT)
08900 MOVEM TEMP1,%SREG(REGPT)
09000 MOVE TEMP1,%LREG+1(REGPT)
09100 MOVEM TEMP1,%LREG(REGPT)
09200 MOVE TEMP1,%NREG+1(REGPT)
09300 MOVEM TEMP1,%NREG(REGPT)
09400 AOJA REGPT,CLOREG
09500
09600 ENDCLO: SOS %AVIOB ;ONE LESS REGION
09700 PUSHJ %P,%COLLE ;FORCE GARBAGE COLLECTION TO CLOSE
09800 MOVEI TEMP1,0 ;FIND HOW MUCH FREE SPACE
09900 MOVE REGPT,%AVIOB ; IN ALL BUT LAST REGION
10000 JUMPE REGPT,.+3
10100 ADD TEMP1,%LREG(REGPT)
10200 SOJG REGPT,.-1
10300 MOVEI TEMP2,0 ;ALLOW EXTRA 1K GROWTH SPACE IF <1K
10400 CAIG TEMP1,1777
10500 MOVEI TEMP2,2000
10600 MOVE REGPT,%AVIOB
10700 MOVE TEMP1,%NREG(REGPT)
10800 ADD TEMP1,TEMP2 ;ALSO ALLOW TO NEXT 1K BOUNDARY
10900 ORI TEMP1,1777
11000 MOVE TEMP2,%NREG(REGPT)
11100 SUBM TEMP1,TEMP2
11200 ADDI TEMP2,1
11300 MOVEM TEMP2,%LREG(REGPT) ;SET NEW FREE LENGTH
11400 CORE TEMP1, ;ADJUST CORE BOUNDARY
11500 JRST .+2
11600 JRST %XUUO ;DONE, EXIT
11700 MOVNI TEMP1,2000 ;TRIED TO GET AT MOST 1K
11800 ADDB TEMP1,%LREG(REGPT)
11900 ADD TEMP1,%NREG(REGPT)
12000 SUBI TEMP1,1 ;MUST BE ABLE TO GET CORE WITHOUT
12100 CORE TEMP1, ; EXTRA 1K
12200 HALT
12300 JRST %XUUO
12400
12500 CLOSER: MOVEI ERROR,[ASCIZ@CLOSE - $:$$$ I/O ERROR DURING CLOSE@]
12600 PUSHJ %P,%ERROR
12700 MOVE ERROR,%IOOPN+1(CINDEX)
12800 PUSHJ %P,%ERRSB
12900 MOVE ERROR,%IOLEB(CINDEX)
13000 JUMPE ERROR,.+7
13100 PUSHJ %P,%ERRSB
13200 MOVEI ERROR,[ASCIZ/./]
13300 PUSHJ %P,%ERRST
13400 HLLZ ERROR,%IOLEB+1(CINDEX)
13500 PUSHJ %P,%ERRSB
13600 EXIT
13700 MOVEI ERROR,0
13800 PUSHJ %P,%ERRSB
13900 MOVEI ERROR,0
14000 PUSHJ %P,%ERRSB
14100 MOVEI ERROR,0
14200 PUSHJ %P,%ERRSB
14300 EXIT ;PRINT MESSAGE, QUIT
14400
14500 RENERR: LDB TEMP1,[POINT ^D12,%IOLEB+1(CINDEX),^D35]
14600 CAIN TEMP1,3 ;IS FILE IN USE, TRY AGAIN
14700 JRST RERE
14800 MOVEI ERROR,[ASCIZ@CLOSE - $:$.$ I/O ERROR ON PROTECTION CHANGE OR DELETE@]
14900 PUSHJ %P,%ERROR
15000 MOVE ERROR,CHAN
15100 PUSHJ %P,%ERRNM
15200 MOVE ERROR,%IOOPN+1(CINDEX)
15300 PUSHJ %P,%ERRSB
15400 MOVE ERROR,%IOPRO(CINDEX)
15500 PUSHJ %P,%ERRSB
15600 HLLZ ERROR,%IOLEB+1(CINDEX)
15700 PUSHJ %P,%ERRSB
15800 EXIT
00100 PRGEND
00200 TITLE %ALLOC -- ALGOLW STORAGE ALLOCATOR -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %ARECD,%ASTRG,%ASTRA,%AARRY,%RARRY,%PROC,%BLOCK,%THUNK
00500 EXTERN %COLLE,%STAT,%NREG,%LREG,%AVIOB,%ERROR
00600 EXTERN %SAVE,%XUUO,%UUO,JOBUUO,%ERRNM,%HDBLK
00700 %T= 14
00800 %B= 16
00900 %P= 17
01000 SIZE= 6
01100 HEADER= 7
01200 REGPT= 10
01300 ARGCNT= 10
01400 TEMP= 11
01500 TEMP2= 12
01600 TEMP3= 13
01700 ERROR= 14
01800 RESULT= 14
01900 ARGTYP= 14
02000
02100 ALLOC: AOS %STAT+3 ;INCREMENT CALL COUNTS
02200 AOS %STAT+30
02300 MOVEI TEMP,0
02400 RUNTIM TEMP, ;CALCULATE TIME SINCE LAST CALL
02500 SUBM TEMP,%STAT
02600 EXCH TEMP,%STAT
02700 ADDM TEMP,%STAT+10 ;TOTAL TIME BETWEEN CALLS
02800 CAMLE TEMP,%STAT+11 ;MAX TIME BETWEEN CALLS
02900 MOVEM TEMP,%STAT+11
03000 ADDM SIZE,%STAT+25 ;REQUESTS SINCE LAST COLLE
03100 ADDM SIZE,%STAT+5 ;TOTAL REQUESTS
03200 CAMLE SIZE,%STAT+6
03300 MOVEM SIZE,%STAT+6 ;MAX REQUEST
03400 MOVE TEMP,%STAT+7
03500 ADDI TEMP,(SIZE) ;CUMULATIVE AVERAGE REQUEST
03600 LSH TEMP,-1
03700 MOVEM TEMP,%STAT+7
03800 MOVEI REGPT,0
03900
04000 ALLOCL: CAMG SIZE,%LREG(REGPT);LOOK FOR SPACE IN REGIONS
04100 JRST FOUNDS
04200 CAMGE REGPT,%AVIOB ;NOT IN THAT ONE, TRY NEXT
04300 AOJA REGPT,ALLOCL
04400
04500 ;****************************************************************
04600
04700 PUSHJ %P,%COLLE ;TEMPORARY DECISION ALGORITHM
04800 MOVEI REGPT,0 ;COLLECT AND SEARCH FOR ROOM NOW
04900 MOVEI TEMP,0 ;ALSO SEE HOW MUCH ROOM IF CAN'T FIT
05000
05100 ALLOC2: CAMG SIZE,%LREG(REGPT)
05200 JRST FOUND2 ;FOUND SPACE, GO FREE UP EXTRA SPACE
05300 ADD TEMP,%LREG(REGPT)
05400 CAMGE REGPT,%AVIOB
05500 AOJA REGPT,ALLOC2 ;TRY NEXT REGION
05600
05700 CAIL TEMP,2000 ;AT LEAST 1K FREE
05800 SKIPA TEMP,[0]
05900 MOVEI TEMP,2000
06000 MOVEI TEMP3,(TEMP)
06100 ADDI TEMP,(SIZE)
06200 ADD TEMP,%NREG(REGPT);FIND NEW END OF STORAGE
06300 ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
06400 MOVE TEMP2,%NREG(REGPT)
06500 SUBM TEMP,TEMP2 ;GET NEW %LREG
06600 ADDI TEMP2,1
06700 MOVEM TEMP2,%LREG(REGPT)
06800 CORE TEMP,
06900 JRST .+2 ;ERROR, NO MORE CORE
07000 JRST FOUNDS ;OK, ALLOCATE BLOCK
07100 JUMPE TEMP3,QUIT ;CAN WE GIVE UP 1K PADDING
07200 MOVNI TEMP,2000
07300 ADDB TEMP,%LREG(REGPT)
07400 ADD TEMP,%NREG(REGPT)
07500 SUBI TEMP,1
07600 CORE TEMP,
07700 JRST QUIT ;I GUESS NOT
07800 JRST FOUNDS
07900
08000 FOUND2: MOVE TEMP3,REGPT ;TOTAL UP ROOM IN REST OF REGIONS
08100 ADD TEMP,%LREG(TEMP3)
08200 CAMGE TEMP3,%AVIOB
08300 AOJA TEMP3,.-2
08400 CAIL TEMP,2000(SIZE) ;DON'T COUNT SIZE
08500 JRST FOUNDS
08600 MOVEI TEMP,2000 ;ALLOW 1K GROWTH ROOM
08700 ADD TEMP,%NREG(TEMP3);FIND NEW END OF STORAGE
08800 ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
08900 MOVE TEMP2,%NREG(TEMP3)
09000 SUBM TEMP,TEMP2 ;GET NEW %LREG
09100 ADDI TEMP2,1
09200 MOVEM TEMP2,%LREG(TEMP3)
09300 CORE TEMP,
09400 JRST .+2 ;ERROR, NO MORE CORE
09500 JRST FOUNDS ;OK, ALLOCATE BLOCK
09600 MOVNI TEMP,2000 ;CAN WE GIVE UP 1K PADDING
09700 ADDB TEMP,%LREG(TEMP3)
09800 ADD TEMP,%NREG(TEMP3)
09900 SUBI TEMP,1
10000 CORE TEMP,
10100 JRST QUIT ;I GUESS NOT
10200 JRST FOUNDS
10300
10400 QUIT: MOVEI ERROR,[ASCIZ/REQUEST FOR STORAGE, NONE AVAILABLE/]
10500 PUSHJ %P,%ERROR
10600 EXIT
10700
10800 ;*****************************************************************
10900
11000 FOUNDS: MOVNI TEMP,(SIZE) ;ADJUST REGION FOR ALLOCATED SPACE
11100 ADDM TEMP,%LREG(REGPT)
11200 MOVE RESULT,%NREG(REGPT)
11300 ADDM SIZE,%NREG(REGPT)
11400 MOVSM HEADER,(RESULT) ;INITIALIZE STORAGE AREA
11500 SETZM 1(RESULT)
11600 MOVEI TEMP,2(RESULT) ;SET UP FOR BLT
11700 HRLI TEMP,1(RESULT)
11800 ADDI SIZE,-1(RESULT)
11900 CAILE SIZE,(TEMP) ;SKIP IF ONLY ONE WORD
12000 BLT TEMP,(SIZE) ;CLEAR BLOCK
12100 MOVEI TEMP,0
12200 RUNTIM TEMP, ;CALCULATE TIME IN ALLOCATOR
12300 SUBM TEMP,%STAT
12400 EXCH TEMP,%STAT
12500 ADDM TEMP,%STAT+12 ;TOTAL TIME IN ALLOCATOR
12600 CAMLE TEMP,%STAT+13 ;MAX TIME IN ALLOCATOR
12700 MOVEM TEMP,%STAT+13
12800 MOVE SIZE,%SAVE+SIZE ;RESTORE SIZE AND HEADER
12900 MOVE HEADER,%SAVE+HEADER
13000 ADDI RESULT,1 ;POINTER PAST HEADER
13100 POPJ %P, ;DONE, EXIT
13200
13300 %ARECD: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
13400 MOVEM HEADER,%SAVE+HEADER
13500 HRRZ HEADER,JOBUUO ;GET DESCRIPTOR ADDRESS
13600 HLRZ SIZE,(HEADER) ;AND AREA SIZE
13700 ADDI SIZE,1 ;ACCOUNT FOR HEADER
13800 PUSHJ %P,ALLOC ;ALLOCATE CORE
13900 LDB TEMP,[POINT 4,JOBUUO,^D12]
14000 MOVEM RESULT,(TEMP)
14100 JRST %XUUO ;AND EXIT
14200
14300 %RARRY: SKIPA TEMP,[XWD 400000,400000] ;REFERENCE ARRAY HEADER
14400 %AARRY: MOVSI TEMP,400000 ;NON-REFERENCE ARRAY HEADER
14500 MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
14600 MOVEM HEADER,%SAVE+HEADER
14700 MOVE HEADER,TEMP ;GET HEADER CONTROL BITS
14800 LDB TEMP,[POINT 4,JOBUUO,^D12] ;GET NO. OF DIMENSIONS
14900 HRRZ TEMP2,JOBUUO ;AND DOPE VECTOR ADDRESS
15000 HLRZ SIZE,1(TEMP2) ;GET LENGTH (IN WORDS)
15100 MOVEM SIZE,2(TEMP2) ;AND SET UP DIMENSION UNITS
15200 ARRYL: MOVE SIZE,4(TEMP2) ;UPPER BOUND
15300 SUB SIZE,3(TEMP2) ; - LOWER BOUND
15400 AOJLE SIZE,NEGDIM ; + 1 = SIZE OF DIMENSION > 0
15500 MOVEM SIZE,4(TEMP2) ;SAVE IT FOR SUBSCRIPT CALCULATIONS
15600 IMUL SIZE,2(TEMP2) ; * DIMENSION UNITS
15700 CAIE TEMP,1
15800 MOVEM SIZE,5(TEMP2) ; = NEW DIMENSION UNITS
15900 ADDI TEMP2,3 ;NEXT DIMENSION
16000 SOJG TEMP,ARRYL
16100 ADDI SIZE,1 ;ALLOW FOR HEADER
16200 CAIL SIZE,400000 ;MAXIMUM STORAGE ALLOWED
16300 JRST TOOBIG
16400 ADDI HEADER,-1(SIZE) ;FINISH UP HEADER
16500 PUSHJ %P,ALLOC ;ALLOCATE STORAGE
16600 MOVE TEMP,%UUO
16700 MOVEI TEMP,@-1(TEMP) ;ADDRESS MUST BE INDEXED BY %TB OR %B
16800 HRRM RESULT,1(TEMP) ; OR BE IN ABSOLUTE LOCATION
16900 JRST %XUUO ;DONE, EXIT
17000
17100 %ASTRA: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
17200 MOVEM HEADER,%SAVE+HEADER
17300 LDB TEMP,[POINT 4,JOBUUO,^D12] ;GET NO. OF DIMENSIONS
17400 HRRZ TEMP2,JOBUUO ;AND DOPE VECTOR ADDRESS
17500 HLRE SIZE,1(TEMP2) ;GET LENGTH (IN BYTES)
17600 JUMPL SIZE,NEGLEN ; TEST > 0
17700 MOVEM SIZE,2(TEMP2) ;AND SET UP DIMENSION UNITS
17800 SARRYL: MOVE SIZE,4(TEMP2) ;UPPER BOUND
17900 SUB SIZE,3(TEMP2) ; - LOWER BOUND
18000 AOJLE SIZE,NEGDIM ; + 1 = SIZE OF DIMENSION > 0
18100 MOVEM SIZE,4(TEMP2) ;SAVE IT FOR SUBSCRIPT CALCULATIONS
18200 IMUL SIZE,2(TEMP2) ; * DIMENSION UNITS
18300 CAIE TEMP,1
18400 MOVEM SIZE,5(TEMP2) ; = NEW DIMENSION UNITS
18500 ADDI TEMP2,3
18600 SOJG TEMP,SARRYL ;NEXT DIMENSION
18700 JRST STRING ;SIZE IN BYTES, PROCESS LIKE STRING
18800
18900 %ASTRG: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
19000 MOVEM HEADER,%SAVE+HEADER
19100 HRRZ TEMP,JOBUUO ;GET DOPE VECTOR ADDRESS
19200 HLRE SIZE,1(TEMP) ;AND LENGTH (IN BYTES)
19300 JUMPL SIZE,NEGLEN ; TEST > 0
19400 STRING: JUMPG SIZE,.+4 ;TEST FOR NULL STRING
19500 MOVE SIZE,%SAVE+SIZE ;RESTORE REGISTER
19600 MOVEI RESULT,0 ;NULL POINTER
19700 JRST STRSTO
19800 LDB TEMP2,[POINT 6,@JOBUUO,^D11] ;GET BYTE SIZE
19900 MOVEI TEMP,^D36 ;HOW MANY PER WORD?
20000 IDIVI TEMP,(TEMP2)
20100 ADDI SIZE,-1(TEMP) ;PAD OUT TO END OF WORD
20200 IDIVI SIZE,(TEMP) ;NUMBER OF WORDS
20300 ADDI SIZE,1 ; + 1 FOR HEADER
20400 CAIL SIZE,400000 ;TEST MAXIMUM SIZE
20500 JRST TOOBIG
20600 MOVEI HEADER,-1(SIZE) ;SET UP HEADER
20700 TLO HEADER,400000 ;NON-REFERENCE STORAGE
20800 PUSHJ %P,ALLOC ;ALLOCATE STORAGE
20900 STRSTO: MOVE TEMP,%UUO ;DOPE VECTOR MUST BE INDEXED
21000 MOVEI TEMP,@-1(TEMP) ; BY %TB OR %B OR BE IN ABSOLUTE LOCATION
21100 HRRM RESULT,1(TEMP) ;STORE POINTER
21200 JRST %XUUO ;AND EXIT
21300
21400 NEGDIM: MOVEI ERROR,[ASCIZ/ARRAY DECLARATION - LOWER BOUND $ > UPPER BOUND $/]
21500 PUSHJ %P,%ERROR
21600 MOVE ERROR,3(TEMP2)
21700 PUSHJ %P,%ERRNM
21800 MOVE ERROR,4(TEMP2)
21900 PUSHJ %P,%ERRNM
22000 EXIT
22100
22200 TOOBIG: MOVEI ERROR,[ASCIZ/ARRAY DECLARATION - ARRAY TOO LARGE/]
22300 PUSHJ %P,%ERROR
22400 EXIT
22500
22600 NEGLEN: MOVEI ERROR,[ASCIZ/STRING DECLARATION - LENGTH $ < 0/]
22700 PUSHJ %P,%ERROR
22800 MOVE ERROR,SIZE
22900 PUSHJ %P,%ERRNM
23000 EXIT
23100
23200 %BLOCK: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
23300 MOVEM HEADER,%SAVE+HEADER
23400 HRRZ HEADER,JOBUUO ;GET DESCRIPTOR ADDRESS
23500 HLRZ SIZE,(HEADER) ;AND SIZE
23600 ADDI SIZE,1 ;ACCOUNT FOR HEADER
23700 PUSHJ %P,ALLOC ;ALLOCATE STORAGE FOR BLOCK
23800 EXCH RESULT,%B ;SET NEW BASE
23900 MOVEM RESULT,(%B) ;AND SAVE OLD ONE
24000 HRRZ TEMP,JOBUUO ;GET DISPLAY SIZE
24100 HLRZ TEMP,-1(TEMP)
24200 JUMPE TEMP,%XUUO ;NO DISPLAY
24300 SOJG TEMP,.+3
24400 MOVEM RESULT,3(%B) ;CALLER LEVEL ONLY
24500 JRST %XUUO
24600 MOVEI TEMP2,3(%B) ;OTHER LEVELS TOO, MOVE THEM
24700 HRLI TEMP2,3(RESULT) ; FROM CALLER'S DISPLAY
24800 ADDI TEMP,2(%B)
24900 BLT TEMP2,(TEMP)
25000 MOVEM RESULT,1(TEMP) ;ALSO CALLER LEVEL
25100 JRST %XUUO ;EXIT
25200
25300 %THUNK: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
25400 MOVEM HEADER,%SAVE+HEADER
25500 HRRZ HEADER,JOBUUO ;GET DESCRIPTOR ADDRESS
25600 HLRZ SIZE,(HEADER) ;AND SIZE
25700 ADDI SIZE,1 ;ACCOUNT FOR HEADER
25800 PUSHJ %P,ALLOC ;ALLOCATE STORAGE FOR THUNK
25900 EXCH RESULT,%B ;SET NEW BASE
26000 MOVEM RESULT,(%B) ;AND SAVE OLD ONE
26100 MOVE %T,%HDBLK+3 ;RESTORE THUNK BASE SAVED BY %UUOTB
26200 POP %P,1(%B) ;SAVE THUNK RETURN ADDRESS
26300 HRRZ TEMP,JOBUUO ;GET DISPLAY SIZE
26400 HLRZ TEMP,-1(TEMP)
26500 SOJG TEMP,.+3
26600 MOVEM %T,3(%B) ;THUNK IMMEDIATE CONTEXT ONLY
26700 JRST %XUUO
26800 MOVEI TEMP2,3(%B) ;OTHER LEVELS, MOVE THEM
26900 HRLI TEMP2,3(%T) ; FROM THUNK IMMEDIATE CONTEXT DISPLAY
27000 ADDI TEMP,2(%B)
27100 BLT TEMP2,(TEMP)
27200 MOVEM %T,1(TEMP) ;ALSO THUNK IMMEDIATE CONTEXT
27300 JRST %XUUO ;EXIT
27400
27500 %PROC: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
27600 MOVEM HEADER,%SAVE+HEADER
27700 HRRZ HEADER,JOBUUO ;GET DESCRIPTOR ADDRESS
27800 HLRZ SIZE,(HEADER) ;AND SIZE
27900 ADDI SIZE,1 ;ACCOUNT FOR HEADER
28000 PUSHJ %P,ALLOC ;ALLOCATE STORAGE
28100 EXCH RESULT,%B ;SET NEW BASE
28200 MOVEM RESULT,(%B) ;AND SAVE OLD ONE
28300 POP %P,1(%B) ;SAVE PROCEDURE RETURN ADDRESS
28400 POP %P,2(%B) ;AND ARGUMENT LIST POINTER
28500 HRRZ TEMP,JOBUUO ;GET DISPLAY SIZE
28600 HLRZ TEMP2,-1(TEMP)
28700 JUMPE TEMP2,CHKARG ;NO DISPLAY
28800 HLRZ TEMP3,-1(RESULT)
28900 HLRZ TEMP3,-1(TEMP3) ;GET PREVIOUS DISPLAY SIZE
29000 CAIL TEMP3,(TEMP2)
29100 JRST .+4 ;IF NOT EXPANDING, JUST COPY
29200 ADDI TEMP3,3(%B)
29300 MOVEM RESULT,(TEMP3) ;ELSE ADD PREVIOUS LEVEL POINTER
29400 SOJE TEMP2,CHKARG ;IF ANY ROOM LEFT, COPY STUFF
29500 MOVEI TEMP3,3(%B) ;OTHER LEVELS, MOVE THEM
29600 HRLI TEMP3,3(RESULT) ; FROM CALLER'S DISPLAY
29700 ADDI TEMP2,2(%B)
29800 BLT TEMP3,(TEMP2)
29900
30000 CHKARG: HLRZ TEMP,-2(TEMP) ;GET ADDRESS OF ARGUMENT TYPES
30100 JUMPE TEMP,%XUUO ;IF ZERO, DON'T BOTHER CHECKING
30200 MOVE TEMP2,2(%B) ;GET ARGUMENT LIST POINTER
30300 JUMPGE TEMP2,%XUUO ;IF NOT NEGATIVE, NO CHECKING
30400 HRLI TEMP,(POINT ^D9,0) ;MAKE BYTE POINTER TO TYPES
30500 HLRZ ARGCNT,TEMP2 ;GET ARGUMENT COUNT
30600 LSH ARGCNT,-5
30700 ANDI ARGCNT,17
30800
30900 CHKLP: ILDB ARGTYP,TEMP ;GET EXPECTED ARGUMENT TYPE
31000 SOJL ARGCNT,CHKEND ;IS PROCEDURE VALUE TYPE
31100 TRNE ARGTYP,400 ;EXPECT PROCEDURE VALUE TYPE
31200 JRST CNTERR ;NO MATCH, MISMATCHED COUNT
31300 HLRZ TEMP3,(TEMP2) ;GET PROVIDED TYPE
31400 LSH TEMP3,-^D9
31500 ADDI TEMP2,4 ;POINT TO NEXT ARGUMENT TYPE
31600 CAIN ARGTYP,(TEMP3) ;COMPARE TYPES
31700 JRST CHKLP ;OK, TRY NEXT
31800 MOVEI ERROR,[ASCIZ/IMPROPER TYPE ARGUMENT SUPPLIED TO PROCEDURE/]
31900 PUSHJ %P,%ERROR
32000 EXIT
32100
32200 CHKEND: TRNN ARGTYP,400 ;PROCEDURE VALUE TYPE EXPECTED
32300 JRST CNTERR
32400 HLRZ TEMP2,TEMP2 ;GET PROCEDURE VALUE TYPE EXPECTED
32500 LSH TEMP2,-^D9
32600 CAIN ARGTYP,(TEMP2) ;COMPARE TYPES
32700 JRST %XUUO ;OK, DONE
32800 MOVEI ERROR,[ASCIZ/IMPROPER TYPE PROCEDURE VALUE EXPECTED/]
32900 PUSHJ %P,%ERROR
33000 EXIT
33100
33200 CNTERR: MOVEI ERROR,[ASCIZ/IMPROPER NUMBER OF ARGUMENTS SUPPLIED TO PROCEDURE/]
33300 PUSHJ %P,%ERROR
33400 EXIT
00100 PRGEND
00200 TITLE %COLLE -- ALGOLW GARBAGE COLLECTOR -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %COLLE
00500 EXTERN %SREG,%LREG,%NREG,%ALREG,%ANREG,%AVIOB
00600 EXTERN %HDBLK,%MARK,%STAT,%DYNAM
00700 %TB= 15
00800 %B= 16
00900 %P= 17
01000 DIMCNT= 6
01100 TEMP= 7
01200 REGPT= 10
01300 HEADER= 11
01400 VCOUNT= 12
01500 SIZE= 12
01600 VPOINT= 13
01700 AREGPT= 13
01800 FREED= 13
01900 POINTR= 14
02000
02100 %COLLE: PUSH %P,TEMP ;SAVE TEMP
02200 PUSH %P,DIMCNT ; AND DIMCNT
02300 AOS %STAT+4 ;INCREMENT CALL COUNT
02400 MOVEI TEMP,0
02500 RUNTIM TEMP, ;FIND RUNTIM
02600 SUBM TEMP,%STAT+1 ;GET DIFFERENCE
02700 EXCH TEMP,%STAT+1
02800 ADDM TEMP,%STAT+17 ;TOTAL RUNTIM BETWEEN CALLS
02900 CAMLE TEMP,%STAT+20
03000 MOVEM TEMP,%STAT+20 ;MAX RUNTIM BETWEEN CALLS
03100 MOVE TEMP,%STAT+25
03200 SETZM %STAT+25 ;RESET REQUESTS SINCE LAST COLLE
03300 CAMLE TEMP,%STAT+26 ;MAX REQUESTS SINCE LAST COLLE
03400 MOVEM TEMP,%STAT+26
03500 ADD TEMP,%STAT+27 ;CUMULATIVE AVERAGE OF
03600 LSH TEMP,-1 ; REQUESTS SINCE LAST COLLE
03700 MOVEM TEMP,%STAT+27
03800 SETZM %STAT+30 ;RESET ALLOC COUNT SINCE LAST COLLE
03900 HRRZM %TB,%HDBLK+1 ;SET %TB AND %B IN %HDBLK FOR
04000 HRRZM %B,%HDBLK+2 ; POINTERS INTO THE LIST STRUCTURE
04100 PUSHJ %P,%MARK ;MARK ALL ACCESSABLE LIST NODES
04200 MOVEI REGPT,0
04300
04400 INITA: MOVE TEMP,%NREG(REGPT) ;INITIALIZE %ALREG AND %ANREG
04500 SUB TEMP,%SREG(REGPT) ;TO REGION LENGTH AND
04600 ADD TEMP,%LREG(REGPT) ;START RESPECTIVELY
04700 MOVEM TEMP,%ALREG(REGPT)
04800 MOVE TEMP,%SREG(REGPT)
04900 MOVEM TEMP,%ANREG(REGPT)
05000 CAMGE REGPT,%AVIOB ;SET NEXT REGION
05100 AOJA REGPT,INITA
05200 MOVEI REGPT,0 ;SETUP FOR STORAGE REALLOCATION
05300 HRROI TEMP,400000 ;MASK
05400
05500 ALLREG: MOVE HEADER,%SREG(REGPT) ;GET START OF REGION
05600
05700 NXTCEL: CAML HEADER,%NREG(REGPT) ;END OF REGION?
05800 JRST NXTREG
05900 MOVS SIZE,(HEADER) ;GET BLOCK HEADER
06000 TLZN SIZE,400000 ;SEE IF THIS IS SIZE
06100 HLR SIZE,(SIZE)
06200 TRZ SIZE,400000 ;KILL TYPE BIT
06300 ADDI SIZE,1
06400 TLZN SIZE,377777 ;IF NOT MARKED, SKIP IT
06500 JRST ADVCEL
06600 MOVEI AREGPT,0 ;LOOK FOR REGION IT CAN FIT INTO
06700 CAMLE SIZE,%ALREG(AREGPT)
06800 AOJA AREGPT,.-1 ;MUST FIND ONE
06900 MOVE POINTR,%ANREG(AREGPT) ;GET NEW ADDRESS
07000 MOVN SIZE,SIZE ;ADJUST AVAILABLE LENGTH
07100 ADDM SIZE,%ALREG(AREGPT)
07200 MOVN SIZE,SIZE
07300 ADDM SIZE,%ANREG(AREGPT) ;AND AVAILABLE LOCATION
07400 ANDM TEMP,(HEADER) ;STORE IT
07500 ORM POINTR,(HEADER)
07600 ADVCEL: ADDI HEADER,(SIZE) ;TRY NEXT BLOCK
07700 JRST NXTCEL
07800
07900 NXTREG: CAMGE REGPT,%AVIOB ;TRY NEXT REGION
08000 AOJA REGPT,ALLREG
08100
08200 MOVEI REGPT,0 ;SETUP FOR REASSIGNMENT OF ADDR
08300
08400 REASNR: MOVE HEADER,%SREG(REGPT) ;GET START OF REGION
08500
08600 REASNB: CAML HEADER,%NREG(REGPT) ;IS END OF REGION
08700 JRST ASNREG
08800 MOVS VCOUNT,(HEADER) ;GET BLOCK HEADER
08900 TLZN VCOUNT,377777 ;IF NOT MARKED, SKIP IT
09000 JRST NXTBLK
09100 TLZN VCOUNT,400000 ;IF RECORD, PROCESS
09200 JRST RECORD
09300 TRZN VCOUNT,400000 ;IF NON-REFERENCE, SKIP IT
09400 JRST NXTBLK
09500 MOVEI VPOINT,1(HEADER);SET UP TO SCAN POINTERS
09600
09700 REASRV: SOJL VCOUNT,NXTBLK ;CONTINUE WHILE SIZE>0
09800 HRRE POINTR,(VPOINT) ;DON'T CHANGE POINTERS TO HISEG
09900 JUMPLE POINTR,REASNV
10000 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
10100 JRST REASNV
10200 MOVE TEMP,-1(POINTR)
10300 ANDI TEMP,377777
10400 ADDI TEMP,1
10500 HRRM TEMP,(VPOINT) ;CHANGE POINTER
10600 REASNV: AOJA VPOINT,REASRV ;TRY NEXT
10700
10800 RECORD: MOVEI VPOINT,1(HEADER);SET UP FOR RECORD ADJUSTING
10900 HLLZ TEMP,1(VCOUNT) ;IF REFERENCE VALUES,
11000 JUMPE TEMP,NOREFV
11100 SUB VPOINT,TEMP ;SET UP AOBJN AC
11200
11300 RECRVL: HRRE POINTR,(VPOINT) ;DON'T CHANGE POINTERS TO HISEG
11400 JUMPLE POINTR,RECRVN
11500 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
11600 JRST RECRVN
11700 MOVE TEMP,-1(POINTR)
11800 ANDI TEMP,377777
11900 ADDI TEMP,1
12000 HRRM TEMP,(VPOINT) ;CHANGE POINTER
12100 RECRVN: AOBJN VPOINT,RECRVL ;TRY NEXT
12200
12300 NOREFV: HRRZ DIMCNT,1(VCOUNT);GET NUMBER OF DV'S
12400 HRLI VCOUNT,(POINT 4,0)
12500 ADDI VCOUNT,2 ;MAKE VCOUNT INTO BYTE POINTER
12600
12700 ARRYDV: SOJL DIMCNT,NXTBLK ;DONE WHEN NO MORE DV'S
12800 ILDB TEMP,VCOUNT ;GET DIMENSION SIZE
12900 IMULI TEMP,3
13000 HRRE POINTR,1(VPOINT);DON'T CHANGE ANY POINTERS TO HISEG
13100 JUMPLE POINTR,ARRYND
13200 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
13300 JRST ARRYND
13400 MOVE POINTR,-1(POINTR)
13500 ANDI POINTR,377777
13600 ADDI POINTR,1
13700 HRRM POINTR,1(VPOINT);CHANGE POINTER
13800 ARRYND: ADDI VPOINT,2(TEMP) ;AND TRY NEXT
13900 JRST ARRYDV
14000
14100 NXTBLK: MOVS SIZE,(HEADER) ;SKIP TO NEXT BLOCK
14200 TLNN SIZE,400000 ;SEE IF THIS IS SIZE
14300 HLR SIZE,(SIZE)
14400 ANDI SIZE,377777 ;TRIM OFF CONTROL BITS
14500 ADDI HEADER,1(SIZE)
14600 JRST REASNB
14700
14800 ASNREG: CAMGE REGPT,%AVIOB ;PROCESSED ALL REGIONS?
14900 AOJA REGPT,REASNR
15000
15100 HLRZ SIZE,%HDBLK ;ADJUST %HDBLK POINTERS
15200 ANDI SIZE,377777 ;SETUP AOBJN POINTER
15300 MOVN SIZE,SIZE
15400 HRLZI SIZE,(SIZE)
15500 HRRI SIZE,%HDBLK+1
15600 HDBLKL: HRRE TEMP,(SIZE) ;ADJUST POINTER
15700 JUMPLE TEMP,.+7 ;IF NOT POINTING TO HISEG
15800 CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
15900 JRST .+5
16000 HRRZ TEMP,-1(TEMP)
16100 ANDI TEMP,377777 ;GET RID OF CONTROL BIT
16200 ADDI TEMP,1
16300 HRRM TEMP,(SIZE) ;AND STORE NEW POINTER
16400 AOBJN SIZE,HDBLKL ;GO FOR NEXT
16500
16600 HRRE TEMP,%TB ;ADJUST %TB
16700 JUMPLE TEMP,.+6 ;IF NOT POINTING TO HISEG
16800 CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
16900 JRST .+4
17000 HRR %TB,-1(%TB)
17100 TRZ %TB,400000 ;CLEAR CONTROL BIT
17200 ADDI %TB,1
17300
17400 HRRE TEMP,%B ;ADJUST %B
17500 JUMPLE TEMP,.+6 ;IF NOT POINTING TO HISEG
17600 CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
17700 JRST .+4
17800 HRR %B,-1(%B)
17900 TRZ %B,400000 ;CLEAR CONTROL BIT
18000 ADDI %B,1
18100
18200 MOVEI REGPT,0 ;SETUP FOR MOVE OF BLOCKS
18300 MOVEI FREED,0 ;HOW MUCH WAS FREED BY COLLECTING?
18400
18500 MOVENR: MOVE HEADER,%SREG(REGPT) ;START OF REGION
18600 HRROI TEMP,400000 ;GET MASK TO UNMARK BLOCKS
18700
18800 MOVENB: CAML HEADER,%NREG(REGPT) ;IS END OF REGION?
18900 JRST MOVEAR
19000 MOVE POINTR,(HEADER) ;GET NEW ADDRESS
19100 ANDI POINTR,377777
19200 JUMPE POINTR,MOVEAB ;IF ZERO, IGNORE
19300 ANDM TEMP,(HEADER) ;UNMARK BLOCK
19400 CAIL POINTR,(HEADER) ;DON'T MOVE IF IN SAME PLACE
19500 JRST MOVEAB
19600 HRLI POINTR,(HEADER) ;SET BLT SOURCE
19700 MOVS SIZE,(HEADER) ;GET BLOCK DESCRIPTOR
19800 TLNN SIZE,400000 ;SEE IF THIS IS SIZE
19900 HLR SIZE,(SIZE)
20000 ANDI SIZE,377777 ;CLEAR CONTROL BITS
20100 ADDI HEADER,1(SIZE) ;ADVANCE TO NEXT BLOCK
20200 ADDI SIZE,(POINTR) ;SET BLT END DESTINATION
20300 BLT POINTR,(SIZE) ;MOVE BLOCK
20400 JRST MOVENB ;TRY NEXT ONE
20500
20600 MOVEAB: MOVS SIZE,(HEADER) ;GET BLOCK DESCRIPTOR
20700 TLNN SIZE,400000 ;SEE IF THIS IS SIZE
20800 HLR SIZE,(SIZE)
20900 ANDI SIZE,377777 ;CLEAR CONTROL BITS
21000 ADDI HEADER,1(SIZE) ;ADVANCE TO NEXT BLOCK
21100 JRST MOVENB
21200
21300 MOVEAR: ADD FREED,%ALREG(REGPT) ;FREED STORAGE IN EACH REGION
21400 SUB FREED,%LREG(REGPT)
21500 MOVE TEMP,%ALREG(REGPT) ;SET NEW %LREG
21600 MOVEM TEMP,%LREG(REGPT)
21700 MOVE TEMP,%ANREG(REGPT) ;AND NEW %NREG
21800 MOVEM TEMP,%NREG(REGPT)
21900 CAMGE REGPT,%AVIOB ;ANY MORE REGIONS?
22000 AOJA REGPT,MOVENR
22100
22200 ADDM FREED,%STAT+14 ;TOTAL FREED STORAGE
22300 CAMLE FREED,%STAT+15
22400 MOVEM FREED,%STAT+15 ;MAX FREED STORAGE
22500 ADD FREED,%STAT+16
22600 LSH FREED,-1 ;CUMULATIVE AVERAGE
22700 MOVEM FREED,%STAT+16 ; OF FREED STORAGE
22800 MOVEI TEMP,0
22900 RUNTIM TEMP, ;FIND RUNTIM
23000 SUBM TEMP,%STAT+1 ;GET DIFFERENCE
23100 EXCH TEMP,%STAT+1
23200 ADDM TEMP,%STAT+21 ;TOTAL RUNTIM IN COLLE
23300 CAMLE TEMP,%STAT+22
23400 MOVEM TEMP,%STAT+22 ;MAX RUNTIM IN COLLE
23500 POP %P,DIMCNT
23600 POP %P,TEMP ;RESTORE TEMP AND DIMCNT
23700 POPJ %P, ;DONE, EXIT
00100 PRGEND
00200 TITLE %MARK -- ALGOLW LIST CELL MARKER -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %MARK
00500 EXTERN %HDBLK,%DYNAM
00600 %P= 17
00700 DIMCNT= 6
00800 TEMP= 7
00900 TOP= 10
01000 HEADER= 11
01100 VCOUNT= 12
01200 VPOINT= 13
01300 POINTR= 14
01400
01500 %MARK: PUSH %P,TEMP ;SAVE TEMP
01600 PUSH %P,DIMCNT ;AND DIMCNT
01700 MOVEI TOP,%HDBLK+1 ;INITIALIZE PUSH DOWN LIST
01800
01900 POPSTK: MOVEI HEADER,(TOP) ;POP TOP ENTRY
02000 CAIN HEADER,1
02100 JRST MARKEX ;ONE MEANS DONE (RH OF %HDBLK)
02200 HRRZ TOP,-1(TOP)
02300 ANDI TOP,377777
02400 MOVS VCOUNT,-1(HEADER) ;GET BLOCK HEADER
02500 TLNN VCOUNT,400000 ;SEE IF RECORD
02600 JRST RECORD
02700 TRNN VCOUNT,400000 ;IF NON-REFERENCE ARRAY, TRY NEXT
02800 JRST POPSTK
02900 MOVEI VPOINT,(HEADER) ;SET UP FOR SCAN OF VALUES
03000 ANDI VCOUNT,377777
03100
03200 MARKRV: SOJL VCOUNT,POPSTK ;CONTINUE WHILE SIZE>0
03300 HRRE POINTR,(VPOINT) ;DON'T MARK ANY POINTERS TO HISEG
03400 JUMPLE POINTR,MARKNV
03500 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
03600 JRST MARKNV
03700 MOVE TEMP,-1(POINTR)
03800 TRNE TEMP,377777 ;IS IT MARKED ALREADY
03900 JRST MARKNV
04000 ORM TOP,-1(POINTR)
04100 MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
04200 MARKNV: AOJA VPOINT,MARKRV ;TRY NEXT
04300
04400 RECORD: MOVEI VPOINT,(HEADER) ;SET UP FOR RECORD MARKING
04500 HLLZ TEMP,1(VCOUNT) ;IF REFERENCE VALUES,
04600 JUMPE TEMP,NOREFV ; SET UP AOBJN AC
04700 SUB VPOINT,TEMP
04800
04900 RECRFV: HRRE POINTR,(VPOINT) ;DON'T MARK ANY POINTERS TO HISEG
05000 JUMPLE POINTR,RECRNV
05100 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
05200 JRST RECRNV
05300 MOVE TEMP,-1(POINTR) ;IS IT MARKED ALREADY
05400 TRNE TEMP,377777
05500 JRST RECRNV
05600 ORM TOP,-1(POINTR)
05700 MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
05800 RECRNV: AOBJN VPOINT,RECRFV ;AND TRY NEXT
05900
06000 NOREFV: HRRZ DIMCNT,1(VCOUNT) ;GET NUMBER OF DV'S
06100 HRLI VCOUNT,(POINT 4,0)
06200 ADDI VCOUNT,2 ;MAKE VCOUNT INTO BYTE POINTER
06300
06400 ARRYDV: SOJL DIMCNT,POPSTK ;DONE WHEN NO MORE DV'S
06500 ILDB TEMP,VCOUNT ;GET DIMENSION SIZE
06600 IMULI TEMP,3
06700 HRRE POINTR,1(VPOINT);DON'T MARK ANY POINTERS TO HISEG
06800 JUMPLE POINTR,ARRYND
06900 CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
07000 JRST ARRYND
07100 HRL TEMP,-1(POINTR) ;SEE IF ALREADY MARKED
07200 TLNE TEMP,377777
07300 JRST ARRYND
07400 ORM TOP,-1(POINTR)
07500 MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
07600 ARRYND: ADDI VPOINT,2(TEMP) ;AND TRY NEXT
07700 JRST ARRYDV
07800
07900 MARKEX: POP %P,DIMCNT
08000 POP %P,TEMP ;DONE, RESTORE TEMP AND DIMCNT
08100 POPJ %P, ;EXIT
00100 PRGEND
00200 TITLE %ERROR -- ALGOLW ERROR MESSAGE EDITOR -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %ERROR,%ERRNM,%ERROC,%ERRSB,%USRER,%ERRST
00500 EXTERN %ERRPT,%UUO,%DCSAV,%XUUO,JOBUUO
00600 %B= 16
00700 %P= 17
00800 BASE= 10
00900 LINENO= 11
01000 HEADER= 12
01100 WORK= 13
01200 ERROR= 14
01300 LENGTH= 10
01400 CHAR= 11
01500 BYTEPT= 12
01600 LNEADR= 12
01700
01800 %ERROR: TTCALL 3,[BYTE (7) 015,012,0]
01900 HRLI ERROR,(POINT 7,0) ;MAKE BYTE POINTER
02000 MOVEM ERROR,%ERRPT ;AND SAVE IT
02100
02200 ERRPRT: ILDB ERROR,%ERRPT ;PRINT MESSAGE, EXIT ON "$"
02300 CAIN ERROR,"$"
02400 POPJ %P,
02500 JUMPE ERROR,ENDSTR ;END OF MESSAGE
02600 TTCALL 1,ERROR
02700 JRST ERRPRT ;PRINT IT AND GET NEXT
02800
02900 %ERRNM: PUSH %P,WORK ;PRINT NUMBER
03000 PUSHJ %P,PRTNUM
03100 POP %P,WORK ;USE ONLY ERROR
03200 JRST ERRPRT
03300
03400 %ERROC: PUSH %P,WORK ;PRINT OCTAL NUMBER
03500 PUSHJ %P,PRTOCT
03600 POP %P,WORK ;USE ONLY ERROR
03700 JRST ERRPRT
03800
03900 PRTOCT: MOVE WORK,ERROR
04000 IDIVI WORK,^D8 ;USUAL RECURSIVE EDITOR
04100 JUMPE WORK,.+4 ;ALWAYS PRINT ONE DIGIT
04200 HRLM ERROR,(%P)
04300 PUSHJ %P,PRTOCT+1 ;SAVE DIGITS IN STACK
04400 HLRZ ERROR,(%P)
04500 ADDI ERROR,"0" ;MAKE ASCII
04600 TTCALL 1,ERROR
04700 POPJ %P, ;OUTPUT AND RETURN
04800
04900 PRTNUM: JUMPGE ERROR,.+2 ;DECIMAL EDITOR, CHECK SIGN
05000 TTCALL 1,["-"]
05100 MOVM WORK,ERROR ;USUAL RECURSIVE ONE
05200 IDIVI WORK,^D10
05300 JUMPE WORK,.+4 ;ALWAYS PRINT ONE DIGIT
05400 HRLM ERROR,(%P)
05500 PUSHJ %P,PRTNUM+3 ;SAVE DIGITS IN STACK
05600 HLRZ ERROR,(%P)
05700 ADDI ERROR,"0" ;MAKE ASCII
05800 TTCALL 1,ERROR
05900 POPJ %P, ;OUTPUT AND RETURN
06000
06100 %ERRSB: PUSH %P,WORK ;PRINT SIXBIT WORD
06200 JUMPN ERROR,.+3 ;NOTHING IF ZERO
06300 POP %P,WORK
06400 JRST ERRPRT
06500 MOVEI WORK,1 ;HIGH ORDER BIT
06600 LSHC WORK,6 ;NEXT SIX BITS
06700 TRC WORK,40 ;MAKE ASCII
06800 TTCALL 1,WORK
06900 JRST %ERRSB+1 ;OUTPUT, TRY NEXT
07000
07100 %ERRST: TTCALL 3,(ERROR) ;ASCIZ STRING
07200 JRST ERRPRT
07300
07400 %USRER: TTCALL 3,[BYTE (7) 015,012,0]
07500 HRRZ ERROR,JOBUUO ;USER CALL - STRING DV
07600 MOVE BYTEPT,(ERROR)
07700 HLRZ LENGTH,1(ERROR) ;GET BYTE POINTER AND LENGTH
07800 HRRZ WORK,1(ERROR)
07900 ADDI BYTEPT,(WORK) ;GET ACTUAL ADDRESS
08000 JUMPE LENGTH,.+5 ;NO MESSAGE IF NULL
08100 ILDB CHAR,BYTEPT
08200 TTCALL 1,CHAR ;OUTPUT CHARACTER
08300 SOJG LENGTH,.-2 ;GET NEXT
08400 TTCALL 3,[BYTE (7) 015,012,0]
08500 PUSHJ %P,ENDSTR+1 ;CALL TRACEBACK STUFF
08600 EXIT ;NO RETURN TO USER
08700
08800 ENDSTR: TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
08900 SKIPN ERROR,%DCSAV
09000 MOVE ERROR,%UUO ;FIND POINT OF CALL
09100 JUMPE %B,NOBASE ;ERROR IN RESET OR ALLOC
09200 MOVE BASE,%B
09300 TTCALL 3,[ASCIZ/?ERROR OCCURRED IN /]
09400 TRACE: HLRZ HEADER,-1(BASE) ;GET DESCRIPTOR INFO
09500 HRRZ WORK,-1(HEADER) ;LIKE PROCEDURE NAME
09600 TTCALL 3,(WORK)
09700 HRRZ WORK,-2(HEADER) ;SEE IF LINE NUMBER TABLE
09800 JUMPN WORK,EDTLNE
09900 NOLINE: TTCALL 3,[ASCIZ/ AT LOCATION /]
10000 SUBI ERROR,1
10100 ANDI ERROR,777777 ;EDIT ABSOLUTE ADDRESS
10200 PUSHJ %P,PRTOCT
10300 JRST ENDERL ;LOOK FOR CALLER
10400 EDTLNE: HRLI WORK,(POINT ^D18,0)
10500 MOVEI LINENO,1 ;SET UP FOR SEARCH OF TABLE
10600 ILDB LNEADR,WORK ;FIND FIRST LINE
10700 CAIL LNEADR,140
10800 JRST .+3
10900 ADDI LINENO,(LNEADR) ;NOT ADDRESS, LINE INCREMENT
11000 JRST .-4
11100 CAILE LNEADR,-1(ERROR) ;ADDRESS IN TABLE
11200 JRST NOLINE
11300 LOOKLP: ILDB LNEADR,WORK ;SEARCH FOR MATCH
11400 JUMPE LNEADR,NOLINE ;END OF TABLE
11500 CAIL LNEADR,140
11600 JRST .+3
11700 ADDI LINENO,(LNEADR) ;NOT ADDRESS, LINE INCREMENT
11800 JRST LOOKLP
11900 CAIG LNEADR,-1(ERROR)
12000 AOJA LINENO,LOOKLP ;NO MATCH, INCREMENT LINE NO
12100 TTCALL 3,[ASCIZ/ IN LINE /]
12200 MOVE ERROR,LINENO
12300 PUSHJ %P,PRTNUM ;EDIT LINE NUMBER
12400 ENDERL: TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
12500 NXTLVL: MOVE ERROR,1(BASE) ;GET CALLER
12600 MOVE BASE,(BASE) ;AND HIS BASE
12700 JUMPE BASE,EREXIT ;NONE, THEN DONE
12800 JUMPE ERROR,NXTLVL ;NO CALLER, TRY NEXT LEVEL
12900 TTCALL 3,[ASCIZ/CALLED FROM /]
13000 JRST TRACE ;EDIT STUFF
13100
13200 NOBASE: TTCALL 3,[ASCIZ/?ERROR OCCURRED AT LOCATION /]
13300 SUBI ERROR,1
13400 ANDI ERROR,777777
13500 PUSHJ %P,PRTOCT ;EDIT ABSOLUTE ADDRESS
13600 TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
13700
13800 EREXIT: POPJ %P, ;RETURN TO USER
00100 PRGEND
00200 TITLE %ARITH -- ALGOLW ARITHMETIC ROUTINES -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %DADD,%DSUB,%DMULT,%DDIV,%CMULT,%CDIV,%DCMUL,%DCDIV
00500 ENTRY %FIX,%FLOAT,%DFIX,%DFLOT
00600 EXTERN JOBUUO,%XUUO,%SAVE,%UUO,%DCSAV,%HDBLK
00700 %P= 17
00800 T= 7
00900 A= 10
01000 MBASE= 13
01100 ACBASE= 12
01200 RESULT= 14
01300 AC0= 0
01400 AC1= 2
01500 AC2= 4
01600 ACAC= 6
01700 MAC= 7
01800 OPDEF DADD [BYTE (9) 15]
01900 OPDEF DSUB [BYTE (9) 16]
02000 OPDEF DMUL [BYTE (9) 17]
02100 OPDEF DDIV [BYTE (9) 20]
02200
02300 %DADD: LDB ACBASE,[POINT 4,JOBUUO,^D12]
02400 TRZN ACBASE,1 ;SET AC, DESTINATION
02500 SKIPA RESULT,ACBASE
02600 HRRZ RESULT,JOBUUO ;AC OR MEMORY
02700 MOVE A,(ACBASE)
02800 MOVE A+1,1(ACBASE) ;SETUP
02900 HRRZ MBASE,JOBUUO
03000 UFA A+1,1(MBASE) ;TAKEN FROM PDP-10 HANDBOOK
03100 FADL A,(MBASE)
03200 UFA A+1,A+2
03300 FADL A,A+2
03400 MOVEM A,(RESULT) ;STORE RESULT
03500 MOVEM A+1,1(RESULT)
03600 JRST %XUUO ;EXIT
03700
03800 %DSUB: LDB ACBASE,[POINT 4,JOBUUO,^D12]
03900 TRZN ACBASE,1 ;SET AC, DESTINATION
04000 SKIPA RESULT,ACBASE
04100 HRRZ RESULT,JOBUUO ;AC OR MEMORY
04200 MOVE A,(ACBASE)
04300 MOVE A+1,1(ACBASE) ;SETUP
04400 HRRZ MBASE,JOBUUO
04500 DFN A,A+1 ;NEGATE
04600 UFA A+1,1(MBASE) ;COPY OF ADD ROUTINE
04700 FADL A,(MBASE)
04800 UFA A+1,A+2
04900 FADL A,A+2
05000 DFN A,A+1 ;NEGATE ANSWER
05100 MOVEM A,(RESULT) ;STORE RESULT
05200 MOVEM A+1,1(RESULT)
05300 JRST %XUUO ;EXIT
05400
05500 %DMULT: LDB ACBASE,[POINT 4,JOBUUO,^D12]
05600 TRZN ACBASE,1 ;SET AC, DESTINATION
05700 SKIPA RESULT,ACBASE
05800 HRRZ RESULT,JOBUUO ;AC OR MEMORY
05900 MOVE A,(ACBASE)
06000 MOVE A+1,1(ACBASE) ;SETUP
06100 HRRZ MBASE,JOBUUO
06200 MOVEM A,A+2 ;ALSO TAKEN FROM PDP-10 HANDBOOK
06300 FMPR A+2,1(MBASE)
06400 FMPR A+1,(MBASE)
06500 UFA A+1,A+2
06600 FMPL A,(MBASE)
06700 UFA A+1,A+2
06800 FADL A,A+2
06900 MOVEM A,(RESULT) ;STORE RESULT
07000 MOVEM A+1,1(RESULT)
07100 JRST %XUUO ;EXIT
07200
07300 %DDIV: LDB ACBASE,[POINT 4,JOBUUO,^D12]
07400 TRZN ACBASE,1 ;SET AC, DESTINATION
07500 SKIPA RESULT,ACBASE
07600 HRRZ RESULT,JOBUUO ;AC OR MEMORY
07700 MOVE A,(ACBASE)
07800 MOVE A+1,1(ACBASE) ;SETUP
07900 HRRZ MBASE,JOBUUO
08000 FDVL A,(MBASE) ;TAKEN FROM PDP-10 HANDBOOK
08100 MOVN A+2,A
08200 FMPR A+2,1(MBASE)
08300 UFA A+1,A+2
08400 FDVR A+2,(MBASE)
08500 FADL A,A+2
08600 MOVEM A,(RESULT) ;STORE RESULT
08700 MOVEM A+1,1(RESULT)
08800 JRST %XUUO ;EXIT
08900
09000 %CMULT: LDB ACBASE,[POINT 4,JOBUUO,^D12]
09100 TRZN ACBASE,1 ;SET AC, DESTINATION
09200 SKIPA RESULT,ACBASE
09300 HRRZ RESULT,JOBUUO ;AC OR MEMORY
09400 HRRZ MBASE,JOBUUO
09500 MOVE A,(ACBASE) ;(A+BI)(C+DI)=
09600 FMPR A,(MBASE) ; (AC-BD)+(AD+BC)I
09700 MOVE A+1,1(ACBASE)
09800 FMPR A+1,1(MBASE)
09900 FSBR A,A+1
10000 MOVE A+1,(ACBASE)
10100 FMPR A+1,1(MBASE)
10200 MOVE A+2,1(ACBASE)
10300 FMPR A+2,(MBASE)
10400 FADR A+1,A+2
10500 MOVEM A,(RESULT) ;STORE RESULT
10600 MOVEM A+1,1(RESULT)
10700 JRST %XUUO ;EXIT
10800
10900 %CDIV: PUSH %P,T ;SAVE WORK REGISTER
11000 LDB ACBASE,[POINT 4,JOBUUO,^D12]
11100 TRZN ACBASE,1 ;AC OR MEMORY
11200 SKIPA RESULT,ACBASE
11300 HRRZ RESULT,JOBUUO
11400 HRRZ MBASE,JOBUUO
11500 MOVE T,(MBASE) ;(A+BI)/(C+DI)=
11600 FMPR T,T ; ((AC+BD)+(BC-AD)I)/(CC+DD)
11700 MOVE A,1(MBASE)
11800 FMPR A,A
11900 FADR T,A
12000 MOVE A,(ACBASE)
12100 FMPR A,(MBASE)
12200 MOVE A+1,1(ACBASE)
12300 FMPR A+1,1(MBASE)
12400 FADR A,A+1
12500 FDVR A,T
12600 MOVE A+1,1(ACBASE)
12700 FMPR A+1,(MBASE)
12800 MOVE A+2,(ACBASE)
12900 FMPR A+2,1(MBASE)
13000 FSBR A+1,A+2
13100 FDVR A+1,T
13200 POP %P,T
13300 MOVEM A,(RESULT) ;STORE RESULT
13400 MOVEM A+1,1(RESULT)
13500 JRST %XUUO
13600
13700 %DCMUL: MOVEI RESULT,%SAVE ;SAVE REGISTERS
13800 BLT RESULT,%SAVE+7
13900 MOVE RESULT,%UUO ;SETUP FOR RECURSIVE CALL ON %ARITH
14000 MOVEM RESULT,%DCSAV
14100 MOVE RESULT,%HDBLK+3
14200 LDB ACAC,[POINT 4,JOBUUO,^D12]
14300 TRZN ACAC,1 ;SET AC, DESTINATION
14400 SKIPA MAC,ACAC
14500 HRRZ MAC,JOBUUO ;AC OR MEMORY
14600 HRLI ACAC,(MAC) ;SAVE DESTINATION
14700 HRRZ MAC,JOBUUO
14800 CAIG MAC,17 ;MEMORY IS SAVED
14900 ADDI MAC,%SAVE
15000 MOVE AC0,%SAVE(ACAC) ;SAME AS %CMULT BUT DOUBLE PRECISION
15100 MOVE AC0+1,%SAVE+1(ACAC)
15200 DMUL AC0,(MAC)
15300 MOVE AC1,%SAVE+2(ACAC)
15400 MOVE AC1+1,%SAVE+3(ACAC)
15500 DMUL AC1,2(MAC)
15600 DSUB AC0,AC1
15700 MOVE AC1,%SAVE(ACAC)
15800 MOVE AC1+1,%SAVE+1(ACAC)
15900 DMUL AC1,2(MAC)
16000 MOVE AC2,(MAC)
16100 MOVE AC2+1,1(MAC)
16200 DMUL AC2,%SAVE+2(ACAC)
16300 DADD AC1,AC2
16400 HLRZ ACAC,ACAC ;STORE RESULT
16500 CAIG ACAC,17
16600 ADDI ACAC,%SAVE ;SAVED REGISTERS
16700 MOVEM AC0,(ACAC)
16800 MOVEM AC0+1,1(ACAC)
16900 MOVEM AC1,2(ACAC)
17000 MOVEM AC1+1,3(ACAC)
17100 MOVSI RESULT,%SAVE ;RESTORE REGISTERS
17200 BLT RESULT,7
17300 MOVE RESULT,%DCSAV
17400 MOVEM RESULT,%UUO ;UNDO RECURSION
17500 SETZM %DCSAV
17600 JRST %XUUO ;AND EXIT
17700
17800 %DCDIV: MOVEI RESULT,%SAVE ;SAVE REGISTERS
17900 BLT RESULT,%SAVE+7
18000 MOVE RESULT,%UUO ;SETUP FOR RECURSIVE CALL ON %ARITH
18100 MOVEM RESULT,%DCSAV
18200 MOVE RESULT,%HDBLK+3
18300 LDB ACAC,[POINT 4,JOBUUO,^D12]
18400 TRZN ACAC,1 ;SET AC, DESTINATION
18500 SKIPA MAC,ACAC
18600 HRRZ MAC,JOBUUO ;AC OR MEMORY
18700 HRLI ACAC,(MAC) ;SAVE DESTINATION
18800 HRRZ MAC,JOBUUO
18900 CAIG MAC,17 ;SAVED MEMORY
19000 ADDI MAC,%SAVE
19100 MOVE AC0,(MAC) ;SAME AS %CDIV BUT DOUBLE PRECISION
19200 MOVE AC0+1,1(MAC)
19300 DMUL AC0,AC0
19400 MOVE AC1,2(MAC)
19500 MOVE AC1+1,3(MAC)
19600 DMUL AC1,AC1
19700 DADD AC0,AC1
19800 PUSH %P,AC0 ;USE STACK AS TEMPORARY STORAGE
19900 PUSH %P,AC0+1
20000 MOVE AC0,%SAVE(ACAC)
20100 MOVE AC0+1,%SAVE+1(ACAC)
20200 DMUL AC0,(MAC)
20300 MOVE AC1,%SAVE+2(ACAC)
20400 MOVE AC1+1,%SAVE+3(ACAC)
20500 DMUL AC1,2(MAC)
20600 DADD AC0,AC1
20700 DDIV AC0,-1(%P)
20800 MOVE AC1,%SAVE+2(ACAC)
20900 MOVE AC1+1,%SAVE+3(ACAC)
21000 DMUL AC1,(MAC)
21100 MOVE AC2,%SAVE(ACAC)
21200 MOVE AC2+1,%SAVE+1(ACAC)
21300 DMUL AC2,2(MAC)
21400 DSUB AC1,AC2
21500 DDIV AC1,-1(%P)
21600 SUB %P,[XWD 2,2] ;ADJUST STACK
21700 HLRZ ACAC,ACAC ;STORE RESULT
21800 CAIG ACAC,17 ;SAVED REGISTERS
21900 ADDI ACAC,%SAVE
22000 MOVEM AC0,(ACAC)
22100 MOVEM AC0+1,1(ACAC)
22200 MOVEM AC1,2(ACAC)
22300 MOVEM AC1+1,3(ACAC)
22400 MOVSI RESULT,%SAVE ;RESTORE REGISTERS
22500 BLT RESULT,7
22600 MOVE RESULT,%DCSAV ;UNDO RECURSION
22700 MOVEM RESULT,%UUO
22800 SETZM %DCSAV
22900 JRST %XUUO ;EXIT
23000
23100 %FIX: MOVM A+1,@JOBUUO ;GET MAGNITUDE OF NUMBER
23200 CAMG A+1,[200777777777] ;IS < 1.0
23300 JRST FIXZER ;ASSUME 0
23400 CAMLE A+1,[243777777777] ;IS TOO BIG
23500 JRST FIXOVF ;YES, FORCE OVERFLOW
23600 SETZ A,
23700 LSHC A,^D9 ;GET EXPONENT
23800 FIXSHL: LSH A+1,-244(A) ;ADJUST MANTISSA ACCORDINGLY
23900 FIXSTO: EXCH A+1,@JOBUUO ;STORE NUMBER
24000 JUMPGE A+1,%XUUO ;IF ORIGINAL WAS NEGATIVE,
24100 MOVNS @JOBUUO ; NEGATE ANSWER
24200 JRST %XUUO ;EXIT
24300 FIXZER: SETZM @JOBUUO ;FORCE ZERO ANSWER
24400 JRST %XUUO ;EXIT
24500 FIXOVF: MOVE A+1,[377777777777] ;FORCE OVERFLOW
24600 AOJA A+1,FIXSTO ;CONTINUE IF OVERFLOW IGNORED
24700
24800 %FLOAT: MOVM A,@JOBUUO ;GET MAGNITUDE OF NUMBER
24900 JUMPE A,%XUUO ;ZERO, QUIT
25000 IDIVI A,400000 ;BREAK NUMBER INTO TWO PARTS
25100 HRLI A+1,233000 ;SET EXPONENT
25200 JUMPE A,.+2 ;IF < 18 BITS, SECOND NUMBER IS ZERO
25300 HRLI A,254000
25400 FAD A+1,A ;USE FAD TO COMBINE AND NORMALIZE
25500 EXCH A+1,@JOBUUO ;STORE
25600 JUMPGE A+1,%XUUO ;IF ORIGINAL WAS NEGATIVE,
25700 MOVNS @JOBUUO ; NEGATE ANSWER
25800 JRST %XUUO ;EXIT
25900
26000 %DFIX: HRRZ MBASE,JOBUUO ;GET ADDRESS
26100 MOVM A+1,(MBASE) ;LOOK AT FIRST WORD
26200 CAMG A+1,[200777777777] ;IS < 1.0L
26300 JRST FIXZER ;ASSUME ZERO
26400 CAMLE A+1,[243777777777] ;IS TOO BIG
26500 JRST FIXOVF ;YES, FORCE OVERFLOW
26600 SKIPL (MBASE) ;GET MAGNITUDE OF SECOND WORD
26700 SKIPA A+2,1(MBASE)
26800 MOVN A+2,1(MBASE)
26900 HLRZ A+2,A+2 ;ONLY FIRST 9 BITS OF SECOND WORD
27000 ANDI A+2,777 ; ARE OF INTEREST
27100 SETZ A,
27200 LSHC A,^D9 ;GET EXPONENT
27300 ORI A+1,(A+2) ; AND EXTRA 9 BITS
27400 JRST FIXSHL ;CONTINUE AS FOR %FIX
27500
27600 %DFLOT: HRRZ MBASE,JOBUUO ;GET ADDRESS
27700 SETZM 1(MBASE) ;POSSIBLE ZERO RESULT
27800 MOVM A,(MBASE) ;GET MAGNITUDE
27900 JUMPE A,%XUUO ;DONE IF ZERO
28000 IDIVI A,400000 ;BREAK NUMBER INTO TWO PARTS
28100 HRLI A+1,233000 ;SET EXPONENT
28200 JUMPE A,.+2 ;IF < 18 BITS, SECOND NUMBER IS ZERO
28300 HRLI A,254000
28400 FADL A,A+1 ;USE LONG FORM HERE
28500 SKIPGE (MBASE) ;IF ORIGINAL WAS NEGATIVE,
28600 DFN A,A+1 ; NEGATE THE ANSWER
28700 MOVEM A,(MBASE) ;STORE RESULT
28800 MOVEM A+1,1(MBASE)
28900 JRST %XUUO ;EXIT
00100 PRGEND
00200 TITLE %STRNG -- ALGOLW STRING ROUTINES -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE
00500 ENTRY %IS,%SMOVE,%SUBST,%SUBSC
00600 ENTRY %STRIN,%BITIN,%INTBI,%INTST
00700 EXTERN JOBUUO,%XUUO,%UUO,%ERROR,%ERRNM
00800 %P= 17
00900 VALUE= 10
01000 DIGITS= 12
01100 SIGN= 13
01200 LEN1= 10
01300 BYTEP1= 11
01400 LEN2= 12
01500 BYTEP2= 13
01600 PAD= 11
01700 CHAR= 12
01800 TEMP= 14
01900 ERROR= 14
02000
02100 SETUP: LDB TEMP,[POINT 4,JOBUUO,^D12]
02200 TRZE TEMP,1 ;OPERANDS IN REVERSE ORDER?
02300 JRST SETUP2
02400 MOVE BYTEP1,(TEMP) ;GET STRING DV AT AC
02500 MOVE LEN1,1(TEMP)
02600 ADDI BYTEP1,(LEN1) ;MAKE BYTEPT ADDR ABSOLUTE
02700 HLRZ LEN1,LEN1 ;GET LENGTH FIELD
02800 HRRZ TEMP,JOBUUO
02900 MOVE BYTEP2,(TEMP) ;GET STRING DV AT ADDRESS
03000 MOVE LEN2,1(TEMP)
03100 ADDI BYTEP2,(LEN2) ;MAKE BYTEPT ADDR ABSOLUTE
03200 HLRZ LEN2,LEN2 ;GET LENGTH FIELD
03300 POPJ %P, ;RETURN
03400 SETUP2: MOVE BYTEP2,(TEMP) ;GET STRING DV AT AC
03500 MOVE LEN2,1(TEMP)
03600 ADDI BYTEP2,(LEN2) ;MAKE BYTEPT ADDR ABSOLUTE
03700 HLRZ LEN2,LEN2 ;GET LENGTH FIELD
03800 HRRZ TEMP,JOBUUO
03900 MOVE BYTEP1,(TEMP) ;GET STRING DV AT ADDRESS
04000 MOVE LEN1,1(TEMP)
04100 ADDI BYTEP1,(LEN1) ;MAKE BYTEPT ADDR ABSOLUTE
04200 HLRZ LEN1,LEN1 ;GET LENGTH FIELD
04300 POPJ %P, ;RETURN
04400
04500 %CSTE: PUSHJ %P,SETUP ;SETUP REGISTERS
04600 HRLI LEN1,(LEN2) ;PUT BOTH LENGTHS TOGETHER
04700 JUMPE LEN1,SUCCES ;NULL STRINGS ARE EQUAL
04800 CSTEL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
04900 JRST .+3
05000 SUBI LEN1,1 ;YEP, GET A CHARACTER
05100 JRST .+4
05200 HRRI BYTEP1,[XWD 200000,0]
05300 TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
05400 TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
05500 ILDB CHAR,BYTEP1
05600 TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
05700 JRST .+3
05800 SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
05900 JRST .+4
06000 HRRI BYTEP2,[XWD 200000,0]
06100 TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
06200 TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
06300 ILDB TEMP,BYTEP2
06400 CAIE CHAR,(TEMP) ;COMPARE BYTES
06500 JRST %XUUO ;NOT EQUAL
06600 JUMPN LEN1,CSTEL ;IF MORE, PROCESS THEM
06700 SUCCES: AOS %UUO ;SUCCES RETURN, SKIP
06800 JRST %XUUO
06900
07000 %CSTN: PUSHJ %P,SETUP ;SETUP REGISTERS
07100 HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
07200 JUMPE LEN1,%XUUO ;NULL STRINGS, FAIL
07300 CSTNL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
07400 JRST .+3
07500 SUBI LEN1,1 ;YEP, GET A BYTE
07600 JRST .+4
07700 HRRI BYTEP1,[XWD 200000,0]
07800 TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
07900 TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
08000 ILDB CHAR,BYTEP1
08100 TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
08200 JRST .+3
08300 SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
08400 JRST .+4
08500 HRRI BYTEP2,[XWD 200000,0]
08600 TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
08700 TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
08800 ILDB TEMP,BYTEP2
08900 CAIE CHAR,(TEMP) ;COMPARE
09000 JRST SUCCES ;NOT =, SUCCEED
09100 JUMPN LEN1,CSTNL ;=, CONTINUE COMPARE
09200 JRST %XUUO ;END OF STRING, FAIL
09300
09400 CSTL: PUSHJ %P,SETUP ;SETUP REGISTERS
09500 HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
09600 JUMPE LEN1,CSTEXT ;NULL STRINGS ARE EQUAL
09700 CSTLL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
09800 JRST .+3
09900 SUBI LEN1,1 ;YEP, GET A BYTE
10000 JRST .+4
10100 HRRI BYTEP1,[XWD 200000,0]
10200 TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
10300 TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
10400 ILDB CHAR,BYTEP1
10500 TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
10600 JRST .+3
10700 SUB LEN1,[XWD 1,0] ;YEP, GET A BYTE
10800 JRST .+4
10900 HRRI BYTEP2,[XWD 200000,0]
11000 TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
11100 TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
11200 ILDB TEMP,BYTEP2
11300 CAIE CHAR,(TEMP) ;COMPARE THEM
11400 JRST LSSNEQ ;NOT =, CHECK FURTHER
11500 JUMPN LEN1,CSTLL ;=, CONTINUE COMPARE
11600 CSTEXT: POPJ %P, ;RETURN
11700 LSSNEQ: CAIL CHAR,(TEMP) ;COMPARE NEQ CHARACTERS
11800 JRST PFAIL ;>, FAIL
11900 PSUCCE: POP %P,TEMP ;DISCARD RETURN
12000 AOS %UUO ;SKIP RETURN
12100 JRST %XUUO
12200 PFAIL: POP %P,TEMP ;DISCARD RETURN
12300 JRST %XUUO ;NON SKIP RETURN
12400
12500 %CSTL: PUSHJ %P,CSTL ;CALL LSS COMPARE
12600 JRST %XUUO ;IF =, FAIL
12700
12800 %CSTLE: PUSHJ %P,CSTL ;CALL LSS COMPARE
12900 JRST SUCCES ;IF =, SUCCEED
13000
13100 CSTG: PUSHJ %P,SETUP ;SETUP REGISTERS
13200 HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
13300 JUMPE LEN1,CSTEXT ;NULL STRINGS ARE EQUAL
13400 CSTGL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
13500 JRST .+3
13600 SUBI LEN1,1 ;YEP, GET A CHARACTER
13700 JRST .+4
13800 HRRI BYTEP1,[XWD 200000,0]
13900 TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
14000 TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
14100 ILDB CHAR,BYTEP1
14200 TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
14300 JRST .+3
14400 SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
14500 JRST .+4
14600 HRRI BYTEP2,[XWD 200000,0]
14700 TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
14800 TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
14900 ILDB TEMP,BYTEP2
15000 CAIE CHAR,(TEMP) ;COMPARE THEM
15100 JRST GTRNEQ ;NOT =, CHECK FURTHER
15200 JUMPN LEN1,CSTGL ;=, CONTINUE COMPARE
15300 POPJ %P, ;RETURN
15400 GTRNEQ: CAIG CHAR,(TEMP) ;COMPARE NEQ CHARACTERS
15500 JRST PFAIL ;<, FAIL
15600 JRST PSUCCE ;>, SUCCEED
15700
15800 %CSTG: PUSHJ %P,CSTG ;CALL GTR COMPARE
15900 JRST %XUUO ;IF =, FAIL
16000
16100 %CSTGE: PUSHJ %P,CSTG ;CALL GTR COMPARE
16200 JRST SUCCES ;IF =, SUCCEED
16300
16400 %SMOVE: PUSHJ %P,SETUP ;SETUP REGISTERS
16500 JUMPE LEN2,%XUUO ;NULL DESTINATION, DONE
16600 TLNE BYTEP1,007600 ;CHECK FOR SAME BYTE SIZE
16700 JRST SMOVET
16800 TLNE BYTEP2,007600 ;PERHAPS BOTH BITS
16900 JRST SMOVEP
17000 SMOVEL: JUMPE LEN1,.+3 ;NO MORE SOURCE, SUPPLY BLANKS
17100 ILDB TEMP,BYTEP1 ;ELSE GET SOURCE CHARACTER
17200 SOJA LEN1,.+2 ;ADJUST LENGTH
17300 MOVEI TEMP," "
17400 IDPB TEMP,BYTEP2 ;STORE CHARACTER
17500 SOJG LEN2,SMOVEL ;PROCESS NEXT
17600 JRST %XUUO ;DONE
17700 SMOVET: TLNE BYTEP2,007600 ;FIRST NOT BITS
17800 JRST SMOVEL ;SECOND NOT BITS EITHER
17900 SMOVEU: JUMPE LEN1,.+3 ;NO MORE SOURCE IN
18000 ILDB TEMP,BYTEP1 ; STRING TO BITS MOVE
18100 SOJA LEN1,.+2 ;ADJUST LENGTH
18200 MOVEI TEMP," " ;PAD OUT SOURCE WITH BLANKS
18300 LSH TEMP,^D29 ;UNPACK LEFT TO RIGHT
18400 TLO TEMP,002000 ;ADD BIT TO MARK END
18500 SMOVER: TLNN TEMP,376000 ;NOW CHECK FOR NO MORE BITS
18600 JRST SMOVEU ;IF SO, GET NEXT SOURCE
18700 ROT TEMP,1 ;IF NOT, ROTATE NEW BIT
18800 IDPB TEMP,BYTEP2 ; TO STORE POSITION
18900 SOJG LEN2,SMOVER ;IF DESTINATION ROOM, CONTINUE
19000 JRST %XUUO ; ELSE QUIT
19100 SMOVEP: HRLI LEN2,1 ;SET UP FOR BITS TO STRING MOVE
19200 JUMPE LEN1,.+4 ;CHECK FOR NO MORE SOURCE
19300 ILDB TEMP,BYTEP1 ;IF NOT, GET A BYTE
19400 LSH TEMP,^D17 ; AND PUT IN HIGH ORDER OF HALF
19500 SOJA LEN1,.+2 ;ADJUST LENGTH
19600 MOVEI TEMP,0 ;PAD OUT SOURCE WITH ZEROES
19700 HLL TEMP,LEN2
19800 LSH TEMP,1 ;PACK IN NEW BIT
19900 HLL LEN2,TEMP
20000 TLNN TEMP,000200 ;CHECK FOR FINISHED BYTE
20100 JRST SMOVEP+1
20200 HRLI LEN2,0 ;RESET LEFT HALF OF LENGTH
20300 HLRZS TEMP ;RIGHT JUSTIFY
20400 IDPB TEMP,BYTEP2 ;AND STORE AWAY
20500 SOJG LEN2,SMOVEP ;ADJUST DEST. LENGTH
20600 JRST %XUUO ;EXIT IF DONE
20700
20800 %IS: LDB TEMP,[POINT 4,JOBUUO,^D12]
20900 MOVE TEMP,(TEMP) ;GET RECORD DESCRIPTOR
21000 JUMPE TEMP,%XUUO ;MAYBE IS NULL POINTER
21100 HLRZ TEMP,-1(TEMP)
21200 CAIN TEMP,@JOBUUO ;IF SAME AS ASKED RECORD,
21300 JRST RECDIS ; SHORT CUT CHECK
21400 HRRZ TEMP,(TEMP) ;GET NAME ADDRESS
21500 HRRZ LEN1,@JOBUUO
21600 MOVE CHAR,(TEMP) ;GET A WORD OF NAME
21700 CAME CHAR,(LEN1) ;COMPARE TO OTHER NAME
21800 JRST %XUUO ;FAIL IF NOT =
21900 ADDI TEMP,1
22000 TRNE CHAR,376 ;IF END OF ASCIZ, SUCCEED
22100 AOJA LEN1,.-5 ; ELSE TRY NEXT WORDS
22200 RECDIS: AOS %UUO
22300 JRST %XUUO ;SKIP RETURN
22400
22500 %SUBST: HRRZ TEMP,JOBUUO ;GET DV
22600 MOVE BYTEP1,(TEMP)
22700 MOVS LEN1,1(TEMP) ;SWAPPED LENGTH
22800 LDB TEMP,[POINT 4,JOBUUO,^D12]
22900 TRZN TEMP,1
23000 JRST .+3
23100 MOVE LEN2,(TEMP) ;SPECIAL CASE, STRING SUBSCRIPTING
23200 JRST SPECSB
23300 MOVE LEN2,(TEMP) ;GET NEW START POSITION
23400 CAILE LEN2,(LEN1) ;COMPARE TO OLD LENGTH
23500 JRST ERR2 ;ERROR IF >
23600 SOJL LEN2,ERR1 ; OR IF <= 0
23700 SUBI LEN1,(LEN2) ;ADJUST OLD LENGTH
23800 MOVE BYTEP2,1(TEMP) ;GET NEW LENGTH
23900 JUMPL BYTEP2,ERR3 ;ERROR IF < 0
24000 CAILE BYTEP2,(LEN1) ; OR IF > ADJUSTED LENGTH
24100 JRST ERR4
24200 HRRI LEN1,(BYTEP2) ;SET NEW LENGTH
24300 SPECSB: LDB BYTEP2,[POINT 6,BYTEP1,^D11]
24400 MOVEI TEMP,^D36 ;HOW MANY BYTES PER WORD
24500 IDIVM TEMP,BYTEP2
24600 IDIVI LEN2,(BYTEP2) ;GET WORD OFFSET AND REMAINDER
24700 ADDI BYTEP1,(LEN2)
24800 JUMPE BYTEP2,.+3 ;ADJUST BYTE POINTER ACCORDINGLY
24900 IBP BYTEP1
25000 SOJG BYTEP2,.-1
25100 LDB TEMP,[POINT 4,JOBUUO,^D12]
25200 ANDI TEMP,16
25300 MOVEM BYTEP1,(TEMP) ;STORE ADJUSTED DV
25400 MOVSM LEN1,1(TEMP)
25500 JRST %XUUO ;AND RETURN
25600
25700 ERR1: MOVE LEN2,(TEMP) ;SAVE START
25800 MOVEI ERROR,[ASCIZ/SUBSTRING - START $ <= 0/]
25900 EDIT: PUSHJ %P,%ERROR
26000 MOVE ERROR,LEN2
26100 PUSHJ %P,%ERRNM
26200 EXIT ;QUIT
26300
26400 ERR2: MOVE LEN2,(TEMP) ;SAVE START
26500 MOVEI ERROR,[ASCIZ/SUBSTRING - START $ > STRING LENGTH $/]
26600 PUSHJ %P,%ERROR
26700 MOVE ERROR,LEN2
26800 PUSHJ %P,%ERRNM
26900 MOVEI ERROR,(LEN1) ;GET STRING LENGTH
27000 PUSHJ %P,%ERRNM
27100 EXIT ;QUIT
27200
27300 ERR3: MOVE LEN2,1(TEMP) ;SAVE LENGTH
27400 MOVEI ERROR,[ASCIZ/SUBSTRING - LENGTH $ < 0/]
27500 JRST EDIT
27600
27700 ERR4: MOVE LEN2,(TEMP) ;SAVE START
27800 MOVE BYTEP2,1(TEMP) ; AND LENGTH
27900 MOVEI ERROR,[ASCIZ/SUBSTRING - LENGTH $ > STRING LENGTH $ - START $ + 1/]
28000 PUSHJ %P,%ERROR
28100 MOVE ERROR,BYTEP2
28200 PUSHJ %P,%ERRNM
28300 MOVEI ERROR,(LEN1) ;GET STRING LENGTH
28400 PUSHJ %P,%ERRNM
28500 JRST EDIT+1
28600
28700 %SUBSC: LDB TEMP,[POINT 4,JOBUUO,^D12]
28800 HRRZ LEN1,JOBUUO ;SUBSCRIPT CHECKING
28900 MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
29000 SUB LEN2,1(LEN1) ;SUBTRACT LOWER BOUND
29100 JUMPL LEN2,LOWERR
29200 CAML LEN2,2(LEN1) ;CHECK UPPER BOUND
29300 JRST HGHERR
29400 IMUL LEN2,(LEN1) ;MULTIPLY BY DIMENSION UNITS
29500 ADDM LEN2,(TEMP) ;ADD IN TO TOTAL
29600 JRST %XUUO
29700
29800 LOWERR: MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
29900 MOVEI ERROR,[ASCIZ/SUBSCRIPT - $ < LOWER BOUND $/]
30000 PUSHJ %P,%ERROR
30100 MOVE ERROR,LEN2
30200 PUSHJ %P,%ERRNM
30300 MOVE ERROR,1(LEN1)
30400 PUSHJ %P,%ERRNM
30500 EXIT
30600
30700 HGHERR: MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
30800 MOVEI ERROR,[ASCIZ/SUBSCRIPT - $ > UPPER BOUND $/]
30900 PUSHJ %P,%ERROR
31000 MOVE ERROR,LEN2
31100 PUSHJ %P,%ERRNM
31200 MOVE ERROR,2(LEN1) ;CALCULATE UPPER BOUND
31300 ADD ERROR,1(LEN1)
31400 SUBI ERROR,1
31500 PUSHJ %P,%ERRNM
31600 EXIT
31700
31800 %INTST: MOVEI SIGN," " ;INTEGER TO STRING CONVERSION
31900 SKIPGE -3(%P) ;CHECK SIGN OF VALUE
32000 MOVEI SIGN,"-"
32100 MOVM VALUE,-3(%P) ;GET MAGNITUDE OF VALUE
32200 MOVE DIGITS,[XWD 2,2];MINIMUM OF 2 CHARACTERS
32300 INTSTD: IDIVI VALUE,^D10
32400 JUMPE VALUE,INTSTE ;PUSH DIGITS INTO STACK
32500 ADDI VALUE+1,"0"
32600 PUSH %P,VALUE+1 ;THEY ARE IN REVERSE ORDER
32700 AOBJP DIGITS,INTSTD ;KEEP TRACK OF HOW MANY
32800 INTSTE: ADDI VALUE+1,"0"
32900 PUSH %P,VALUE+1 ;DO LAST DIGIT
33000 PUSH %P,SIGN ; AND SIGN
33100 SUB %P,DIGITS ;NOW ADJUST STACK
33200 MOVE LEN1,-1(%P)
33300 SUBI LEN1,(DIGITS) ;HOW MANY LEADING BLANKS
33400 JUMPL LEN1,INTSTX ; OR MAYBE AN ERROR
33500 JUMPE LEN1,INTSTC
33600 MOVEI PAD," "
33700 IDPB PAD,-2(%P) ;STORE LEADING BLANKS
33800 SOJG LEN1,.-1
33900 INTSTC: ADDI DIGITS,(%P) ;POINT TO START OF NUMBER
34000 SUB DIGITS,[XWD 1,0]
34100 MOVE PAD,(DIGITS) ;GET A CHARACTER
34200 IDPB PAD,-2(%P) ; AND STORE IT
34300 SUB DIGITS,[XWD 1,1]
34400 JUMPGE DIGITS,.-3 ;LOOP UNTIL DONE
34500 POP %P,-3(%P)
34600 SUB %P,[XWD 2,2] ;CLOSE UP STACK
34700 POPJ %P, ;AND EXIT
34800 INTSTX: MOVEI ERROR,[ASCIZ/INTSTR - $ TOO BIG FOR $ CHARACTER STRING/]
34900 PUSHJ %P,%ERROR
35000 MOVE ERROR,-3(%P) ;EDIT IN INTEGER
35100 PUSHJ %P,%ERRNM
35200 MOVE ERROR,-1(%P) ;AND STRING LENGTH
35300 PUSHJ %P,%ERRNM
35400 EXIT
35500
35600 %STRIN: MOVE LEN2,-1(%P) ;STRING TO INTEGER CONVERSION
35700 SOJL LEN2,FMTERR
35800 ILDB SIGN,-2(%P) ;SKIP LEADING BLANKS
35900 CAIN SIGN," "
36000 JRST .-3
36100 CAIE SIGN,"+" ;ALLOW LEADING PLUS
36200 CAIN SIGN,"-" ; OR MINUS
36300 JRST STRINS
36400 CAIGE SIGN,"0" ;MAKE SURE VALID DIGIT
36500 JRST FMTERR
36600 CAILE SIGN,"9"
36700 JRST FMTERR
36800 MOVEI VALUE,-"0"(SIGN);ASSUME POSITIVE
36900 SOJL LEN2,STRINE
37000 STRINL: ILDB VALUE+1,-2(%P) ;GET NEXT CHARACTER
37100 CAIGE VALUE+1,"0"
37200 JRST FMTERR ;ALLOW ONLY DIGITS
37300 CAILE VALUE+1,"9"
37400 JRST FMTERR
37500 CAMLE VALUE,[DEC <^O377777777777-9>/10]
37600 JRST SIZERR ;CHECK FOR SIZE
37700 IMULI VALUE,^D10
37800 ADDI VALUE,-"0"(VALUE+1)
37900 SOJGE LEN2,STRINL ;PACK IN AND TRY AGAIN
38000 STRINE: CAIN SIGN,"-"
38100 MOVN VALUE,VALUE ;NEGATE IF MINUS SIGN
38200 MOVEM VALUE,-2(%P)
38300 POP %P,-1(%P) ;CLOSE UP STACK
38400 POPJ %P,
38500 STRINS: SOJL LEN2,FMTERR ;SIGN, CHECK FOR FOLLOWING
38600 MOVEI VALUE,0 ; DIGIT
38700 JRST STRINL
38800 SIZERR: MOVEI ERROR,[ASCIZ/STRINT - INTEGER TOO LARGE/]
38900 PUSHJ %P,%ERROR
39000 EXIT
39100 FMTERR: MOVEI ERROR,[ASCIZ/STRINT - STRING DOESN'T CONTAIN INTEGER/]
39200 PUSHJ %P,%ERROR
39300 EXIT
39400
39500 %INTBI: MOVE LEN2,-1(%P) ;INTEGER TO BITS CONVERSION
39600 MOVEI VALUE,0
39700 CAIG LEN2,^D36 ;PAD ON LEFT WITH ZEROES
39800 JRST .+3
39900 IDPB VALUE,-2(%P)
40000 SOJA LEN2,.-3
40100 MOVE VALUE,-3(%P) ;LEFT SHIFT FOR SHORT BITSTRINGS
40200 HRREI SIGN,-^D36(CHAR)
40300 JUMPE SIGN,INTBIS ;36 BITS, NO SHIFT NEEDED
40400 JUMPL VALUE,BITSIZ ;CHECK FOR NOT ENOUGH ROOM
40500 LSH VALUE,1
40600 AOJL SIGN,.-2
40700 INTBIS: JUMPE LEN2,INTBIE ;COPY BITS NOW
40800 ROT VALUE,1
40900 IDPB VALUE,-2(%P)
41000 SOJG LEN2,.-2
41100 INTBIE: POP %P,-3(%P) ;CLOSE UP STACK
41200 SUB %P,[XWD 2,2]
41300 POPJ %P,
41400 BITSIZ: MOVEI ERROR,[ASCIZ/INTBIT - $ TOO BIG FOR $ BIT BITSTRING/]
41500 PUSHJ %P,%ERROR
41600 MOVE ERROR,-3(%P) ;EDIT IN INTEGER
41700 PUSHJ %P,%ERRNM
41800 MOVE ERROR,-1(%P) ;EDIT IN LENGTH
41900 PUSHJ %P,%ERRNM
42000 EXIT
42100
42200 %BITIN: MOVE LEN2,-1(%P) ;BITSTRING TO INTEGER CONVERSION
42300 MOVEI VALUE,0
42400 JUMPE LEN2,BITINE ;NULL BITSTRING ALLOWED
42500 BITINL: JUMPL VALUE,INTSIZ ;TOO BIG
42600 ILDB VALUE+1,-2(%P)
42700 ROT VALUE+1,-1 ;GET BIT INTO POSITION
42800 LSHC VALUE,1
42900 SOJG LEN2,BITINL ;MERGE AND GET NEXT ONE
43000 BITINE: MOVEM VALUE,-2(%P) ;SAVE VALUE
43100 POP %P,-1(%P) ; AND CLOSE UP STACK
43200 POPJ %P,
43300 INTSIZ: MOVEI ERROR,[ASCIZ/BITINT - MORE THAN 36 SIGNIFICANT BITS/]
43400 PUSHJ %P,%ERROR
43500 EXIT
00100 PRGEND
00200 TITLE %RUN ROUTINE FOR ALGOLW -- MICHAEL GREEN
00300 HISEG
00400 ENTRY %RUN
00500 EXTERN %ERROR,%ERRSB,%OPNSW
00600 %P= 17
00700 CHAR= 10
00800 ASSEMB= 11
00900 LENGTH= 12
01000 FLAG= 13
01100 ERROR= 14
01200 LOOKNM= 400000 ;FLAGS IN LH OF FLAG
01300 FINDNM= 200000
01400 LOOKDG= 100000
01500 FINDDG= 040000
01600 LOOKDV= 020000
01700 LOOKFL= 010000
01800 PASTFL= 004000
01900 LOOKPP= 002000
02000 OCTAL= 001000
02100 LOOKPG= 000400
02200 FINDPP= 000200
02300 LOOKEN= 000100
02400 FINDEN= 000040
02500 LOOKST= 000020
02600 FINDST= 000010
02700 CONDRN= 000004
02800
02900 DEV= %OPNSW ;DEVICE NAME
03000 NAME= %OPNSW+1 ;FILE NAME
03100 EXT= %OPNSW+2 ;EXTENSION
03200 PPNO= %OPNSW+4 ;PROJECT-PROGRAMMER NUMBER
03300 LOWMEM= %OPNSW+5 ;LOW SEGMENT LENGTH
03400 ENTRY= %OPNSW+6 ;RELATIVE ENTRY POINT
03500
03600 %RUN: SETZB FLAG,NAME ;CLEAR FLAGS AND CONTROL BLOCK
03700 MOVE CHAR,[XWD NAME,EXT]
03800 BLT CHAR,ENTRY
03900 MOVSI CHAR,(SIXBIT/DSK/)
04000 MOVEM CHAR,DEV ;DEFAULT DEVICE IS DSK
04100 MOVE LENGTH,-1(%P) ;GET STRING LENGTH
04200
04300 NEWITM: SETZ ASSEMB, ;START NEW FIELD
04400 JUMPL LENGTH,GORUN ; UNLESS NO MORE STRING
04500
04600 NEXTCH: SOJL LENGTH,ENDFLD ;END OF FIELD AT STRING END
04700 ILDB CHAR,-2(%P)
04800 CAIN CHAR,":" ;END OF DEVICE
04900 JRST DEVCHK
05000 CAIN CHAR,"." ;END OF FILE NAME
05100 JRST NAMCHK
05200 CAIN CHAR,"[" ;START OF PROJECT-PROGRAMMER
05300 JRST STRTPP
05400 CAIN CHAR,"," ;START OF PROGRAMMER
05500 JRST COMMA
05600 CAIN CHAR,"]" ;END OF PROGRAMMER NUMBER
05700 JRST ENDPP
05800 CAIN CHAR,"?" ;CONDITIONAL RUN
05900 JRST CONDCD
06000 CAIN CHAR,"@" ;START OF ENTRY POINT
06100 JRST STRTEN
06200 CAIN CHAR,"=" ;START OF LOW SEGMENT LENGTH
06300 JRST STRTST
06400 CAIN CHAR,"K" ;MAYBE END OF LOW SEGMENT LENGTH
06500 JRST ENDSTU
06600 CAIN CHAR,"K"+40 ;ALSO MAYBE END OF LOW SEGMENT LENGTH
06700 JRST ENDSTL
06800 CAIGE CHAR,"0" ;CHECK FOR DIGIT
06900 JRST .+3
07000 CAIG CHAR,"9"
07100 JRST DIGIT
07200 CAIGE CHAR,"A" ;CHECK FOR UPPER CASE LETTER
07300 JRST .+3
07400 CAIG CHAR,"Z"
07500 JRST LETTER
07600 CAIGE CHAR,"A"+40 ;CHECK FOR LOWER CASE LETTER
07700 JRST .+3
07800 CAIG CHAR,"Z"+40
07900 JRST LOWERC
08000 UNKNOW: MOVEI ERROR,[ASCIZ/RUN - UNRECOGNIZABLE FILE DESCRIPTOR/]
08100 PUSHJ %P,%ERROR
08200 EXIT
08300
08400 LOWERC: TRZ CHAR,40 ;FORCE TO UPPER CASE
08500 LETTER: TLNE FLAG,LOOKNM
08600 JRST UNKNOW ;MUST BE LOOKING FOR NAME
08700 TLO FLAG,FINDNM
08800 TLNE ASSEMB,770000 ;USE ONLY FIRST 6 CHARACTERS
08900 JRST NEXTCH
09000 TRC CHAR,40
09100 ROT CHAR,-6
09200 ROTC CHAR,6 ;PACK IN USING SIXBIT
09300 JRST NEXTCH
09400
09500 DIGIT: TLNN FLAG,LOOKDG ;ARE WE LOOKING FOR DIGIT
09600 JRST LETTER ; NO, MAYBE PART OF NAME
09700 TLO FLAG,FINDDG
09800 TLNE FLAG,OCTAL ;TAKE CARE OF OCTAL NUMBER
09900 JRST POCTAL
10000 CAIL ASSEMB,^D100 ;MAXIMUM OF 3 DIGITS
10100 JRST UNKNOW
10200 IMULI ASSEMB,^D10 ;OK, PACK IN DIGIT
10300 ADDI ASSEMB,-"0"(CHAR)
10400 JRST NEXTCH
10500
10600 POCTAL: CAIL CHAR,"8" ;CHECK FOR LEGAL OCTAL DIGIT
10700 JRST UNKNOW
10800 CAIL ASSEMB,100000 ;MAXIMUM OF 18 BITS
10900 JRST UNKNOW
11000 ROT CHAR,-3 ;PACK IN
11100 ROTC CHAR,3
11200 JRST NEXTCH
11300
11400 DEVCHK: TLOE FLAG,LOOKDV ;LOOKING FOR DEVICE NAME
11500 JRST UNKNOW
11600 TLZN FLAG,FINDNM ;LOOKING FOR NAME
11700 JRST UNKNOW
11800 TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
11900 JRST .+3
12000 LSH ASSEMB,6
12100 JRST .-3
12200 MOVEM ASSEMB,DEV ;SAVE EXPLICIT DEVICE NAME
12300 JRST NEWITM
12400
12500 NAMCHK: TLOE FLAG,LOOKFL ;LOOKING FOR FILE NAME
12600 JRST UNKNOW
12700 TLZN FLAG,FINDNM ;LOOKING FOR NAME
12800 JRST UNKNOW
12900 TLO FLAG,LOOKDV ;NO MORE DEVICE NAMES
13000 STORFL: TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
13100 JRST .+3
13200 LSH ASSEMB,6
13300 JRST .-3
13400 MOVEM ASSEMB,NAME ;STORE IT AWAY
13500 JRST NEWITM
13600
13700 ENDFLD: TLOE FLAG,PASTFL ;PAST DEV:FILE.EXT
13800 JRST CHKENT
13900 TLO FLAG,LOOKNM ;NO, NO MORE NAMES
14000 TLZN FLAG,FINDNM
14100 JRST NEWITM ;NO NAME
14200 TLON FLAG,LOOKFL
14300 JRST STORFL ;LOOKING FOR FILE NAME
14400 TLNE ASSEMB,770000
14500 JRST .+3 ;NO, FOUND EXTENSION
14600 LSH ASSEMB,6
14700 JRST .-3
14800 HLLZM ASSEMB,EXT ;SO STORE IT
14900 JRST NEWITM
15000
15100 STRTPP: TLNE FLAG,LOOKPP+FINDPP+LOOKST+LOOKPG
15200 JRST UNKNOWN ;NOT IN PROJ-PROG OR LOW SEG SIZE
15300 TLO FLAG,LOOKDG+OCTAL+LOOKPP
15400 JRST ENDFLD ;LOOK FOR OCTAL PROJECT NO.
15500
15600 CHKENT: TLZN FLAG,LOOKEN ;CHECK IN ENTRY POINT
15700 JRST NEWITM
15800 TLZN FLAG,FINDDG ;MUST HAVE NUMBER
15900 JRST UNKNOW
16000 TLO FLAG,FINDEN ;FOUND ENTRY POINT
16100 HRLZM ASSEMB,ENTRY ; SO SAVE IT
16200 JRST NEWITM
16300
16400 STRTEN: TLNE FLAG,LOOKEN+FINDEN
16500 JRST UNKNOW ;NOT IN ENTRY AND NOT FOUND ONE
16600 TLO FLAG,LOOKDG+LOOKEN+OCTAL
16700 TLOE FLAG,PASTFL ;CHECK PAST FILE
16800 JRST NEWITM ; IF SO, DON'T USE ENDFLD
16900 JRST ENDFLD+2 ; IF NOT, BYPASS CHKENT TEST
17000
17100 COMMA: TLZN FLAG,LOOKPP ;MUST BE LOOKING FOR PROJECT
17200 JRST UNKNOW
17300 TLZN FLAG,FINDDG ;MUST HAVE FOUND THE NUMBER
17400 JRST UNKNOW
17500 TLO FLAG,LOOKPG ;LOOK FOR PROGRAMMER NUMBER
17600 HRLZM ASSEMB,PPNO
17700 JRST NEWITM ;STORE PROJECT NUMBER
17800
17900 ENDPP: TLZN FLAG,LOOKPG ;MUST BE LOOKING FOR PROGRAMMER NO.
18000 JRST UNKNOW
18100 TLZN FLAG,FINDDG ;MUST HAVE FOUND THE NUMBER
18200 JRST UNKNOW
18300 TLO FLAG,FINDPP ;FOUND PROJECT-PROGRAMMER
18400 TLZ FLAG,LOOKDG
18500 HRRM ASSEMB,PPNO ;STORE IT AWAY
18600 JRST NEWITM
18700
18800 STRTST: TLNE FLAG,FINDST+LOOKST+LOOKPP+LOOKPG
18900 JRST UNKNOW ;MUST NOT BE IN A FIELD
19000 TLO FLAG,LOOKDG+LOOKST
19100 TLZ FLAG,OCTAL ;LOOK FOR DECIMAL NUMBER
19200 JRST ENDFLD
19300
19400 ENDSTL: TRZ CHAR,40 ;FORCE TO UPPER CASE "K"
19500 ENDSTU: TLZN FLAG,LOOKST ;MUST BE IN ENTRY FIELD
19600 JRST LETTER ; IF NOT, IS PART OF NAME
19700 TLZN FLAG,FINDDG
19800 JRST UNKNOW ;MUST HAVE FOUND NUMBER
19900 JUMPE ASSEMB,UNKNOW
20000 CAILE ASSEMB,^D128 ;0 < SIZE <= 128
20100 JRST UNKNOW
20200 TLO FLAG,FINDST ;SO FOUND LOW SEGMENT SIZE
20300 TLZ FLAG,LOOKDG
20400 LSH ASSEMB,^D10 ;SIZE IS IN MULTIPLES OF 1024
20500 SUBI ASSEMB,1
20600 HRRZM ASSEMB,LOWMEM ;STORE MAX ADDRESS OF LOW SEG
20700 JRST NEWITM
20800
20900 CONDCD: TLNE FLAG,LOOKPP+LOOKST+LOOKPG
21000 JRST UNKNOW ;NOT IN A FIELD
21100 TLZ FLAG,LOOKDG
21200 TLO FLAG,CONDRN ;SET CONDITIONAL RUN FLAG
21300 JRST ENDFLD
21400
21500 GORUN: POP %P,-1(%P) ;CLOSE UP STACK
21600 POP %P,-1(%P)
21700 MOVE CHAR,ENTRY ;ENTRY POINT IN LH
21800 HRRI CHAR,DEV ;ADDR OF BLOCK IN RH
21900 RUN CHAR, ;ASK TO RUN IT
22000 TLNE FLAG,CONDRN
22100 POPJ %P, ;ERROR RETURN
22200 MOVEI ERROR,[ASCIZ/RUN - $:$.$ CAN NOT BE RUN/]
22300 PUSHJ %P,%ERROR ;UNCONDITIONAL RUN
22400 MOVE ERROR,DEV
22500 PUSHJ %P,%ERRSB ;EDIT IN DEVICE NAME
22600 MOVE ERROR,NAME
22700 PUSHJ %P,%ERRSB ;AND FILE NAME
22800 MOVE ERROR,EXT
22900 PUSHJ %P,%ERRSB ;AND EXTENSION
23000 EXIT
00100 END
00200 EXIT