Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0035/alglib.mac
There are 11 other files named alglib.mac in the archive. Click here to see a list.
TITLE %LOW -- ALGOLW LOW CORE TABLES -- MICHAEL GREEN
; Modified by Paul T. Robinson, Wesleyan Univ. for
; DECUS conversion to DEC-20. Edits usually in lower case.
ENTRY %SREG,%LREG,%NREG,%ANREG,%ALREG,%AVIOB,%UUO
ENTRY %IOOPN,%IOLEB,%IOBFH,%IOPRO,%IOREG,%IOSIZ,%IOEND
ENTRY %HDBLK,%SAVE,%PDL,%ENTRY,%STAT,%STEND,%DYNAM
ENTRY %ARITH,%APRSV,%ERRPT,%IOBRK,%DCSAV,%IOPP,%OPNSW
EXTERN %RESET
.jb41= 41
LOC .jb41
JSP 1,%RESET ;UUO HANDLER SETUP
RELOC
%SREG: BLOCK ^D16 ;START OF REGION TABLE
%LREG: BLOCK ^D16 ;AVAILABLE LENGTH IN REGION TABLE
%NREG: BLOCK ^D16 ;NEXT AVAILABLE LOCATION IN REGION TABLE
%ALREG: BLOCK ^D16 ;ALLOCATOR AVAILABLE LENGTH IN REGION
%ANREG: BLOCK ^D16 ;ALLOCATOR NEXT AVAILABLE LOCATION
%AVIOB: BLOCK 1 ;NEXT AVAILABLE I/O REGION
%IOOPN: BLOCK 3 ;OPEN CONTROL BLOCK
%IOLEB: BLOCK 4 ;LOOKUP/ENTER CONTROL BLOCK
%IOBFH: BLOCK 3 ;BUFFER HEADER
%IOPP: BLOCK 1 ;PROJECT-PROGRAMMER NUMBER FOR CLOSE
%IOPRO: BLOCK 1 ;PROTECTION CODE FOR CLOSE ON OUTPUT FILE
%IOREG: BLOCK 1 ;INDEX TO I/O REGION
%IOBRK: BLOCK 10 ;USED BY BREAK FUNCTION
%IOSIZ= .-%IOOPN ;SIZE OF CHANNEL CONTROL BLOCKS
BLOCK ^D15*%IOSIZ
%IOEND= .-1 ;END OF I/O CONTROL BLOCKS
%HDBLK: BLOCK 6 ;USED BY GARBAGE COLLECTOR AND RECORD I/O
%SAVE: BLOCK 10 ;SAVE AREA FOR AC'S 0 THROUGH 7
%APRSV: BLOCK 2 ;SAVE AREA FOR APR INTERRUPTS
%ENTRY: BLOCK 1 ;0-NORMAL ENTRY, -1-ALTERNATE ENTRY TO CUSP
%PDL: BLOCK ^D128 ;PUSH DOWN LIST
%STAT: BLOCK 1 ;+0 RUNTIM AT END OF LAST ALLOC
BLOCK 1 ;+1 RUNTIM AT END OF LAST COLLE
%DYNAM: BLOCK 1 ;+2 START OF DYNAMIC STORAGE
BLOCK 1 ;+3 # TIMES ALLOC CALLED
BLOCK 1 ;+4 # TIMES COLLE CALLED
BLOCK 1 ;+5 TOTAL CORE REQUESTED
BLOCK 1 ;+6 MAX CORE REQUESTED
BLOCK 1 ;+7 CUMULATIVE AVERAGE CORE REQUESTED
BLOCK 1 ;+10 TOTAL TIME BETWEEN ALLOC CALLS
BLOCK 1 ;+11 MAX TIME BETWEEN ALLOC CALLS
BLOCK 1 ;+12 TOTAL TIME IN ALLOC
BLOCK 1 ;+13 MAX TIME IN ALLOC
BLOCK 1 ;+14 TOTAL CORE FREED BY COLLECTION
BLOCK 1 ;+15 MAX CORE FREED BY COLLECTION
BLOCK 1 ;+16 CUMULATIVE AVERAGE CORE FREED
BLOCK 1 ;+17 TOTAL TIME BETWEEN COLLE CALLS
BLOCK 1 ;+20 MAX TIME BETWEEN COLLE CALLS
BLOCK 1 ;+21 TOTAL TIME IN COLLE
BLOCK 1 ;+22 MAX TIME IN COLLE
BLOCK 1 ;+23 STARTING TIME OF RUN
BLOCK 1 ;+24 RUNTIM AT START OF RUN
BLOCK 1 ;+25 CORE REQUESTED SINCE LAST COLLE
BLOCK 1 ;+26 MAX CORE REQUESTED SINCE LAST COLLE
BLOCK 1 ;+27 CUMULATIVE AVERAGE SINCE LAST COLLE
BLOCK 1 ;+30 # TIMES ALLOC CALLED SINCE LAST COLLE
%STEND= .-1
%ERRPT: BLOCK 1 ;USED BY %ERROR ROUTINE
%DCSAV: BLOCK 1 ;USED TO SAVE %UUO FOR CALL ON %ARITH
%UUO: BLOCK 2 ;.jb41 CONTAINS JSR %UUO
%ARITH: BLOCK 1 ;CONTROL OF FLOATING POINT UNDERFLOWS
%OPNSW: BLOCK 10 ;USED TO HOLD DTA AND MTA SWITCHES DURING OPEN
PRGEND
TITLE %RESET -- ALGOLW INITIALIZATION -- MICHAEL GREEN
HISEG
ENTRY %RESET
EXTERN %PDL,%HDBLK,%ENTRY,%ERROR,%STEND ;JOBFF,JOBREN,JOBAPR
EXTERN %SREG,%NREG,%AVIOB,%IOOPN,%IOLEB,%IOBFH,%IOEND,%STAT
EXTERN %DYNAM,%UUO,%DCSAV,%IOBRK ;JOBCNI,JOBTPC,JOBOPC,JOB41
EXTERN %APRSV,%UUOTB,%ARITH,%BLOCK ;JOBSYM,JOBUSY,JOBSA
extern .jbff,.jbren,.jbapr,.jbcni,.jbtpc,.jbopc,.jb41
extern .jbsym,.jbusy,.jbsa
%T= 14
%TB= 15
%B= 16
%P= 17
ENTRY= 0
RETURN= 1
TEMP= 2
TEMP2= 3
TEMP3= 4
ERROR= 14
INFLG= 040000 ;FLAGS IN LH OF %IOOPN
OUTFLG= 020000
STRFLG= 004000
LNEFLG= 200000
SYMPAT= 2*^D32 ;ROOM FOR NEW SYMBOLS IN DDT TABLE
%RESET: MOVEM RETURN,%UUO ;INITIAL SETUP
SETZB %T,%DCSAV ;MARK NOT IN %ARITH CALLING %ARITH
SETZB %TB,%B ;RESET BLOCK POINTERS
RESET ;RESET I/O AND STORAGE LIMITS
HRREM ENTRY,%ENTRY ;SET ENTRY CODE
SETZM .jbUSY ;NO GLOBAL UNDEFINED SYMBOL TABLE
MOVE TEMP,.jbSYM
JUMPE TEMP,NOSYM ;NO SYMBOLS LOADED
HRLE TEMP2,TEMP
SUBM TEMP,TEMP2 ;SEE IF .jbSA IS ABOVE TABLE
HLRZ TEMP3,.jbSA
CAIL TEMP3,(TEMP2) ;IF SO, WE ALREADY MOVED IT
JRST NOSYM
ADDI TEMP3,SYMPAT
CAIL TEMP3,(TEMP) ;HAS IT ALREADY BEEN MOVED BY LOADER
JRST NOMOVE
HRLI TEMP3,(TEMP) ;NO, SET UP TO MOVE IT
HRRM TEMP3,.jbSYM
HRLE TEMP2,TEMP
SUBM TEMP3,TEMP2
BLT TEMP3,-1(TEMP2)
NOMOVE: HRLM TEMP2,.jbSA
HRRM TEMP2,.jbFF
NOSYM: MOVE %P,[IOWD ^D108,%PDL] ;SET PDL POINTER
MOVE [XWD 400000+INFLG+OUTFLG+STRFLG+LNEFLG,1]
MOVEM %IOOPN
HRLZI (SIXBIT/TTY/)
MOVEM %IOOPN+1 ;INITIALIZE CHANNEL 0 - TTY
MOVE [XWD %IOBFH,%IOLEB]
MOVEM %IOOPN+2
SETZM %IOOPN+3 ;CLEAR REST OF CONTROL BLOCKS
MOVE [XWD %IOOPN+3,%IOOPN+4]
BLT %IOEND
SETZM %AVIOB
SETZM %SREG
MOVE [XWD %SREG,%SREG+1]
BLT %SREG+5*^D16-1 ;CLEAR STORAGE ALLOCATION BLOCKS
MOVE [XWD 000014,176400] ;INITIALIZE BREAK TABLE
MOVEM %IOBRK
MOVSI 3
MOVEM %IOBRK+1 ;IGNORE CARRIAGE RETURN
MOVEI 3
MOVEM %IOBRK+6 ;BREAK ON VERTICAL MOTION CHARS
MOVEI -1
MOVEM %IOBRK+7 ;AND BELL AND ^Z AND ALTMODE
OPEN %IOOPN ;OPEN TTY - CHANNEL 0
HALT ;FATAL ERROR IF CANNOT
INBUF 2 ;GET BUFFER SPACE
OUTBUF 2
HRRZ .jbFF ;GET NEW STORAGE LIMIT
MOVEM %SREG
MOVEM %NREG ;SET IN TABLES
MOVEM %DYNAM ;SET START OF DYNAMIC STORAGE
SETZM %ARITH ;INITIALIZE ARITH ERROR CONTROL
MOVE [XWD 400005,400001]
MOVEM %HDBLK ;INITIALIZE %HDBLK
SETZM %HDBLK+3 ;SET EXTRA POINTERS TO NULL
SETZM %HDBLK+4
MOVE [JSR %UUO] ;SET UP FOR UUOS
MOVEM .jb41
MOVE [JRST %UUOTB]
MOVEM %UUO+1
MOVEI %REENT ;SET UP FOR REENTER
HRRM .jbREN ; FOR ERROR RECOVERY
MOVEI %APRER
HRRM .jbAPR ;SET UP FOR INTERRUPTS
MOVEI 200110 ; ON PDL OVF,OVF,EXP OVF
APRENB
SETZM %STAT+3
MOVE [XWD %STAT+3,%STAT+4]
BLT %STEND ;INITIALIZE STATISTICS TABLE
MOVEI 0
RUNTIM
MOVEM %STAT ;INITIALIZE TIMES
MOVEM %STAT+1
MOVEM %STAT+24
MSTIME ;GET MS TIME OF DAY
MOVEM %STAT+23
JRST %BLOCK ;TREAT NOW LIKE %BLOCK UUO
%REENT: MOVE .jbOPC ;INDICATE PROPER ERROR POINT
SKIPN %UUO
MOVEM %UUO
MOVEI ERROR,[ASCIZ/REENTER/]
PUSHJ %P,%ERROR ;REENTER, CALL ERROR ROUTINE
EXIT ;AND QUIT
%APRER: MOVEM %APRSV
MOVE .jbTPC ;INDICATE PROPER ERROR POINT
SKIPN %UUO
MOVEM %UUO
MOVE .jbCNI ;APR ERROR, DECODE IT
TRNE 200000
JRST PUSHER ;PUSHDOWN OVERFLOW
TRNE 100
JRST FLTOVF ;FLOATING OVERFLOW
MOVE .jbTPC ;DECODE INTEGER OVERFLOW
TLNE 40
JRST FIXDIV ;FIXED POINT DIVIDE BY ZERO
MOVEI ERROR,[ASCIZ/INTEGER OVERFLOW/]
ERRPRT: PUSHJ %P,%ERROR ;ERROR PRINTOUT
EXIT ;AND QUIT
ERRRTN: MOVE %UUO ;SEE IF SHOULD RESET %UUO
CAMN .jbTPC
SETZM %UUO ;IF %UUO=INTERRUPT POINT
MOVEM ERROR,%APRSV+1 ;SAVE ERROR
MOVE ERROR,.jbTPC ;SEE WHAT KIND OF INSTRUCTION
HLRZ -1(ERROR)
ANDI 777000 ;GET OPCODE
CAIN 140000
JRST UFA ;UFA
CAIN 142000
JRST AC ;FSC
ANDI 007000 ;GET MODE
CAIN 001000
JRST LONG ;LONG MODE
ANDI 003000 ;WHAT DESTINATION
CAIN 003000
JRST BOTH ;XXXXB
CAIN 002000
JRST MEMORY ;XXXXM
AC: HLRZ ERROR,-1(ERROR) ;XXXX OR XXXXI, SET AC
LSH ERROR,-5
ANDI ERROR,17
STORE: JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
SETZM (ERROR)
JRST DONE
SETZM %APRSV
JRST DONE
UFA: HLRZ ERROR,-1(ERROR) ;GET AC+1
ADDI ERROR,40
JRST AC+1
MEMORY: MOVE -1(ERROR) ;GET INSTRUCTION
MOVE ERROR,%APRSV+1 ;RESET ERROR
MOVEI ERROR,@0 ;GET ADDRESS
JRST STORE
BOTH: MOVE -1(ERROR) ;GET INSTRUCTION
MOVE ERROR,%APRSV+1 ;RESET ERROR
MOVEI ERROR,@0 ;GET ADDRESS
JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
SETZM (ERROR)
JRST .+2
SETZM %APRSV
MOVE ERROR,.jbTPC ;SET UP AGAIN FOR STORE IN AC
JRST AC
LONG: HLRZ ERROR,-1(ERROR) ;GET AC
LSH ERROR,-5
ANDI ERROR,17
JUMPE ERROR,.+3 ;ACCOUNT FOR AC0 IN %APRSV
SETZM (ERROR)
JRST .+2
SETZM %APRSV
SETZM 1(ERROR) ;TAKE CARE OF AC+1 ALSO
DONE: MOVE ERROR,%APRSV+1
MOVEI 200110 ;RESET APRENB
APRENB
MOVE %APRSV ;RESTORE REGISTER
JRSTF @.jbTPC ;AND RETURN
FIXDIV: MOVEI ERROR,[ASCIZ/INTEGER DIVISION BY ZERO/]
JRST ERRPRT
FLTOVF: MOVE .jbTPC ;DECODE FLOATING OVERFLOW
TLNE 40
JRST FLTDIV ;FLOATING POINT DIVIDE BY ZERO
TLNE 100
JRST FLTUNF ;FLOATING POINT UNDERFLOW
MOVEI ERROR,[ASCIZ/REAL OR COMPLEX OVERFLOW/]
JRST ERRPRT
FLTDIV: MOVEI ERROR,[ASCIZ/REAL OR COMPLEX DIVISION BY ZERO/]
JRST ERRPRT
FLTUNF: AOSE %ARITH ;KEEP ERROR COUNT
JRST ERRRTN
MOVEI ERROR,[ASCIZ/REAL OR COMPLEX UNDERFLOW/]
JRST ERRPRT
PUSHER: MOVEI ERROR,[ASCIZ/INTERNAL ERROR (STACK OVF)/]
SUB %P,[XWD ^D20,0]
JRST ERRPRT ;ALLOW ACCESS TO EXTRA STACK SPACE
PRGEND
TITLE %UUOTB -- ALGOLW UUO DISPATCH TABLE -- MICHAEL GREEN
HISEG
ENTRY %UUOTB,%XUUO
EXTERN %CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE,%SMOVE,%SUBST
EXTERN %ARECD,%AARRY,%RARRY,%ASTRA,%DADD,%DSUB,%DMULT,%DDIV
EXTERN %CMULT,%CDIV,%DCMUL,%DCDIV,%RDLST,%WRLST,%READ,%WRITE
EXTERN %BRK0,%BRK1,%GETBK,%GETLN,%PUTLN,%CLRBK,%EFILE,%ASTRG
EXTERN %BLOCK,%THUNK,%FIX,%FLOAT,%DFIX,%DFLOT,%CLOSE,%RESET
EXTERN %ERROR,%UUO,%USRER,%SUBSC,%PROC,%OPEN,%IS,%HDBLK
EXTERN .jbUUO
%P= 17
UUOPTR= 14 ;NOTE: IS ALSO %T (SEE %ALLOC)
%UUOTB: MOVEM UUOPTR,%HDBLK+3 ;SAVE %T IN %HDBLK
HLRZ UUOPTR,.jbUUO
LSH UUOPTR,-^D9 ;GET TABLE INDEX
HRLI UUOPTR,%HDBLK+3 ;SETUP FOR REGISTER RESTORE
JRA UUOPTR,.(UUOPTR);JUMP INTO TABLE
JRST %CSTE ;COMPARE STRING EQUAL
JRST %CSTN ;COMPARE STRING NOT EQUAL
JRST %CSTL ;COMPARE STRING LESS THAN
JRST %CSTLE ;COMPARE STRING LESS THAN OR EQUAL
JRST %CSTG ;COMPARE STRING GREATER THAN
JRST %CSTGE ;COMPARE STRING GREATER THAN OR EQUAL
JRST %SMOVE ;MOVE STRING
JRST %SUBST ;SUBSTRING
JRST %ARECD ;RECORD ALLOCATE
JRST %AARRY ;NON-REFERENCE ARRAY ALLOCATE
JRST %RARRY ;REFERENCE ARRAY ALLOCATE
JRST %ASTRA ;STRING ARRAY ALLOCATE
JRST %DADD ;LONG REAL ADD
JRST %DSUB ;LONG REAL SUBTRACT
JRST %DMULT ;LONG REAL MULTIPLY
JRST %DDIV ;LONG REAL DIVIDE
JRST %CMULT ;COMPLEX MULTIPLY
JRST %CDIV ;COMPLEX DIVIDE
JRST %DCMUL ;LONG COMPLEX MULTIPLY
JRST %DCDIV ;LONG COMPLEX DIVIDE
JRST %OPEN ;OPEN FILE
JRST %IS ;REFERENCE IS RECORD TEST
JRST %READ ;READ
JRST %WRITE ;WRITE
JRST %GETLN ;GET INPUT LINE NUMBER
JRST %PUTLN ;PUT OUTPUT LINE NUMBER
JRST %BRK0 ;BREAK NOACTION, IGNORE
JRST %BRK1 ;BREAK INCLUDE, DEFER
JRST %GETBK ;GET BREAK CHARACTER
JRST %SUBSC ;ARRAY SUBSCRIPT CHECKING
HLRZ UUOPTR,.jbUUO ;FURTHER UUO DECODE
LSH UUOPTR,-5 ;USE AC FIELD
HRLI UUOPTR,%HDBLK+3 ;SETUP FOR RESTORE AGAIN
JRA UUOPTR,.-757(UUOPTR) ;ALLOW FOR OPCODE=37
JRST %ASTRG ;STRING ALLOCATE
JRST %PROC ;PROCEDURE ENTRY
JRST %BLOCK ;BLOCK ENTRY
JRST %THUNK ;THUNK ENTRY
JRST %FIX ;REAL TO INTEGER
JRST %FLOAT ;INTEGER TO REAL
JRST %DFIX ;LONG REAL TO INTEGER
JRST %DFLOT ;INTEGER TO LONG REAL
JRST %CLOSE ;CLOSE FILE
JRST %EFILE ;END FILE TEST
JRST CALLUO ;ENTER INTERNAL ROUTINE
JRST %USRER ;USER ERROR TRACEBACK
JRST %CLRBK ;RESET BREAK TABLE
JRST %RDLST ;READ LIST STRUCTURE
JRST %WRLST ;WRITE LIST STRUCTURE
JRST %RESET+1 ;RESET SYSTEM, ENTER OUTER BLOCK
CALLUO: PUSHJ %P,@.jbUUO ;SET TRACEBACK POINT ON ERROR
%XUUO: PUSH %P,%UUO ;RETURN TO POINT OF CALL
SETZM %UUO ;RESET TRACEBACK POINT
MOVE UUOPTR,%HDBLK+3 ;RESTORE REGISTER
POPJ %P,
PRGEND
TITLE %OPEN -- ALGOLW OPEN ROUTINE -- MICHAEL GREEN
HISEG
ENTRY %OPEN,%OPENT
EXTERN %IOOPN,%IOSIZ,%IOLEB,%IOPRO,%IOREG,%AVIOB
EXTERN %SREG,%NREG,%LREG,%COLLE,%ERROR,%ERRNM
EXTERN %XUUO,%IOEND,%SAVE,%ERRSB
EXTERN %IOBFH,%IOBRK,%IOPP,%OPNSW,%UUO
EXTERN .jbUUO,.jbFF
%P= 17
CHAN= 10
CINDEX= 11
TEMP= 12
BUFFCT= 13
TEMP2= 13
ERROR= 14
REGPT= 14
TEMP3= 14
OPNFLG= 400000 ;OPNFLG MUST BE SIGN BIT FOR %OPENT
LNEFLG= 200000
RECFLG= 100000
INFLG= 040000 ;FLAGS IN LH OF %IOOPN
OUTFLG= 020000
BITFLG= 010000
STRFLG= 004000
REWFLG= 002000
CONFLG= 001000
OPENI: TLNN TEMP,2 ;DEVICE CAN DO INPUT
JRST NOINPT
MOVEI TEMP,%IOBFH(CINDEX) ;SET POINTER TO BUFF HEADER
HRRZM TEMP,%IOOPN+2(CINDEX)
MOVE TEMP,[OPEN %IOOPN(CINDEX)]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;OPEN CHANNEL
JRST OPENER
MOVE TEMP,[LOOKUP %IOLEB(CINDEX)]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;LOOKUP FILE
JRST LOOKER
MOVE TEMP,%IOOPN(CINDEX)
TLNE TEMP,RECFLG
JRST FORCEI ;IF LIST I/O, LEAVE BINARY BYTE PTR
ANDI TEMP,17 ;IF BINARY, SET BYTE SIZE OF 1 BIT
JUMPE TEMP,FORCEI
MOVEI TEMP,1
DPB TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
FORCEI: PUSHJ %P,MTASW ;PROCESS DTA AND MTA SWITCHES
PUSH %P,CHAN ;SAVE REGISTERS
PUSH %P,CINDEX
PUSH %P,BUFFCT
PUSHJ %P,%COLLE ;FORCE COLLECTION
POP %P,BUFFCT ;AND RESTORE REGISTERS
POP %P,CINDEX
POP %P,CHAN
MOVE REGPT,%AVIOB
MOVE TEMP,%NREG(REGPT)
HRRM TEMP,.jbFF ;SET AREA FOR BUFFERS
MOVE TEMP,[INBUF (BUFFCT)]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;ALLOCATE THEM
PUSHJ %P,BUFFER ;ADJUST STORAGE CONTROL TABLES
MOVSI TEMP,OPNFLG+INFLG ;MARK NOW AS OPEN
ORM TEMP,%IOOPN(CINDEX)
AOS %UUO ;SKIP RETURN
JRST %XUUO ;DONE, EXIT
OPENO: TLNN TEMP,1 ;DEVICE CAN DO OUTPUT
JRST NOOUT
MOVEI TEMP,%IOBFH(CINDEX) ;SET POINTER TO BUFF HEADER
HRLZM TEMP,%IOOPN+2(CINDEX)
MOVE TEMP,[OPEN %IOOPN(CINDEX)]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;OPEN CHANNEL
JRST OPENER
MOVE TEMP,[ENTER %IOLEB(CINDEX)]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;CREATE FILE
JRST ENTRER
MOVE TEMP,%IOOPN(CINDEX)
TLNE TEMP,RECFLG
JRST FORCEO ;IF LIST I/O, LEAVE BINARY BYTE PTR
ANDI TEMP,17 ;IF BINARY, SET BYTE SIZE TO 1 BIT
JUMPE TEMP,FORCEO
MOVEI TEMP,1
DPB TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
FORCEO: PUSHJ %P,MTASW ;PROCESS DTA AND MTA SWITCHES
PUSH %P,CHAN ;SAVE REGISTERS
PUSH %P,CINDEX
PUSH %P,BUFFCT
PUSHJ %P,%COLLE ;FORCE COLLECTION
POP %P,BUFFCT
POP %P,CINDEX
POP %P,CHAN
MOVE REGPT,%AVIOB
MOVE TEMP,%NREG(REGPT)
HRRM TEMP,.jbFF
MOVE TEMP,[OUTBUF (BUFFCT)] ;SET AREA FOR BUFFERS
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;ALLOCATE THEM
PUSHJ %P,BUFFER ;ADJUST STORAGE CONTROL TABLES
MOVSI TEMP,OPNFLG+OUTFLG ;MARK NOW AS OPEN
ORM TEMP,%IOOPN(CINDEX)
AOS %UUO ;SKIP RETURN
JRST %XUUO ;DONE, EXIT
NOINPT: MOVEI ERROR,[ASCIZ/OPEN - INPUT NOT POSSIBLE FOR $:/]
JRST OPENER+1
NOOUT: MOVEI ERROR,[ASCIZ/OPEN - OUTPUT NOT POSSIBLE FOR $:/]
JRST OPENER+1
OPENER: MOVEI ERROR,[ASCIZ@OPEN - $: I/O ERROR DURING OPEN@]
MOVE TEMP,%IOOPN(CINDEX)
TLNE TEMP,CONFLG ;ERROR ON CONDITIONAL OPEN
JRST %XUUO ;ERROR RETURN
PUSHJ %P,%ERROR
MOVE ERROR,%IOOPN+1(CINDEX)
PUSHJ %P,%ERRSB
EXIT
ENTRER: MOVEI ERROR,[ASCIZ/OPEN OUTPUT - $:$.$ CAN NOT BE CREATED/]
JRST OPNEDT
LOOKER: MOVEI ERROR,[ASCIZ/OPEN INPUT - $:$.$ DOES NOT EXIST/]
OPNEDT: MOVE TEMP,%IOOPN(CINDEX)
TLNE TEMP,CONFLG ;ERROR ON CONDITIONAL OPEN
JRST %XUUO ;ERROR RETURN
PUSHJ %P,%ERROR
MOVE ERROR,%IOOPN+1(CINDEX)
PUSHJ %P,%ERRSB
MOVE ERROR,%IOLEB(CINDEX)
PUSHJ %P,%ERRSB
HLLZ ERROR,%IOLEB+1(CINDEX)
PUSHJ %P,%ERRSB
EXIT
BUFFER: SETZM %LREG(REGPT) ;OLD REGION ZERO AVAILABLE SPACE
AOS REGPT,%AVIOB ;GET NEW REGION
HRRZ TEMP,.jbFF ;START OF AVAILABLE STORAGE
MOVEM TEMP,%SREG(REGPT) ;STORE IN TABLES
MOVEM TEMP,%NREG(REGPT)
SETZM %LREG(REGPT) ;NEW REGION ZERO LENGTH
MOVEI REGPT,0 ;FIND OUT HOW MUCH ALREADY FREE
MOVEI TEMP,0
ADD TEMP,%LREG(REGPT)
CAMGE REGPT,%AVIOB ;ALL ALLOCATED REGIONS
AOJA REGPT,.-2
CAIGE TEMP,2000 ;YES, IF LESS THAN 1K AVAILABLE
SKIPA TEMP,[2000] ;MAKE 1K MORE AVAILABLE
MOVEI TEMP,0
ADD TEMP,%NREG(REGPT)
ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
MOVE TEMP2,%NREG(REGPT)
SUBM TEMP,TEMP2 ;FIND THE LENGTH OF AVAILABLE SPACE
ADDI TEMP2,1
MOVEM TEMP2,%LREG(REGPT) ;SAVE IT
CORE TEMP, ;ASK FOR CORE
JRST TIGHT
POPJ %P,
TIGHT: MOVNI TEMP,2000 ;SEE IF WE REMOVE 1K PADDING
ADDB TEMP,%LREG(REGPT)
ADD TEMP,%NREG(REGPT)
SUBI TEMP,1 ;SHOULD BE ABLE TO GET THAT MUCH
CORE TEMP,
HALT
POPJ %P,
MTASW: MOVE TEMP,[POINT 7,%OPNSW]
ILDB TEMP3,TEMP ;PROCESS DTA OR MTA SWITCHES
JUMPN TEMP3,.+2
POPJ %P, ;ZERO BYTE ENDS LIST
CAIE TEMP3,"Z"
JRST .+5 ;Z IS ZERO DECTAPE DIRECTORY
MOVE TEMP3,[UTPCLR]
DOSW: DPB CHAN,[POINT 4,TEMP3,^D12]
XCT TEMP3 ;DO IT
JRST MTASW+1 ;AND GET NEXT SWITCH
CAIE TEMP3,"A"
JRST .+3 ;A IS ADVANCE ONE FILE
DOASW: MOVE TEMP3,[MTAPE 16]
JRST DOSW
CAIE TEMP3,"C"
JRST .+3 ;C IS IBM COMPATIBLE MODE
MOVE TEMP3,[MTAPE 101]
JRST DOSW
CAIE TEMP3,"W"
JRST .+3 ;W IS REWIND TAPE
MOVE TEMP3,[MTAPE 1]
JRST DOSW
CAIE TEMP3,"T"
JRST .+3 ;T IS GO TO LOGICAL END OF TAPE
MOVE TEMP3,[MTAPE 10]
JRST DOSW
MOVE TEMP3,[MTAPE 17];ELSE ASSUME B - BACKSPACE FILE
DPB CHAN,[POINT 4,TEMP3,^D12]
XCT TEMP3 ;BACKSPACE IT
HRRI TEMP3,0
XCT TEMP3 ;WAIT TIL DONE
MOVE TEMP3,[STATO 4000]
DPB CHAN,[POINT 4,TEMP3,^D12]
XCT TEMP3 ;IS BEGINNING OF TAPE
JRST DOASW ;NO, MOVE PAST TAPE MARK
JRST MTASW+1 ;YES, GET NEXT SWITCH
PAGE
; FILE DESCRIPTOR SCANNER
CHAR= 0
ASSEMB= 1
BYTEPT= 2
LENGTH= 3
FLAG= 4
SWPTR= 5
LOOKNM= 400000 ;FLAG BITS
FINDNM= 200000
LOOKDG= 100000
OCTAL= 040000
FINDDG= 020000
LOOKDV= 010000
LOOKFL= 004000
PASTFL= 002000
LOOKPP= 001000
LOOKPR= 000400
LOOKPG= 000200
LOOKBN= 000100
FINDBN= 000040
FINDPP= 000020
FINDPR= 000010
FINDMD= 000004
SWSKIP= 000002
GOTSW= 000001
%OPEN: MOVEI TEMP,%SAVE ;SAVE WORK REGISTERS
BLT TEMP,%SAVE+5
MOVE CHAN,@.jbUUO ;GET CHANNEL NUMBER
JUMPG CHAN,CHANOK ;MUST BE 0 < CHAN < 16
CHANER: MOVEI ERROR,[ASCIZ/OPEN - ILLEGAL CHANNEL - $/]
OPNERM: PUSHJ %P,%ERROR
MOVE ERROR,CHAN
PUSHJ %P,%ERRNM
EXIT ;QUIT
CHANOK: CAIL CHAN,^D16
JRST CHANER
MOVEI CINDEX,(CHAN) ;GET INDEX INTO TABLES
IMULI CINDEX,%IOSIZ
SKIPL %IOOPN(CINDEX) ;SEE IF ALREADY OPEN
JRST NOTOPN
MOVEI ERROR,[ASCIZ/OPEN - CHANNEL $ ALREADY OPEN/]
JRST OPNERM
NOTOPN: SETZB FLAG,%IOOPN(CINDEX) ;INITIALIZE TABLES
MOVEI TEMP,%IOOPN+1(CINDEX)
HRLI TEMP,%IOOPN(CINDEX)
MOVEI TEMP2,%IOOPN(CINDEX)
BLT TEMP,%IOSIZ-1(TEMP2)
MOVSI TEMP,(SIXBIT/DSK/) ;DEFAULT DEVICE
MOVEM TEMP,%IOOPN+1(CINDEX)
MOVEI BUFFCT,2 ;DEFAULT BUFFER COUNT = 2
SETOM %IOPRO(CINDEX) ;NO PROTECTION RENAME
MOVE TEMP,%AVIOB ;SET REGION NUMBER
MOVEM TEMP,%IOREG(CINDEX)
SETZM %OPNSW
LDB TEMP,[POINT 4,.jbUUO,^D12]
TRZ TEMP,1 ;EITHER INPUT OR OUTPUT
CAIG TEMP,SWPTR ;GET DESCRIPTOR DOPE VECTOR
ADDI TEMP,%SAVE
MOVE BYTEPT,(TEMP)
MOVE TEMP,1(TEMP)
HLRZ LENGTH,TEMP
ADDI BYTEPT,(TEMP) ;MAKE BYTEPTR ABSOLUTE
NEWITM: SETZ ASSEMB, ;START OF NEW ITEM
JUMPL LENGTH,SETXIT ;DONE
NEXTCH: SOJL LENGTH,ENDFLD ;END OF STRING, FINISH UP
ILDB CHAR,BYTEPT ;GET CHARACTER
CAIN CHAR,")"
JRST ENDSW ;END OF DTA OR MTA SWITCHES
TLNE FLAG,SWSKIP
JRST SWTEST ;PROCESS DTA OR MTA SWITCH
CAIN CHAR,"("
JRST STRTSW ;START OF DTA OR MTA SWITCHES
CAIN CHAR,"?"
JRST CONDOP ;CONDITIONAL OPEN
CAIN CHAR,":"
JRST DEVCHK ;END OF DEVICE SPECIFICATION
CAIN CHAR,"."
JRST NAMCHK ;END OF FILE NAME
CAIN CHAR,"["
JRST STRTPP ;START OF PROJECT-PROGRAMMER
CAIN CHAR,"<"
JRST STRTPR ;START OF PROTECTION CODE
CAIN CHAR,"*"
JRST STRTMD ;START OF MODE CODE
CAIN CHAR,"#"
JRST STRTBN ;START OF BUFFER COUNT
CAIN CHAR,","
JRST COMMA ;END OF PROJECT START PROGRAMMER
CAIN CHAR,"]"
JRST ENDPP ;END OF PROGRAMMER
CAIN CHAR,">"
JRST ENDPR ;END OF PROTECT CODE
CAIN CHAR,"^" ;DELETE FILE CODE
JRST DELCOD
CAIGE CHAR,"0"
JRST .+3 ;DIGIT
CAIG CHAR,"9"
JRST DIGIT
CAIGE CHAR,"A"
JRST .+3 ;UPPER CASE LETTER
CAIG CHAR,"Z"
JRST LETTER
CAIGE CHAR,"A"+40
JRST .+3 ;LOWER CASE LETTER
CAIG CHAR,"Z"+40
JRST LOWERC
JRST UNKNOW
LOWERC: TRZ CHAR,40 ;CONVERT TO UPPER CASE
LETTER: TLNE FLAG,LOOKNM ;ARE WE LOOKING FOR A NAME?
JRST UNKNOW
TLO FLAG,FINDNM ;INDICATE WE FOUND ONE
TLNE ASSEMB,770000 ;ONLY FIRST SIX CHARACTERS
JRST NEXTCH
TRC CHAR,40 ;CONVERT TO SIXBIT
ROT CHAR,-6
ROTC CHAR,6 ;PACK INTO ASSEMB
JRST NEXTCH
DIGIT: TLNN FLAG,LOOKDG ;ARE WE LOOKING FOR A NUMBER?
JRST LETTER ;MAYBE PART OF A NAME
TLO FLAG,FINDDG ;INDICATE WE FOUND ONE
TLNE FLAG,OCTAL ;IS IT DECIMAL
JRST POCTAL
CAIL ASSEMB,^D1000 ;MAXIMUM 9999
JRST UNKNOW
IMULI ASSEMB,^D10 ;PACK IN DIGIT
ADDI ASSEMB,-"0"(CHAR)
JRST NEXTCH
POCTAL: CAIL CHAR,"8" ;IS LEGAL OCTAL CHARACTER
JRST UNKNOW
CAIL ASSEMB,100000 ;CHECK HALFWORD ONLY
JRST UNKNOW
ROT CHAR,-3
ROTC CHAR,3 ;PACK IN ASSEMB
JRST NEXTCH
DEVCHK: TLOE FLAG,LOOKDV ;ARE WE LOOKING FOR A DEVICE NAME
JRST UNKNOW
TLZN FLAG,FINDNM ;HAVE WE FOUND A NAME
JRST UNKNOW
TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
JRST .+3
LSH ASSEMB,6
JRST .-3
MOVEM ASSEMB,%IOOPN+1(CINDEX)
JRST NEWITM ;STORE DEVICE AND LEAVE LOOKNM SET
NAMCHK: TLOE FLAG,LOOKFL ;ARE WE LOOKING FOR A FILE NAME
JRST UNKNOW
TLZN FLAG,FINDNM ;HAVE WE FOUND A NAME
JRST UNKNOW
TLO FLAG,LOOKDV
STORFL: TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
JRST .+3
LSH ASSEMB,6
JRST .-3
MOVEM ASSEMB,%IOLEB(CINDEX)
JRST NEWITM ;STORE FILE NAME AND LEAVE LOOKNM SET
ENDFLD: TLNE FLAG,SWSKIP ;END OF STRING IN SWITCH SCAN MODE
JRST UNKNOW
TLOE FLAG,PASTFL ;HAVE WE FINISHED WITH FILE NAME.EXT
JRST CHKBFN
STOEXT: TLO FLAG,LOOKNM ;NO, NO MORE NAMES
TLZN FLAG,FINDNM ;HAVE WE FOUND NAME
JRST NEWITM
TLNN FLAG,LOOKFL ;HAVE WE FOUND FILE NAME
JRST STORFL
TLNE ASSEMB,770000 ;YES, LEFT JUSTIFY EXTENSION
JRST .+3
LSH ASSEMB,6
JRST .-3
HLLM ASSEMB,%IOLEB+1(CINDEX)
JRST NEWITM ;STORE EXTENSION
STRTPP: TLNE FLAG,LOOKPP+FINDPP+LOOKPR+LOOKPG
JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND P-P
TLO FLAG,LOOKDG+OCTAL+LOOKPP
JRST ENDFLD ;LOOKING FOR OCTAL PROJECT NO.
STRTPR: TLNE FLAG,FINDPR+LOOKPR+LOOKPP+LOOKPG
JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND PROT
TLO FLAG,LOOKDG+OCTAL+LOOKPR
JRST ENDFLD ;LOOKING FOR OCTAL PROTECTION
CHKBFN: TLZN FLAG,LOOKBN ;WERE WE PACKING BUFFER NUMBER
JRST NEWITM
TLZN FLAG,FINDDG ;HAD WE FOUND A NUMBER
JRST UNKNOW
JUMPE ASSEMB,UNKNOW ;MUST BE > 0
TLO FLAG,FINDBN ;WE FOUND IT
MOVE BUFFCT,ASSEMB ;SAVE VALUE
JRST NEWITM
STRTBN: TLNE FLAG,LOOKBN+FINDBN
JRST UNKNOW ;ONLY ONE BUFFER NUMBER SPEC.
TLO FLAG,LOOKDG+LOOKBN
TLZ FLAG,OCTAL ;LOOKING FOR DECIMAL BUFFER COUNT
TLOE FLAG,PASTFL ;ARE WE ENDING FILE NAME OR EXT.
JRST NEWITM
JRST STOEXT ;YES, LOOKBN ALREADY SET
STRTMD: TLOE FLAG,FINDMD ;ALREADY FOUND MODE
JRST UNKNOW
TLZ FLAG,LOOKDG
SOJL LENGTH,UNKNOW ;NO, GET NEXT CHARACTER
ILDB CHAR,BYTEPT
CAIN CHAR,"S"
JRST STRMOD ;ASCII MODE
CAIN CHAR,"L"
JRST LINEMD ;NUMBERED LINES (ASCII)
CAIN CHAR,"R"
JRST RECORD ;RECORD I/O
CAIE CHAR,"B"
JRST UNKNOW
MOVSI TEMP,BITFLG ;SET BITS MODE FLAG
ORM TEMP,%IOOPN(CINDEX)
SETBIN: MOVEI TEMP,14 ;BINARY, SET MODE
ORM TEMP,%IOOPN(CINDEX)
JRST ENDFLD
RECORD: MOVSI TEMP,RECFLG ;SET RECORD I/O MODE
ORM TEMP,%IOOPN(CINDEX)
JRST SETBIN
LINEMD: MOVSI TEMP,LNEFLG+STRFLG ;SET NUMBERED LINE MODE
ORM TEMP,%IOOPN(CINDEX)
HLLOS %IOBRK+7(CINDEX) ;SET NO LINE NUMBERS YET
JRST ENDFLD
STRMOD: MOVSI TEMP,STRFLG ;SET STRING MODE
ORM TEMP,%IOOPN(CINDEX)
JRST ENDFLD
ENDPR: TLZN FLAG,LOOKPR ;WERE WE LOOKING FOR PROTECT CODE
JRST UNKNOW
TLZN FLAG,FINDDG ;DID WE FIND NUMBER
JRST UNKNOW
CAIL ASSEMB,1000 ;IS LEGAL CODE
JRST UNKNOW
TLO FLAG,FINDPR ;MARK AS FOUND
TLZ FLAG,LOOKDG
HRRZM ASSEMB,%IOPRO(CINDEX)
JRST NEWITM ;STORE IT
COMMA: TLZN FLAG,LOOKPP ;WERE WE LOOKING FOR PROJECT
JRST UNKNOW
TLZN FLAG,FINDDG ;DID WE FIND NUMBER
JRST UNKNOW
TLO FLAG,LOOKPG ;MARK LOOKING FOR PROGRAMMER
HRLZM ASSEMB,%IOLEB+3(CINDEX)
HRLZM ASSEMB,%IOPP(CINDEX)
JRST NEWITM ;STORE IT
ENDPP: TLZN FLAG,LOOKPG ;WERE WE LOOKING FOR PROGRAMMER
JRST UNKNOW
TLZN FLAG,FINDDG ;DID WE FIND NUMBER
JRST UNKNOW
TLO FLAG,FINDPP ;MARK FOUND
TLZ FLAG,LOOKDG
HRRM ASSEMB,%IOLEB+3(CINDEX)
HRRM ASSEMB,%IOPP(CINDEX)
JRST NEWITM ;STORE IT
DELCOD: TLNE FLAG,LOOKPP+LOOKPR+FINDPR+LOOKPG
JRST UNKNOW ;NOT IN PROT OR P-P OR FOUND PROT
TLZ FLAG,LOOKDG
TLO FLAG,FINDPR
HRRZS %IOPRO(CINDEX) ;MARK FILE TO BE DELETED
JRST ENDFLD
CONDOP: TLNE FLAG,LOOKPP+LOOKPR+LOOKPG
JRST UNKNOW ;NOT IN P-P OR IN PROT
TLZ FLAG,LOOKDG
MOVSI TEMP,CONFLG
ORM TEMP,%IOOPN(CINDEX)
JRST ENDFLD ;SET CONDITIONAL MODE
STRTSW: TLNE FLAG,LOOKPP+LOOKPG+LOOKPR+GOTSW
JRST UNKNOW ;NOT IN P-P OR IN PROT OR GOT SWITCHES
TLZ FLAG,LOOKDG
TLO FLAG,SWSKIP
MOVE SWPTR,[POINT 7,%OPNSW]
JRST ENDFLD+2 ;SET UP FOR SWITCHES
ENDSW: TLZN FLAG,SWSKIP ;BETTER HAVE BEEN PROCESSING SWITCHES
JRST UNKNOW
TLO FLAG,GOTSW
MOVEI TEMP,0
IDPB TEMP,SWPTR ;MARK END OF SWITCHES
JRST NEWITM
SWTEST: MOVE TEMP,SWPTR ;CHECK SWITCHES
CAIN CHAR,"Z"
IDPB CHAR,SWPTR
CAIN CHAR,"A"
IDPB CHAR,SWPTR ;CONDITIONALLY STORE
CAIN CHAR,"B"
IDPB CHAR,SWPTR ;JUST STORE DEFERRED ONES
CAIN CHAR,"C"
IDPB CHAR,SWPTR
CAIN CHAR,"W"
IDPB CHAR,SWPTR
CAIN CHAR,"T"
IDPB CHAR,SWPTR
CAMN SWPTR,[POINT 7,%OPNSW+7,^D34]
JRST UNKNOW ;CHECK LIMIT
CAME TEMP,SWPTR
JRST NEWITM ;IF WE STORED ONE, DONE
CAIN CHAR,"U"
JRST UNLOAD ;SPECIAL SWITCH
CAIN CHAR,"2"
MOVE ASSEMB,[XWD 000200,777177] ;200 BPI
CAIN CHAR,"5"
MOVE ASSEMB,[XWD 000400,777177] ;556 BPI
CAIN CHAR,"8"
MOVE ASSEMB,[XWD 000600,777177] ;800 BPI
CAIN CHAR,"E"
HRLOI ASSEMB,001000 ;EVEN PARITY
CAIN CHAR,"O"
HRRZI ASSEMB,776777 ;ODD PARITY
JUMPE ASSEMB,UNKNOW ;ERROR, UNKNOWN SWITCH
HRROI TEMP,(ASSEMB)
ANDM TEMP,%IOOPN(CINDEX) ;SET MODE
HLRZ TEMP,ASSEMB
ORM TEMP,%IOOPN(CINDEX)
JRST NEWITM ;GET NEXT
UNLOAD: MOVSI TEMP,REWFLG ;SET UNLOAD ON CLOSE
ORM TEMP,%IOOPN(CINDEX)
JRST NEWITM
SETXIT: TLNE FLAG,FINDMD ;HAVE WE FOUND MODE SET
JRST .+12
MOVSI TEMP,STRFLG+LNEFLG
ORM TEMP,%IOOPN(CINDEX) ;NO, SET DEFAULT
HLLOS %IOBRK+7(CINDEX)
MOVE TEMP,[XWD 000014,176400]
MOVEM TEMP,%IOBRK(CINDEX)
MOVSI TEMP,3
MOVEM TEMP,%IOBRK+1(CINDEX)
MOVEI TEMP,3
MOVEM TEMP,%IOBRK+6(CINDEX)
MOVSI TEMP,%SAVE ;DONE, RESTORE REGISTERS
BLT TEMP,5
MOVE TEMP,%IOOPN+1(CINDEX) ;WHAT ARE DEVICE CHARACTERISTICS
DEVCHR TEMP,
TLNN TEMP,40 ;IS DEVICE AVAILABLE TO JOB
JRST NOTAV
MOVE TEMP3,%IOOPN(CINDEX)
TRNE TEMP3,17 ;CHECK I/O MODE POSSIBLE
JRST .+6
TRNN TEMP,1 ;STRING I/O
JRST NOSTRG
JRST .+3
TRNN TEMP,10000 ;BITS I/O
JRST NOBITS
MOVE TEMP3,.jbUUO ;GO TO PROPER ROUTINE
TLNE TEMP3,40
JRST OPENO
JRST OPENI
NOTAV: MOVEI ERROR,[ASCIZ/OPEN - $: NOT AVAILABLE/]
JRST OPENER+1
NOSTRG: MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO STRING I/O@]
JRST OPENER+1
NOBITS: MOVE TEMP,%IOOPN(CINDEX)
TLNE TEMP,RECFLG ;IS RECORD I/O
JRST NORECD
MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO BITS I/O@]
JRST OPENER+1
NORECD: MOVEI ERROR,[ASCIZ@OPEN - $: CAN NOT DO RECORD I/O@]
JRST OPENER+1
UNKNOW: MOVEI ERROR,[ASCIZ/OPEN - UNRECOGNIZABLE FILE DESCRIPTOR/]
PUSHJ %P,%ERROR
EXIT
%OPENT: MOVE CHAN,-1(%P) ;GET CHANNEL NUMBER
POP %P,-1(%P) ;CLOSE UP STACK
JUMPL CHAN,CHANER
CAIL CHAN,^D16 ;0 <= CHAN < 16
JRST CHANER
IMULI CHAN,%IOSIZ ;GET INDEX INTO TABLES
SKIPGE %IOOPN(CHAN) ;OPEN FLAG IS SIGN BIT
AOS %UUO ;TRUE RETURN IF CHANNEL OPEN
POPJ %P,
PRGEND
TITLE %INOUT -- ALGOLW INPUT/OUTPUT ROUTINES -- MICHAEL GREEN
HISEG
ENTRY %READ,%WRITE,%EFILE,%BRK0,%BRK1,%GETLN,%PUTLN
ENTRY %GETBK,%CLRBK,%RDLST,%WRLST
EXTERN %IOOPN,%IOSIZ,%IOBRK,%ERROR,%ERRNM,%ERRSB,%IOLEB
EXTERN %ERRST,%SAVE,%XUUO,%UUO,%ERROC,%IOBFH
EXTERN .jbUUO
%P= 17
CHAN= 10
CINDEX= 11
BYTEPT= 12
LENGTH= 13
LINENO= 12
DIGIT= 13
TEMP2= 12
TEMP= 14
ERROR= 14
CHAR= 6
BFHD= 7
BYTE= 7
LNEFLG= 200000 ;FLAGS IN LH OF %IOOPN
INFLG= 040000
OUTFLG= 020000
BITFLG= 010000
STRFLG= 004000
INCHK: MOVE CINDEX,@.jbUUO ;GET CHANNEL NUMBER
JUMPGE CINDEX,INCHK2 ;CHECK FOR VALIDITY
ILLCHN: MOVEI ERROR,[ASCIZ/$ - ILLEGAL CHANNEL - $/]
PUSHJ %P,%ERROR
HLRZ ERROR,CHAN
PUSHJ %P,%ERRST
MOVE ERROR,CINDEX
PUSHJ %P,%ERRNM
EXIT
INCHK2: CAIL CINDEX,^D16
JRST ILLCHN
HRRI CHAN,(CINDEX) ;SET CHANNEL NUMBER
IMULI CINDEX,%IOSIZ ;GET INDEX INTO TABLES
SKIPGE TEMP,%IOOPN(CINDEX)
JRST .+4 ;CHECK CHANNEL OPEN
NOTOPN: MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN/]
MOVEI CINDEX,(CHAN)
JRST ILLCHN+1
TLNE TEMP,INFLG ;CHECK OPEN FOR INPUT
POPJ %P,
MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR INPUT/]
JRST NOTOPN+1
OUTCHK: MOVE CINDEX,@.jbUUO ;GET CHANNEL NUMBER
JUMPL CINDEX,ILLCHN ;CHECK FOR VALIDITY
CAIL CINDEX,^D16
JRST ILLCHN
HRRI CHAN,(CINDEX) ;SET CHANNEL NUMBER
IMULI CINDEX,%IOSIZ ;GET INDEX INTO TABLES
SKIPL TEMP,%IOOPN(CINDEX)
JRST NOTOPN ;CHECK CHANNEL OPEN
TLNE TEMP,OUTFLG
POPJ %P, ;CHECK OPEN FOR OUTPUT
MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR OUTPUT/]
JRST NOTOPN+1
%EFILE: HRLZI CHAN,[ASCIZ/ENDFILE/]
PUSHJ %P,INCHK ;SET UP
MOVE TEMP,[STATZ 020000]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;TEST FOR END OF FILE
AOS %UUO ;IF SO, SKIP RETURN
JRST %XUUO
%CLRBK: HRLZI CHAN,[ASCIZ/SETBREAK/]
PUSHJ %P,INCHK ;SET UP
TLNE TEMP,STRFLG ;CHECK STRING I/O
JRST .+3
BRKERR: MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
JRST NOTOPN+1
HRLI CINDEX,-7 ;SETUP FOR AOBJN THROUGH %IOBRK
SETZM %IOBRK(CINDEX)
AOBJN CINDEX,.-1 ;CLEAR BREAK TABLE
HRLOI TEMP,37777
ANDM TEMP,%IOBRK(CINDEX) ;ADDRESS NOW %IOBRK+7
JRST %XUUO ;EXIT
BRKSUP: HRLZI CHAN,[ASCIZ/SETBREAK/]
PUSHJ %P,INCHK ;SET UP
TLNN TEMP,STRFLG ;CHECK STRING I/O
JRST BRKERR
MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
MOVEM BYTE,%SAVE+BYTE
LDB TEMP,[POINT 4,.jbUUO,^D12]
HRLI TEMP,(TEMP) ;SAVE COPY OF AC FIELD
ANDCMI TEMP,1
MOVE BYTEPT,(TEMP) ;GET DV
MOVE LENGTH,1(TEMP)
ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LENGTH,LENGTH ; AND GET LENGTH
POPJ %P, ;DONE WITH BREAK SETUP
BRKCON: SOJL LENGTH,BRKXIT ;ACTUALLY FILL BREAK TABLE
ILDB CHAR,BYTEPT
IDIVI CHAR,^D18 ;GET WORD AND BYTE #
ADDI CHAR,%IOBRK(CINDEX)
DPB TEMP,BRKTBL(BYTE)
JRST BRKCON ;PROCESS NEXT
BRKXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
MOVE BYTE,%SAVE+BYTE
JRST %XUUO ;DONE
.TEMP== 1 ;SET UP BYTE POINTER TABLE
BRKTBL: REPEAT ^D18,
< POINT 2,(CHAR),.TEMP
.TEMP== .TEMP+2>
%BRK0: PUSHJ %P,BRKSUP ;SETUP
TLNN TEMP,1 ;AC ODD OR EVEN
SKIPA TEMP,[0]
MOVEI TEMP,2
JRST BRKCON ;SET VALUE ACCORDINGLY
%BRK1: PUSHJ %P,BRKSUP ;SETUP
TLNN TEMP,1 ;AC ODD OR EVEN
SKIPA TEMP,[1]
MOVEI TEMP,3
JRST BRKCON ;SET VALUE ACCORDINGLY
%RDLST:%WRLST:
MOVEI ERROR,[ASCIZ@RECORD I/O NOT IMPLEMENTED YET@]
PUSHJ %P,%ERROR
EXIT
%GETBK: HRLZI CHAN,[ASCIZ/BREAK/]
PUSHJ %P,INCHK ;SETUP
TLNN TEMP,STRFLG
JRST BRKERR ;CHECK STRING I/O
LDB TEMP,[POINT 4,.jbUUO,^D12]
TRZ TEMP,1
MOVE BYTEPT,(TEMP) ;GET DV
MOVE LENGTH,1(TEMP)
ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LENGTH,LENGTH ;GET LENGTH
LDB TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
SOJL LENGTH,%XUUO ;NULL STRING
IDPB TEMP,BYTEPT
JRST BREAK2+2 ;STORE IT AND ADJUST LENGTH OR PAD OUT
%GETLN: HRLZI CHAN,[ASCIZ/LINENO/]
PUSHJ %P,INCHK ;SETUP
TLNE TEMP,LNEFLG ;CHECK LINE NUMBER MODE
JRST .+3
LNEERR: MOVEI ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN WITH LINE NUMBERING/]
JRST NOTOPN+1
HRRE TEMP2,%IOBRK+7(CINDEX)
LDB TEMP,[POINT 4,.jbUUO,^D12]
MOVEM TEMP2,(TEMP) ;STORE VALUE
JRST %XUUO ;DONE
OUTPUT: SOSG 2(BFHD) ;OUTPUT A CHARACTER
JRST .+3
IDPB CHAR,1(BFHD)
POPJ %P, ;AND RETURN
MOVE TEMP,[OUT] ;OR GET BUFFER AND TRY AGAIN
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP
JRST OUTPUT+2
JUMPG CINDEX,.+2 ;ERROR ON TTY, FATAL
HALT
MOVEI ERROR,[ASCIZ/$ - $:$$$ OUTPUT ERROR - STATUS $/]
EDTSTS: PUSHJ %P,%ERROR
HLRZ ERROR,CHAN
PUSHJ %P,%ERRST
MOVE ERROR,%IOOPN+1(CINDEX)
PUSHJ %P,%ERRSB
MOVE ERROR,%IOLEB(CINDEX)
JUMPE ERROR,.+7 ;EDIT MESSAGE WITH OR WITHOUT FILE NAME
PUSHJ %P,%ERRSB
MOVEI ERROR,[ASCIZ/./]
PUSHJ %P,%ERRST
HLLZ ERROR,%IOLEB+1(CINDEX)
PUSHJ %P,%ERRSB
JRST .+7
MOVEI ERROR,0
PUSHJ %P,%ERRSB
MOVEI ERROR,0
PUSHJ %P,%ERRSB
MOVEI ERROR,0
PUSHJ %P,%ERRSB
MOVE ERROR,[GETSTS ERROR]
DPB CHAN,[POINT 4,ERROR,^D12]
XCT ERROR ;GET STATUS
PUSHJ %P,%ERROC
EXIT
%PUTLN: HLRZI CHAN,[ASCIZ/OUTLINE/]
PUSHJ %P,OUTCHK ;SETUP
TLNN TEMP,LNEFLG ;CHECK LINE NUMBERING
JRST LNEERR
MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
MOVEM BFHD,%SAVE+BFHD
LDB LINENO,[POINT 4,.jbUUO,^D12]
SKIPL LINENO,(LINENO) ;GET AND CHECK LINE NUMBER
JRST LNEOK
LNEVAL: MOVEI ERROR,[ASCIZ/OUTLINE - $ < 0 OR > 99999/]
PUSHJ %P,%ERROR
MOVE ERROR,LINENO
PUSHJ %P,%ERRNM
EXIT
LNEOK: CAILE LINENO,^D99999
JRST LNEVAL
HLRZ BFHD,%IOOPN+2(CINDEX)
LDB TEMP,[POINT 6,1(BFHD),5]
CAIE TEMP,1 ;GET OUTPUT ON WORD BOUNDARY
CAIN TEMP,^D36
JRST .+4
MOVEI CHAR,0
PUSHJ %P,OUTPUT ;OUTPUT NULLS UNTIL SO
JRST LNEOK+3
PUSHJ %P,LNEEDT ;OUTPUT LINE NUMBER
ORM LINENO,@1(BFHD) ;LINENO LEFT AS 1
MOVEI CHAR,011
PUSHJ %P,OUTPUT ;OUTPUT TAB AT END
JRST OUTXIT ;FORCE BUFFER OUT AND EXIT
LNEEDT: ADDI LINENO,^D100000 ;TO FORCE FIVE DIGITS
IDIVI LINENO,^D10
CAIN LINENO,1
JRST .+4
HRLM DIGIT,(%P) ;REGULAR EDITOR
PUSHJ %P,LNEEDT+1
HLRZ DIGIT,(%P)
MOVEI CHAR,"0"
ADDI CHAR,(DIGIT) ;MAKE ASCII
JRST OUTPUT ;OUTPUT WILL RETURN
%WRITE: HRLZI CHAN,[ASCIZ/OUT/]
PUSHJ %P,OUTCHK ;SETUP
MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
MOVEM BFHD,%SAVE+BFHD
LDB CHAR,[POINT 4,.jbUUO,^D12]
MOVE BYTEPT,(CHAR)
MOVE LENGTH,1(CHAR) ;GET DV
ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LENGTH,LENGTH ;GET LENGTH
HLRZ BFHD,%IOOPN+2(CINDEX)
LDB CHAR,[POINT 6,BYTEPT,^D11]
CAIN CHAR,1 ;SEE WHAT KIND OF BYTES
JRST CHKBIT
TLNE TEMP,STRFLG ;WANTS CHARACTERS
JRST OUTLP
MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
JRST NOTOPN+1
CHKBIT: TLNE TEMP,BITFLG ;WANTS BITS
JRST OUTLP
MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
JRST NOTOPN+1
OUTLP: SOJL LENGTH,OUTXIT ;DO ONE CHARACTER
ILDB CHAR,BYTEPT
PUSHJ %P,OUTPUT ;OUTPUT IT
JRST OUTLP
OUTXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
MOVE BFHD,%SAVE+BFHD
JUMPG CINDEX,%XUUO ;IF NOT CHANNEL 0, DONE
OUT 0,
AOSA %IOBFH+2 ;IF TTY, FORCE OUTPUT
HALT ;ERROR ON TTY FATAL
JRST %XUUO ;NOW DONE
INPUT: MOVE TEMP,[STATZ 020000]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;CHECK END FILE ALREADY
JRST FORCEF
SOSG 2(BFHD) ;INPUT A CHARACTER
JRST .+3
ILDB CHAR,1(BFHD)
POPJ %P, ;AND EXIT
MOVE TEMP,[IN] ;OR GET A BUFFER AND TRY AGAIN
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP
JRST INPUT+6
MOVE TEMP,[STATZ 020000]
DPB CHAN,[POINT 4,TEMP,^D12]
XCT TEMP ;CHECK END FILE
JRST .+5
JUMPG CINDEX,.+2
HALT ;ERROR ON TTY, FATAL
MOVEI ERROR,[ASCIZ/$ - $:$$$ INPUT ERROR - STATUS $/]
JRST EDTSTS
JUMPG CINDEX,FORCEF ;IF NOT TTY, FORCE END FILE CHAR
GETSTS 0,ERROR ;ELSE RESET END FILE
ANDI ERROR,757777
SETSTS 0,(ERROR)
JRST INPUT+4 ;^Z ALREADY RECEIVED
FORCEF: POP %P,TEMP ;DISCARD RETURN
MOVEI TEMP,032 ;FORCE ^Z BREAK CHARACTER
AOJA LENGTH,BREAK2+1
%READ: HRLZI CHAN,[ASCIZ/IN/]
PUSHJ %P,INCHK ;SETUP
MOVEM CHAR,%SAVE+CHAR ;SAVE REGISTERS
MOVEM BFHD,%SAVE+BFHD
HRRZ BFHD,%IOOPN+2(CINDEX)
LDB CHAR,[POINT 4,.jbUUO,^D12]
ANDI CHAR,16
MOVE BYTEPT,(CHAR) ;GET DV
MOVE LENGTH,1(CHAR)
ADDI BYTEPT,(LENGTH) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LENGTH,LENGTH ;AND GET LENGTH
LDB CHAR,[POINT 6,BYTEPT,^D11]
CAIE CHAR,1 ;SEE WHAT KIND OF BYTES
JRST RDCHAR
TLNE TEMP,BITFLG ;BITS EXPECTED
JRST .+3
MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
JRST NOTOPN+1
BITLP: SOJL LENGTH,INXIT ;PROCESS BITS
PUSHJ %P,INPUT ;GET A BIT
IDPB CHAR,BYTEPT ;STORE IT
JRST BITLP
INXIT: MOVE CHAR,%SAVE+CHAR ;RESTORE REGISTERS
MOVE BFHD,%SAVE+BFHD
JRST %XUUO ;DONE, EXIT
RDCHAR: TLNE TEMP,STRFLG ;CHARACTERS EXPECTED
JRST .+3
MOVEI ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
JRST NOTOPN+1
HRLZI TEMP,177 ;RESET BREAK CHARACTER
ANDCAM TEMP,%IOBRK+7(CINDEX)
CHARLP: SOJL LENGTH,INXIT
PUSHJ %P,INPUT ;GET A CHARACTER
JUMPE CHAR,.-1 ;IGNORE NULLS
MOVE TEMP,@1(BFHD) ;SEE IF LINE NUMBER
TRNN TEMP,1
JRST NOLINE ;NOPE
MOVE TEMP,%IOOPN(CINDEX)
TLNN TEMP,LNEFLG ;LINE NUMBER MODE
JRST NOLINE ;NOPE, JUST CHARACTERS
SUBI CHAR,"0"
HRRM CHAR,%IOBRK+7(CINDEX)
REPEAT 4,
< PUSHJ %P,INPUT
HRRZ TEMP,%IOBRK+7(CINDEX)
IMULI TEMP,^D10
ADDI TEMP,-"0"(CHAR)
HRRM TEMP,%IOBRK+7(CINDEX)>
PUSHJ %P,INPUT ;GOT LINE NUMBER, THROW AWAY TAB
JRST CHARLP+1 ;GET NEXT CHARACTER
NOLINE: MOVE TEMP,BFHD ;SAVE FOR DIVIDE
HRLI TEMP,(CHAR) ;SAVE POSSIBLE BREAK CHAR
IDPB CHAR,BYTEPT ;ASSUME WE WANT CHARACTER
IDIVI CHAR,^D18
EXCH TEMP,BFHD
ADDI CHAR,%IOBRK(CINDEX)
LDB TEMP,BRKTBL(TEMP)
JRST .+1(TEMP) ;GOT BREAK TYPE, DO IT
JRST CHARLP ;NORMAL CHARACTER
JRST BACKUP ;IGNORE CHARACTER
JRST BREAK2 ;IS BREAK CHARACTER
IBP BYTEPT ;IS BREAK CHARACTER TOO
IBP BYTEPT ; BUT BACKUP STUFF SO
IBP BYTEPT ; WILL NOT BE READ
IBP BYTEPT
SOJ BYTEPT,
AOJA LENGTH,BREAK2
BACKUP: IBP BYTEPT ;IGNORE CHARACTER
IBP BYTEPT
IBP BYTEPT
IBP BYTEPT
SOJA BYTEPT,CHARLP+1 ;GET NEXT
BREAK2: HLRZ TEMP,BFHD ;GET BREAK CHARACTER
DPB TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
LDB TEMP,[POINT 4,.jbUUO,^D12]
TRZN TEMP,1 ;AFTER STORING CHARACTER,
JRST PADOUT ;SEE IF SHOULD ADJUST LENGTH
HLRZ TEMP2,1(TEMP) ;OR PAD OUT WITH BLANKS
SUBI TEMP2,(LENGTH)
HRLM TEMP2,1(TEMP)
JRST INXIT ;ADJUSTED LENGTH, EXIT
PADOUT: MOVEI CHAR," "
SOJL LENGTH,INXIT ;PAD OUT WITH BLANKS
IDPB CHAR,BYTEPT
JRST PADOUT+1
PRGEND
TITLE %CLOSE -- ALGOLW FILE CLOSE ROUTINE -- MICHAEL GREEN
HISEG
ENTRY %CLOSE
EXTERN %IOOPN,%IOLEB,%IOPRO,%IOREG,%AVIOB
EXTERN %SREG,%NREG,%LREG,%ERROR,%ERRNM,%COLLE,%IOSIZ
EXTERN %XUUO,%ERRSB,%IOPP,%ERRST
EXTERN .jbUUO
%P= 17
CHAN= 10
CINDEX= 11
TEMP1= 12
TEMP2= 11
REGPT= 13
ERROR= 14
REWFLG= 002000 ;FLAGS IN LH OF %IOOPN
%CLOSE: MOVE CHAN,@.jbUUO ;GET CHANNEL NUMBER
JUMPG CHAN,CHANGR ;CHECK CHAN>0
MOVEI ERROR,[ASCIZ/CLOSE - ILLEGAL CHANNEL - $/]
PUSHJ %P,%ERROR
MOVE ERROR,CHAN
PUSHJ %P,%ERRNM ;EDIT ERROR MESSAGE
EXIT ;QUIT
CHANGR: CAIL CHAN,^D16 ;CHECK CHAN<16
JRST %CLOSE+2
MOVEI CINDEX,(CHAN) ;INDEX INTO TABLES
IMULI CINDEX,%IOSIZ
SKIPGE %IOOPN(CINDEX) ;IS CHANNEL OPEN?
JRST CHANOK
MOVEI ERROR,[ASCIZ/CLOSE - CHANNEL $ NOT OPEN/]
PUSHJ %P,%ERROR
MOVE ERROR,CHAN
PUSHJ %P,%ERRNM ;EDIT ERROR MESSAGE
EXIT ;QUIT
CHANOK: MOVE TEMP1,[CLOSE] ;CLOSE CHANNEL
DPB CHAN,[POINT 4,TEMP1,^D12]
XCT TEMP1
MOVE TEMP1,[STATZ 740000] ;CHECK CLOSE STATUS
DPB CHAN,[POINT 4,TEMP1,^D12]
XCT TEMP1
JRST CLOSER ;ERROR ON CLOSE
MOVE TEMP1,%IOOPN(CINDEX)
TLNN TEMP1,REWFLG ;UNLOAD ON CLOSE?
JRST RENAME
MOVE TEMP1,[MTAPE 11]
DPB CHAN,[POINT 4,TEMP1,^D12]
XCT TEMP1 ;YES, DO IT
RENAME: SKIPGE TEMP1,%IOPRO(CINDEX)
JRST NORENA ;SEE IF RENAME AFTER CLOSE
MOVE ERROR,%IOLEB(CINDEX)
MOVEM ERROR,%IOPRO(CINDEX) ;SAVE FILE NAME
CAIG TEMP1,777 ;IS FILE TO BE DELETED
JRST .+3
SETZM %IOLEB(CINDEX) ;YES
JRST .+2 ;ELSE JUST CHANGE PROTECTION
DPB TEMP1,[POINT ^D9,%IOLEB+2(CINDEX),^D8]
MOVE TEMP1,%IOPP(CINDEX)
MOVEM TEMP1,%IOLEB+3(CINDEX) ;RESTORE PROJ-PROG
RERE: MOVE TEMP1,[RENAME %IOLEB(CINDEX)]
DPB CHAN,[POINT 4,TEMP1,^D12]
XCT TEMP1
JRST RENERR ;ERROR ON RENAME
NORENA: MOVE TEMP1,[RELEAS] ;NOW RELEASE CHANNEL
DPB CHAN,[POINT 4,TEMP1,^D12]
XCT TEMP1
HRLOI TEMP1,377777 ;MARK AS CLOSED
ANDM TEMP1,%IOOPN(CINDEX)
MOVE REGPT,%IOREG(CINDEX) ;MERGE ADJACENT REGIONS
MOVE TEMP1,%NREG(REGPT)
MOVE TEMP2,%SREG(REGPT)
EXCH TEMP2,%SREG+1(REGPT)
SUBI TEMP2,1(TEMP1) ;SET UP BUFFER AS STORAGE BLOCK
HRLI TEMP2,400000
MOVSM TEMP2,(TEMP1)
MOVEI TEMP1,0
MOVEI TEMP2,^D16 ;ADJUST I/O REGION POINTERS
CAMGE REGPT,%IOREG(TEMP1)
SOS %IOREG(TEMP1) ;IS ABOVE MERGED REGION
ADDI TEMP1,%IOSIZ
SOJG TEMP2,.-3 ;DO NEXT
CLOREG: CAML REGPT,%AVIOB ;NOW MOVE OTHER AREAS DOWN
JRST ENDCLO
MOVE TEMP1,%SREG+1(REGPT)
MOVEM TEMP1,%SREG(REGPT)
MOVE TEMP1,%LREG+1(REGPT)
MOVEM TEMP1,%LREG(REGPT)
MOVE TEMP1,%NREG+1(REGPT)
MOVEM TEMP1,%NREG(REGPT)
AOJA REGPT,CLOREG
ENDCLO: SOS %AVIOB ;ONE LESS REGION
PUSHJ %P,%COLLE ;FORCE GARBAGE COLLECTION TO CLOSE
MOVEI TEMP1,0 ;FIND HOW MUCH FREE SPACE
MOVE REGPT,%AVIOB ; IN ALL BUT LAST REGION
JUMPE REGPT,.+3
ADD TEMP1,%LREG(REGPT)
SOJG REGPT,.-1
MOVEI TEMP2,0 ;ALLOW EXTRA 1K GROWTH SPACE IF <1K
CAIG TEMP1,1777
MOVEI TEMP2,2000
MOVE REGPT,%AVIOB
MOVE TEMP1,%NREG(REGPT)
ADD TEMP1,TEMP2 ;ALSO ALLOW TO NEXT 1K BOUNDARY
ORI TEMP1,1777
MOVE TEMP2,%NREG(REGPT)
SUBM TEMP1,TEMP2
ADDI TEMP2,1
MOVEM TEMP2,%LREG(REGPT) ;SET NEW FREE LENGTH
CORE TEMP1, ;ADJUST CORE BOUNDARY
JRST .+2
JRST %XUUO ;DONE, EXIT
MOVNI TEMP1,2000 ;TRIED TO GET AT MOST 1K
ADDB TEMP1,%LREG(REGPT)
ADD TEMP1,%NREG(REGPT)
SUBI TEMP1,1 ;MUST BE ABLE TO GET CORE WITHOUT
CORE TEMP1, ; EXTRA 1K
HALT
JRST %XUUO
CLOSER: MOVEI ERROR,[ASCIZ@CLOSE - $:$$$ I/O ERROR DURING CLOSE@]
PUSHJ %P,%ERROR
MOVE ERROR,%IOOPN+1(CINDEX)
PUSHJ %P,%ERRSB
MOVE ERROR,%IOLEB(CINDEX)
JUMPE ERROR,.+7
PUSHJ %P,%ERRSB
MOVEI ERROR,[ASCIZ/./]
PUSHJ %P,%ERRST
HLLZ ERROR,%IOLEB+1(CINDEX)
PUSHJ %P,%ERRSB
EXIT
MOVEI ERROR,0
PUSHJ %P,%ERRSB
MOVEI ERROR,0
PUSHJ %P,%ERRSB
MOVEI ERROR,0
PUSHJ %P,%ERRSB
EXIT ;PRINT MESSAGE, QUIT
RENERR: LDB TEMP1,[POINT ^D12,%IOLEB+1(CINDEX),^D35]
CAIN TEMP1,3 ;IS FILE IN USE, TRY AGAIN
JRST RERE
MOVEI ERROR,[ASCIZ@CLOSE - $:$.$ I/O ERROR ON PROTECTION CHANGE OR DELETE@]
PUSHJ %P,%ERROR
MOVE ERROR,CHAN
PUSHJ %P,%ERRNM
MOVE ERROR,%IOOPN+1(CINDEX)
PUSHJ %P,%ERRSB
MOVE ERROR,%IOPRO(CINDEX)
PUSHJ %P,%ERRSB
HLLZ ERROR,%IOLEB+1(CINDEX)
PUSHJ %P,%ERRSB
EXIT
PRGEND
TITLE %ALLOC -- ALGOLW STORAGE ALLOCATOR -- MICHAEL GREEN
HISEG
ENTRY %ARECD,%ASTRG,%ASTRA,%AARRY,%RARRY,%PROC,%BLOCK,%THUNK
EXTERN %COLLE,%STAT,%NREG,%LREG,%AVIOB,%ERROR
EXTERN %SAVE,%XUUO,%UUO,%ERRNM,%HDBLK
EXTERN .jbUUO
%T= 14
%B= 16
%P= 17
SIZE= 6
HEADER= 7
REGPT= 10
ARGCNT= 10
TEMP= 11
TEMP2= 12
TEMP3= 13
ERROR= 14
RESULT= 14
ARGTYP= 14
ALLOC: AOS %STAT+3 ;INCREMENT CALL COUNTS
AOS %STAT+30
MOVEI TEMP,0
RUNTIM TEMP, ;CALCULATE TIME SINCE LAST CALL
SUBM TEMP,%STAT
EXCH TEMP,%STAT
ADDM TEMP,%STAT+10 ;TOTAL TIME BETWEEN CALLS
CAMLE TEMP,%STAT+11 ;MAX TIME BETWEEN CALLS
MOVEM TEMP,%STAT+11
ADDM SIZE,%STAT+25 ;REQUESTS SINCE LAST COLLE
ADDM SIZE,%STAT+5 ;TOTAL REQUESTS
CAMLE SIZE,%STAT+6
MOVEM SIZE,%STAT+6 ;MAX REQUEST
MOVE TEMP,%STAT+7
ADDI TEMP,(SIZE) ;CUMULATIVE AVERAGE REQUEST
LSH TEMP,-1
MOVEM TEMP,%STAT+7
MOVEI REGPT,0
ALLOCL: CAMG SIZE,%LREG(REGPT);LOOK FOR SPACE IN REGIONS
JRST FOUNDS
CAMGE REGPT,%AVIOB ;NOT IN THAT ONE, TRY NEXT
AOJA REGPT,ALLOCL
;****************************************************************
PUSHJ %P,%COLLE ;TEMPORARY DECISION ALGORITHM
MOVEI REGPT,0 ;COLLECT AND SEARCH FOR ROOM NOW
MOVEI TEMP,0 ;ALSO SEE HOW MUCH ROOM IF CAN'T FIT
ALLOC2: CAMG SIZE,%LREG(REGPT)
JRST FOUND2 ;FOUND SPACE, GO FREE UP EXTRA SPACE
ADD TEMP,%LREG(REGPT)
CAMGE REGPT,%AVIOB
AOJA REGPT,ALLOC2 ;TRY NEXT REGION
CAIL TEMP,2000 ;AT LEAST 1K FREE
SKIPA TEMP,[0]
MOVEI TEMP,2000
MOVEI TEMP3,(TEMP)
ADDI TEMP,(SIZE)
ADD TEMP,%NREG(REGPT);FIND NEW END OF STORAGE
ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
MOVE TEMP2,%NREG(REGPT)
SUBM TEMP,TEMP2 ;GET NEW %LREG
ADDI TEMP2,1
MOVEM TEMP2,%LREG(REGPT)
CORE TEMP,
JRST .+2 ;ERROR, NO MORE CORE
JRST FOUNDS ;OK, ALLOCATE BLOCK
JUMPE TEMP3,QUIT ;CAN WE GIVE UP 1K PADDING
MOVNI TEMP,2000
ADDB TEMP,%LREG(REGPT)
ADD TEMP,%NREG(REGPT)
SUBI TEMP,1
CORE TEMP,
JRST QUIT ;I GUESS NOT
JRST FOUNDS
FOUND2: MOVE TEMP3,REGPT ;TOTAL UP ROOM IN REST OF REGIONS
ADD TEMP,%LREG(TEMP3)
CAMGE TEMP3,%AVIOB
AOJA TEMP3,.-2
CAIL TEMP,2000(SIZE) ;DON'T COUNT SIZE
JRST FOUNDS
MOVEI TEMP,2000 ;ALLOW 1K GROWTH ROOM
ADD TEMP,%NREG(TEMP3);FIND NEW END OF STORAGE
ORI TEMP,1777 ;ROUND UP TO 1K BOUNDARY
MOVE TEMP2,%NREG(TEMP3)
SUBM TEMP,TEMP2 ;GET NEW %LREG
ADDI TEMP2,1
MOVEM TEMP2,%LREG(TEMP3)
CORE TEMP,
JRST .+2 ;ERROR, NO MORE CORE
JRST FOUNDS ;OK, ALLOCATE BLOCK
MOVNI TEMP,2000 ;CAN WE GIVE UP 1K PADDING
ADDB TEMP,%LREG(TEMP3)
ADD TEMP,%NREG(TEMP3)
SUBI TEMP,1
CORE TEMP,
JRST QUIT ;I GUESS NOT
JRST FOUNDS
QUIT: MOVEI ERROR,[ASCIZ/REQUEST FOR STORAGE, NONE AVAILABLE/]
PUSHJ %P,%ERROR
EXIT
;*****************************************************************
FOUNDS: MOVNI TEMP,(SIZE) ;ADJUST REGION FOR ALLOCATED SPACE
ADDM TEMP,%LREG(REGPT)
MOVE RESULT,%NREG(REGPT)
ADDM SIZE,%NREG(REGPT)
MOVSM HEADER,(RESULT) ;INITIALIZE STORAGE AREA
SETZM 1(RESULT)
MOVEI TEMP,2(RESULT) ;SET UP FOR BLT
HRLI TEMP,1(RESULT)
ADDI SIZE,-1(RESULT)
CAILE SIZE,(TEMP) ;SKIP IF ONLY ONE WORD
BLT TEMP,(SIZE) ;CLEAR BLOCK
MOVEI TEMP,0
RUNTIM TEMP, ;CALCULATE TIME IN ALLOCATOR
SUBM TEMP,%STAT
EXCH TEMP,%STAT
ADDM TEMP,%STAT+12 ;TOTAL TIME IN ALLOCATOR
CAMLE TEMP,%STAT+13 ;MAX TIME IN ALLOCATOR
MOVEM TEMP,%STAT+13
MOVE SIZE,%SAVE+SIZE ;RESTORE SIZE AND HEADER
MOVE HEADER,%SAVE+HEADER
ADDI RESULT,1 ;POINTER PAST HEADER
POPJ %P, ;DONE, EXIT
%ARECD: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
HRRZ HEADER,.jbUUO ;GET DESCRIPTOR ADDRESS
HLRZ SIZE,(HEADER) ;AND AREA SIZE
ADDI SIZE,1 ;ACCOUNT FOR HEADER
PUSHJ %P,ALLOC ;ALLOCATE CORE
LDB TEMP,[POINT 4,.jbUUO,^D12]
MOVEM RESULT,(TEMP)
JRST %XUUO ;AND EXIT
%RARRY: SKIPA TEMP,[XWD 400000,400000] ;REFERENCE ARRAY HEADER
%AARRY: MOVSI TEMP,400000 ;NON-REFERENCE ARRAY HEADER
MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
MOVE HEADER,TEMP ;GET HEADER CONTROL BITS
LDB TEMP,[POINT 4,.jbUUO,^D12] ;GET NO. OF DIMENSIONS
HRRZ TEMP2,.jbUUO ;AND DOPE VECTOR ADDRESS
HLRZ SIZE,1(TEMP2) ;GET LENGTH (IN WORDS)
MOVEM SIZE,2(TEMP2) ;AND SET UP DIMENSION UNITS
ARRYL: MOVE SIZE,4(TEMP2) ;UPPER BOUND
SUB SIZE,3(TEMP2) ; - LOWER BOUND
AOJLE SIZE,NEGDIM ; + 1 = SIZE OF DIMENSION > 0
MOVEM SIZE,4(TEMP2) ;SAVE IT FOR SUBSCRIPT CALCULATIONS
IMUL SIZE,2(TEMP2) ; * DIMENSION UNITS
CAIE TEMP,1
MOVEM SIZE,5(TEMP2) ; = NEW DIMENSION UNITS
ADDI TEMP2,3 ;NEXT DIMENSION
SOJG TEMP,ARRYL
ADDI SIZE,1 ;ALLOW FOR HEADER
CAIL SIZE,400000 ;MAXIMUM STORAGE ALLOWED
JRST TOOBIG
ADDI HEADER,-1(SIZE) ;FINISH UP HEADER
PUSHJ %P,ALLOC ;ALLOCATE STORAGE
MOVE TEMP,%UUO
MOVEI TEMP,@-1(TEMP) ;ADDRESS MUST BE INDEXED BY %TB OR %B
HRRM RESULT,1(TEMP) ; OR BE IN ABSOLUTE LOCATION
JRST %XUUO ;DONE, EXIT
%ASTRA: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
LDB TEMP,[POINT 4,.jbUUO,^D12] ;GET NO. OF DIMENSIONS
HRRZ TEMP2,.jbUUO ;AND DOPE VECTOR ADDRESS
HLRE SIZE,1(TEMP2) ;GET LENGTH (IN BYTES)
JUMPL SIZE,NEGLEN ; TEST > 0
MOVEM SIZE,2(TEMP2) ;AND SET UP DIMENSION UNITS
SARRYL: MOVE SIZE,4(TEMP2) ;UPPER BOUND
SUB SIZE,3(TEMP2) ; - LOWER BOUND
AOJLE SIZE,NEGDIM ; + 1 = SIZE OF DIMENSION > 0
MOVEM SIZE,4(TEMP2) ;SAVE IT FOR SUBSCRIPT CALCULATIONS
IMUL SIZE,2(TEMP2) ; * DIMENSION UNITS
CAIE TEMP,1
MOVEM SIZE,5(TEMP2) ; = NEW DIMENSION UNITS
ADDI TEMP2,3
SOJG TEMP,SARRYL ;NEXT DIMENSION
JRST STRING ;SIZE IN BYTES, PROCESS LIKE STRING
%ASTRG: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
HRRZ TEMP,.jbUUO ;GET DOPE VECTOR ADDRESS
HLRE SIZE,1(TEMP) ;AND LENGTH (IN BYTES)
JUMPL SIZE,NEGLEN ; TEST > 0
STRING: JUMPG SIZE,.+4 ;TEST FOR NULL STRING
MOVE SIZE,%SAVE+SIZE ;RESTORE REGISTER
MOVEI RESULT,0 ;NULL POINTER
JRST STRSTO
LDB TEMP2,[POINT 6,@.jbUUO,^D11] ;GET BYTE SIZE
MOVEI TEMP,^D36 ;HOW MANY PER WORD?
IDIVI TEMP,(TEMP2)
ADDI SIZE,-1(TEMP) ;PAD OUT TO END OF WORD
IDIVI SIZE,(TEMP) ;NUMBER OF WORDS
ADDI SIZE,1 ; + 1 FOR HEADER
CAIL SIZE,400000 ;TEST MAXIMUM SIZE
JRST TOOBIG
MOVEI HEADER,-1(SIZE) ;SET UP HEADER
TLO HEADER,400000 ;NON-REFERENCE STORAGE
PUSHJ %P,ALLOC ;ALLOCATE STORAGE
STRSTO: MOVE TEMP,%UUO ;DOPE VECTOR MUST BE INDEXED
MOVEI TEMP,@-1(TEMP) ; BY %TB OR %B OR BE IN ABSOLUTE LOCATION
HRRM RESULT,1(TEMP) ;STORE POINTER
JRST %XUUO ;AND EXIT
NEGDIM: MOVEI ERROR,[ASCIZ/ARRAY DECLARATION - LOWER BOUND $ > UPPER BOUND $/]
PUSHJ %P,%ERROR
MOVE ERROR,3(TEMP2)
PUSHJ %P,%ERRNM
MOVE ERROR,4(TEMP2)
PUSHJ %P,%ERRNM
EXIT
TOOBIG: MOVEI ERROR,[ASCIZ/ARRAY DECLARATION - ARRAY TOO LARGE/]
PUSHJ %P,%ERROR
EXIT
NEGLEN: MOVEI ERROR,[ASCIZ/STRING DECLARATION - LENGTH $ < 0/]
PUSHJ %P,%ERROR
MOVE ERROR,SIZE
PUSHJ %P,%ERRNM
EXIT
%BLOCK: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
HRRZ HEADER,.jbUUO ;GET DESCRIPTOR ADDRESS
HLRZ SIZE,(HEADER) ;AND SIZE
ADDI SIZE,1 ;ACCOUNT FOR HEADER
PUSHJ %P,ALLOC ;ALLOCATE STORAGE FOR BLOCK
EXCH RESULT,%B ;SET NEW BASE
MOVEM RESULT,(%B) ;AND SAVE OLD ONE
HRRZ TEMP,.jbUUO ;GET DISPLAY SIZE
HLRZ TEMP,-1(TEMP)
JUMPE TEMP,%XUUO ;NO DISPLAY
SOJG TEMP,.+3
MOVEM RESULT,3(%B) ;CALLER LEVEL ONLY
JRST %XUUO
MOVEI TEMP2,3(%B) ;OTHER LEVELS TOO, MOVE THEM
HRLI TEMP2,3(RESULT) ; FROM CALLER'S DISPLAY
ADDI TEMP,2(%B)
BLT TEMP2,(TEMP)
MOVEM RESULT,1(TEMP) ;ALSO CALLER LEVEL
JRST %XUUO ;EXIT
%THUNK: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
HRRZ HEADER,.jbUUO ;GET DESCRIPTOR ADDRESS
HLRZ SIZE,(HEADER) ;AND SIZE
ADDI SIZE,1 ;ACCOUNT FOR HEADER
PUSHJ %P,ALLOC ;ALLOCATE STORAGE FOR THUNK
EXCH RESULT,%B ;SET NEW BASE
MOVEM RESULT,(%B) ;AND SAVE OLD ONE
MOVE %T,%HDBLK+3 ;RESTORE THUNK BASE SAVED BY %UUOTB
POP %P,1(%B) ;SAVE THUNK RETURN ADDRESS
HRRZ TEMP,.jbUUO ;GET DISPLAY SIZE
HLRZ TEMP,-1(TEMP)
SOJG TEMP,.+3
MOVEM %T,3(%B) ;THUNK IMMEDIATE CONTEXT ONLY
JRST %XUUO
MOVEI TEMP2,3(%B) ;OTHER LEVELS, MOVE THEM
HRLI TEMP2,3(%T) ; FROM THUNK IMMEDIATE CONTEXT DISPLAY
ADDI TEMP,2(%B)
BLT TEMP2,(TEMP)
MOVEM %T,1(TEMP) ;ALSO THUNK IMMEDIATE CONTEXT
JRST %XUUO ;EXIT
%PROC: MOVEM SIZE,%SAVE+SIZE ;SAVE REGISTERS
MOVEM HEADER,%SAVE+HEADER
HRRZ HEADER,.jbUUO ;GET DESCRIPTOR ADDRESS
HLRZ SIZE,(HEADER) ;AND SIZE
ADDI SIZE,1 ;ACCOUNT FOR HEADER
PUSHJ %P,ALLOC ;ALLOCATE STORAGE
EXCH RESULT,%B ;SET NEW BASE
MOVEM RESULT,(%B) ;AND SAVE OLD ONE
POP %P,1(%B) ;SAVE PROCEDURE RETURN ADDRESS
POP %P,2(%B) ;AND ARGUMENT LIST POINTER
HRRZ TEMP,.jbUUO ;GET DISPLAY SIZE
HLRZ TEMP2,-1(TEMP)
JUMPE TEMP2,CHKARG ;NO DISPLAY
HLRZ TEMP3,-1(RESULT)
HLRZ TEMP3,-1(TEMP3) ;GET PREVIOUS DISPLAY SIZE
CAIL TEMP3,(TEMP2)
JRST .+4 ;IF NOT EXPANDING, JUST COPY
ADDI TEMP3,3(%B)
MOVEM RESULT,(TEMP3) ;ELSE ADD PREVIOUS LEVEL POINTER
SOJE TEMP2,CHKARG ;IF ANY ROOM LEFT, COPY STUFF
MOVEI TEMP3,3(%B) ;OTHER LEVELS, MOVE THEM
HRLI TEMP3,3(RESULT) ; FROM CALLER'S DISPLAY
ADDI TEMP2,2(%B)
BLT TEMP3,(TEMP2)
CHKARG: HLRZ TEMP,-2(TEMP) ;GET ADDRESS OF ARGUMENT TYPES
JUMPE TEMP,%XUUO ;IF ZERO, DON'T BOTHER CHECKING
MOVE TEMP2,2(%B) ;GET ARGUMENT LIST POINTER
JUMPGE TEMP2,%XUUO ;IF NOT NEGATIVE, NO CHECKING
HRLI TEMP,(POINT ^D9,0) ;MAKE BYTE POINTER TO TYPES
HLRZ ARGCNT,TEMP2 ;GET ARGUMENT COUNT
LSH ARGCNT,-5
ANDI ARGCNT,17
CHKLP: ILDB ARGTYP,TEMP ;GET EXPECTED ARGUMENT TYPE
SOJL ARGCNT,CHKEND ;IS PROCEDURE VALUE TYPE
TRNE ARGTYP,400 ;EXPECT PROCEDURE VALUE TYPE
JRST CNTERR ;NO MATCH, MISMATCHED COUNT
HLRZ TEMP3,(TEMP2) ;GET PROVIDED TYPE
LSH TEMP3,-^D9
ADDI TEMP2,4 ;POINT TO NEXT ARGUMENT TYPE
CAIN ARGTYP,(TEMP3) ;COMPARE TYPES
JRST CHKLP ;OK, TRY NEXT
MOVEI ERROR,[ASCIZ/IMPROPER TYPE ARGUMENT SUPPLIED TO PROCEDURE/]
PUSHJ %P,%ERROR
EXIT
CHKEND: TRNN ARGTYP,400 ;PROCEDURE VALUE TYPE EXPECTED
JRST CNTERR
HLRZ TEMP2,TEMP2 ;GET PROCEDURE VALUE TYPE EXPECTED
LSH TEMP2,-^D9
CAIN ARGTYP,(TEMP2) ;COMPARE TYPES
JRST %XUUO ;OK, DONE
MOVEI ERROR,[ASCIZ/IMPROPER TYPE PROCEDURE VALUE EXPECTED/]
PUSHJ %P,%ERROR
EXIT
CNTERR: MOVEI ERROR,[ASCIZ/IMPROPER NUMBER OF ARGUMENTS SUPPLIED TO PROCEDURE/]
PUSHJ %P,%ERROR
EXIT
PRGEND
TITLE %COLLE -- ALGOLW GARBAGE COLLECTOR -- MICHAEL GREEN
HISEG
ENTRY %COLLE
EXTERN %SREG,%LREG,%NREG,%ALREG,%ANREG,%AVIOB
EXTERN %HDBLK,%MARK,%STAT,%DYNAM
%TB= 15
%B= 16
%P= 17
DIMCNT= 6
TEMP= 7
REGPT= 10
HEADER= 11
VCOUNT= 12
SIZE= 12
VPOINT= 13
AREGPT= 13
FREED= 13
POINTR= 14
%COLLE: PUSH %P,TEMP ;SAVE TEMP
PUSH %P,DIMCNT ; AND DIMCNT
AOS %STAT+4 ;INCREMENT CALL COUNT
MOVEI TEMP,0
RUNTIM TEMP, ;FIND RUNTIM
SUBM TEMP,%STAT+1 ;GET DIFFERENCE
EXCH TEMP,%STAT+1
ADDM TEMP,%STAT+17 ;TOTAL RUNTIM BETWEEN CALLS
CAMLE TEMP,%STAT+20
MOVEM TEMP,%STAT+20 ;MAX RUNTIM BETWEEN CALLS
MOVE TEMP,%STAT+25
SETZM %STAT+25 ;RESET REQUESTS SINCE LAST COLLE
CAMLE TEMP,%STAT+26 ;MAX REQUESTS SINCE LAST COLLE
MOVEM TEMP,%STAT+26
ADD TEMP,%STAT+27 ;CUMULATIVE AVERAGE OF
LSH TEMP,-1 ; REQUESTS SINCE LAST COLLE
MOVEM TEMP,%STAT+27
SETZM %STAT+30 ;RESET ALLOC COUNT SINCE LAST COLLE
HRRZM %TB,%HDBLK+1 ;SET %TB AND %B IN %HDBLK FOR
HRRZM %B,%HDBLK+2 ; POINTERS INTO THE LIST STRUCTURE
PUSHJ %P,%MARK ;MARK ALL ACCESSABLE LIST NODES
MOVEI REGPT,0
INITA: MOVE TEMP,%NREG(REGPT) ;INITIALIZE %ALREG AND %ANREG
SUB TEMP,%SREG(REGPT) ;TO REGION LENGTH AND
ADD TEMP,%LREG(REGPT) ;START RESPECTIVELY
MOVEM TEMP,%ALREG(REGPT)
MOVE TEMP,%SREG(REGPT)
MOVEM TEMP,%ANREG(REGPT)
CAMGE REGPT,%AVIOB ;SET NEXT REGION
AOJA REGPT,INITA
MOVEI REGPT,0 ;SETUP FOR STORAGE REALLOCATION
HRROI TEMP,400000 ;MASK
ALLREG: MOVE HEADER,%SREG(REGPT) ;GET START OF REGION
NXTCEL: CAML HEADER,%NREG(REGPT) ;END OF REGION?
JRST NXTREG
MOVS SIZE,(HEADER) ;GET BLOCK HEADER
TLZN SIZE,400000 ;SEE IF THIS IS SIZE
HLR SIZE,(SIZE)
TRZ SIZE,400000 ;KILL TYPE BIT
ADDI SIZE,1
TLZN SIZE,377777 ;IF NOT MARKED, SKIP IT
JRST ADVCEL
MOVEI AREGPT,0 ;LOOK FOR REGION IT CAN FIT INTO
CAMLE SIZE,%ALREG(AREGPT)
AOJA AREGPT,.-1 ;MUST FIND ONE
MOVE POINTR,%ANREG(AREGPT) ;GET NEW ADDRESS
MOVN SIZE,SIZE ;ADJUST AVAILABLE LENGTH
ADDM SIZE,%ALREG(AREGPT)
MOVN SIZE,SIZE
ADDM SIZE,%ANREG(AREGPT) ;AND AVAILABLE LOCATION
ANDM TEMP,(HEADER) ;STORE IT
ORM POINTR,(HEADER)
ADVCEL: ADDI HEADER,(SIZE) ;TRY NEXT BLOCK
JRST NXTCEL
NXTREG: CAMGE REGPT,%AVIOB ;TRY NEXT REGION
AOJA REGPT,ALLREG
MOVEI REGPT,0 ;SETUP FOR REASSIGNMENT OF ADDR
REASNR: MOVE HEADER,%SREG(REGPT) ;GET START OF REGION
REASNB: CAML HEADER,%NREG(REGPT) ;IS END OF REGION
JRST ASNREG
MOVS VCOUNT,(HEADER) ;GET BLOCK HEADER
TLZN VCOUNT,377777 ;IF NOT MARKED, SKIP IT
JRST NXTBLK
TLZN VCOUNT,400000 ;IF RECORD, PROCESS
JRST RECORD
TRZN VCOUNT,400000 ;IF NON-REFERENCE, SKIP IT
JRST NXTBLK
MOVEI VPOINT,1(HEADER);SET UP TO SCAN POINTERS
REASRV: SOJL VCOUNT,NXTBLK ;CONTINUE WHILE SIZE>0
HRRE POINTR,(VPOINT) ;DON'T CHANGE POINTERS TO HISEG
JUMPLE POINTR,REASNV
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST REASNV
MOVE TEMP,-1(POINTR)
ANDI TEMP,377777
ADDI TEMP,1
HRRM TEMP,(VPOINT) ;CHANGE POINTER
REASNV: AOJA VPOINT,REASRV ;TRY NEXT
RECORD: MOVEI VPOINT,1(HEADER);SET UP FOR RECORD ADJUSTING
HLLZ TEMP,1(VCOUNT) ;IF REFERENCE VALUES,
JUMPE TEMP,NOREFV
SUB VPOINT,TEMP ;SET UP AOBJN AC
RECRVL: HRRE POINTR,(VPOINT) ;DON'T CHANGE POINTERS TO HISEG
JUMPLE POINTR,RECRVN
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST RECRVN
MOVE TEMP,-1(POINTR)
ANDI TEMP,377777
ADDI TEMP,1
HRRM TEMP,(VPOINT) ;CHANGE POINTER
RECRVN: AOBJN VPOINT,RECRVL ;TRY NEXT
NOREFV: HRRZ DIMCNT,1(VCOUNT);GET NUMBER OF DV'S
HRLI VCOUNT,(POINT 4,0)
ADDI VCOUNT,2 ;MAKE VCOUNT INTO BYTE POINTER
ARRYDV: SOJL DIMCNT,NXTBLK ;DONE WHEN NO MORE DV'S
ILDB TEMP,VCOUNT ;GET DIMENSION SIZE
IMULI TEMP,3
HRRE POINTR,1(VPOINT);DON'T CHANGE ANY POINTERS TO HISEG
JUMPLE POINTR,ARRYND
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST ARRYND
MOVE POINTR,-1(POINTR)
ANDI POINTR,377777
ADDI POINTR,1
HRRM POINTR,1(VPOINT);CHANGE POINTER
ARRYND: ADDI VPOINT,2(TEMP) ;AND TRY NEXT
JRST ARRYDV
NXTBLK: MOVS SIZE,(HEADER) ;SKIP TO NEXT BLOCK
TLNN SIZE,400000 ;SEE IF THIS IS SIZE
HLR SIZE,(SIZE)
ANDI SIZE,377777 ;TRIM OFF CONTROL BITS
ADDI HEADER,1(SIZE)
JRST REASNB
ASNREG: CAMGE REGPT,%AVIOB ;PROCESSED ALL REGIONS?
AOJA REGPT,REASNR
HLRZ SIZE,%HDBLK ;ADJUST %HDBLK POINTERS
ANDI SIZE,377777 ;SETUP AOBJN POINTER
MOVN SIZE,SIZE
HRLZI SIZE,(SIZE)
HRRI SIZE,%HDBLK+1
HDBLKL: HRRE TEMP,(SIZE) ;ADJUST POINTER
JUMPLE TEMP,.+7 ;IF NOT POINTING TO HISEG
CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
JRST .+5
HRRZ TEMP,-1(TEMP)
ANDI TEMP,377777 ;GET RID OF CONTROL BIT
ADDI TEMP,1
HRRM TEMP,(SIZE) ;AND STORE NEW POINTER
AOBJN SIZE,HDBLKL ;GO FOR NEXT
HRRE TEMP,%TB ;ADJUST %TB
JUMPLE TEMP,.+6 ;IF NOT POINTING TO HISEG
CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
JRST .+4
HRR %TB,-1(%TB)
TRZ %TB,400000 ;CLEAR CONTROL BIT
ADDI %TB,1
HRRE TEMP,%B ;ADJUST %B
JUMPLE TEMP,.+6 ;IF NOT POINTING TO HISEG
CAMG TEMP,%DYNAM ; AND NOT BELOW %DYNAM
JRST .+4
HRR %B,-1(%B)
TRZ %B,400000 ;CLEAR CONTROL BIT
ADDI %B,1
MOVEI REGPT,0 ;SETUP FOR MOVE OF BLOCKS
MOVEI FREED,0 ;HOW MUCH WAS FREED BY COLLECTING?
MOVENR: MOVE HEADER,%SREG(REGPT) ;START OF REGION
HRROI TEMP,400000 ;GET MASK TO UNMARK BLOCKS
MOVENB: CAML HEADER,%NREG(REGPT) ;IS END OF REGION?
JRST MOVEAR
MOVE POINTR,(HEADER) ;GET NEW ADDRESS
ANDI POINTR,377777
JUMPE POINTR,MOVEAB ;IF ZERO, IGNORE
ANDM TEMP,(HEADER) ;UNMARK BLOCK
CAIL POINTR,(HEADER) ;DON'T MOVE IF IN SAME PLACE
JRST MOVEAB
HRLI POINTR,(HEADER) ;SET BLT SOURCE
MOVS SIZE,(HEADER) ;GET BLOCK DESCRIPTOR
TLNN SIZE,400000 ;SEE IF THIS IS SIZE
HLR SIZE,(SIZE)
ANDI SIZE,377777 ;CLEAR CONTROL BITS
ADDI HEADER,1(SIZE) ;ADVANCE TO NEXT BLOCK
ADDI SIZE,(POINTR) ;SET BLT END DESTINATION
BLT POINTR,(SIZE) ;MOVE BLOCK
JRST MOVENB ;TRY NEXT ONE
MOVEAB: MOVS SIZE,(HEADER) ;GET BLOCK DESCRIPTOR
TLNN SIZE,400000 ;SEE IF THIS IS SIZE
HLR SIZE,(SIZE)
ANDI SIZE,377777 ;CLEAR CONTROL BITS
ADDI HEADER,1(SIZE) ;ADVANCE TO NEXT BLOCK
JRST MOVENB
MOVEAR: ADD FREED,%ALREG(REGPT) ;FREED STORAGE IN EACH REGION
SUB FREED,%LREG(REGPT)
MOVE TEMP,%ALREG(REGPT) ;SET NEW %LREG
MOVEM TEMP,%LREG(REGPT)
MOVE TEMP,%ANREG(REGPT) ;AND NEW %NREG
MOVEM TEMP,%NREG(REGPT)
CAMGE REGPT,%AVIOB ;ANY MORE REGIONS?
AOJA REGPT,MOVENR
ADDM FREED,%STAT+14 ;TOTAL FREED STORAGE
CAMLE FREED,%STAT+15
MOVEM FREED,%STAT+15 ;MAX FREED STORAGE
ADD FREED,%STAT+16
LSH FREED,-1 ;CUMULATIVE AVERAGE
MOVEM FREED,%STAT+16 ; OF FREED STORAGE
MOVEI TEMP,0
RUNTIM TEMP, ;FIND RUNTIM
SUBM TEMP,%STAT+1 ;GET DIFFERENCE
EXCH TEMP,%STAT+1
ADDM TEMP,%STAT+21 ;TOTAL RUNTIM IN COLLE
CAMLE TEMP,%STAT+22
MOVEM TEMP,%STAT+22 ;MAX RUNTIM IN COLLE
POP %P,DIMCNT
POP %P,TEMP ;RESTORE TEMP AND DIMCNT
POPJ %P, ;DONE, EXIT
PRGEND
TITLE %MARK -- ALGOLW LIST CELL MARKER -- MICHAEL GREEN
HISEG
ENTRY %MARK
EXTERN %HDBLK,%DYNAM
%P= 17
DIMCNT= 6
TEMP= 7
TOP= 10
HEADER= 11
VCOUNT= 12
VPOINT= 13
POINTR= 14
%MARK: PUSH %P,TEMP ;SAVE TEMP
PUSH %P,DIMCNT ;AND DIMCNT
MOVEI TOP,%HDBLK+1 ;INITIALIZE PUSH DOWN LIST
POPSTK: MOVEI HEADER,(TOP) ;POP TOP ENTRY
CAIN HEADER,1
JRST MARKEX ;ONE MEANS DONE (RH OF %HDBLK)
HRRZ TOP,-1(TOP)
ANDI TOP,377777
MOVS VCOUNT,-1(HEADER) ;GET BLOCK HEADER
TLNN VCOUNT,400000 ;SEE IF RECORD
JRST RECORD
TRNN VCOUNT,400000 ;IF NON-REFERENCE ARRAY, TRY NEXT
JRST POPSTK
MOVEI VPOINT,(HEADER) ;SET UP FOR SCAN OF VALUES
ANDI VCOUNT,377777
MARKRV: SOJL VCOUNT,POPSTK ;CONTINUE WHILE SIZE>0
HRRE POINTR,(VPOINT) ;DON'T MARK ANY POINTERS TO HISEG
JUMPLE POINTR,MARKNV
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST MARKNV
MOVE TEMP,-1(POINTR)
TRNE TEMP,377777 ;IS IT MARKED ALREADY
JRST MARKNV
ORM TOP,-1(POINTR)
MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
MARKNV: AOJA VPOINT,MARKRV ;TRY NEXT
RECORD: MOVEI VPOINT,(HEADER) ;SET UP FOR RECORD MARKING
HLLZ TEMP,1(VCOUNT) ;IF REFERENCE VALUES,
JUMPE TEMP,NOREFV ; SET UP AOBJN AC
SUB VPOINT,TEMP
RECRFV: HRRE POINTR,(VPOINT) ;DON'T MARK ANY POINTERS TO HISEG
JUMPLE POINTR,RECRNV
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST RECRNV
MOVE TEMP,-1(POINTR) ;IS IT MARKED ALREADY
TRNE TEMP,377777
JRST RECRNV
ORM TOP,-1(POINTR)
MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
RECRNV: AOBJN VPOINT,RECRFV ;AND TRY NEXT
NOREFV: HRRZ DIMCNT,1(VCOUNT) ;GET NUMBER OF DV'S
HRLI VCOUNT,(POINT 4,0)
ADDI VCOUNT,2 ;MAKE VCOUNT INTO BYTE POINTER
ARRYDV: SOJL DIMCNT,POPSTK ;DONE WHEN NO MORE DV'S
ILDB TEMP,VCOUNT ;GET DIMENSION SIZE
IMULI TEMP,3
HRRE POINTR,1(VPOINT);DON'T MARK ANY POINTERS TO HISEG
JUMPLE POINTR,ARRYND
CAMG POINTR,%DYNAM ;OR TO BELOW %DYNAM
JRST ARRYND
HRL TEMP,-1(POINTR) ;SEE IF ALREADY MARKED
TLNE TEMP,377777
JRST ARRYND
ORM TOP,-1(POINTR)
MOVE TOP,POINTR ;ELSE PUSH ONTO STACK
ARRYND: ADDI VPOINT,2(TEMP) ;AND TRY NEXT
JRST ARRYDV
MARKEX: POP %P,DIMCNT
POP %P,TEMP ;DONE, RESTORE TEMP AND DIMCNT
POPJ %P, ;EXIT
PRGEND
TITLE %ERROR -- ALGOLW ERROR MESSAGE EDITOR -- MICHAEL GREEN
HISEG
ENTRY %ERROR,%ERRNM,%ERROC,%ERRSB,%USRER,%ERRST
EXTERN %ERRPT,%UUO,%DCSAV,%XUUO
EXTERN .jbUUO
%B= 16
%P= 17
BASE= 10
LINENO= 11
HEADER= 12
WORK= 13
ERROR= 14
LENGTH= 10
CHAR= 11
BYTEPT= 12
LNEADR= 12
%ERROR: TTCALL 3,[BYTE (7) 015,012,0]
HRLI ERROR,(POINT 7,0) ;MAKE BYTE POINTER
MOVEM ERROR,%ERRPT ;AND SAVE IT
ERRPRT: ILDB ERROR,%ERRPT ;PRINT MESSAGE, EXIT ON "$"
CAIN ERROR,"$"
POPJ %P,
JUMPE ERROR,ENDSTR ;END OF MESSAGE
TTCALL 1,ERROR
JRST ERRPRT ;PRINT IT AND GET NEXT
%ERRNM: PUSH %P,WORK ;PRINT NUMBER
PUSHJ %P,PRTNUM
POP %P,WORK ;USE ONLY ERROR
JRST ERRPRT
%ERROC: PUSH %P,WORK ;PRINT OCTAL NUMBER
PUSHJ %P,PRTOCT
POP %P,WORK ;USE ONLY ERROR
JRST ERRPRT
PRTOCT: MOVE WORK,ERROR
IDIVI WORK,^D8 ;USUAL RECURSIVE EDITOR
JUMPE WORK,.+4 ;ALWAYS PRINT ONE DIGIT
HRLM ERROR,(%P)
PUSHJ %P,PRTOCT+1 ;SAVE DIGITS IN STACK
HLRZ ERROR,(%P)
ADDI ERROR,"0" ;MAKE ASCII
TTCALL 1,ERROR
POPJ %P, ;OUTPUT AND RETURN
PRTNUM: JUMPGE ERROR,.+2 ;DECIMAL EDITOR, CHECK SIGN
TTCALL 1,["-"]
MOVM WORK,ERROR ;USUAL RECURSIVE ONE
IDIVI WORK,^D10
JUMPE WORK,.+4 ;ALWAYS PRINT ONE DIGIT
HRLM ERROR,(%P)
PUSHJ %P,PRTNUM+3 ;SAVE DIGITS IN STACK
HLRZ ERROR,(%P)
ADDI ERROR,"0" ;MAKE ASCII
TTCALL 1,ERROR
POPJ %P, ;OUTPUT AND RETURN
%ERRSB: PUSH %P,WORK ;PRINT SIXBIT WORD
JUMPN ERROR,.+3 ;NOTHING IF ZERO
POP %P,WORK
JRST ERRPRT
MOVEI WORK,1 ;HIGH ORDER BIT
LSHC WORK,6 ;NEXT SIX BITS
TRC WORK,40 ;MAKE ASCII
TTCALL 1,WORK
JRST %ERRSB+1 ;OUTPUT, TRY NEXT
%ERRST: TTCALL 3,(ERROR) ;ASCIZ STRING
JRST ERRPRT
%USRER: TTCALL 3,[BYTE (7) 015,012,0]
HRRZ ERROR,.jbUUO ;USER CALL - STRING DV
MOVE BYTEPT,(ERROR)
HLRZ LENGTH,1(ERROR) ;GET BYTE POINTER AND LENGTH
HRRZ WORK,1(ERROR)
ADDI BYTEPT,(WORK) ;GET ACTUAL ADDRESS
JUMPE LENGTH,.+5 ;NO MESSAGE IF NULL
ILDB CHAR,BYTEPT
TTCALL 1,CHAR ;OUTPUT CHARACTER
SOJG LENGTH,.-2 ;GET NEXT
TTCALL 3,[BYTE (7) 015,012,0]
PUSHJ %P,ENDSTR+1 ;CALL TRACEBACK STUFF
EXIT ;NO RETURN TO USER
ENDSTR: TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
SKIPN ERROR,%DCSAV
MOVE ERROR,%UUO ;FIND POINT OF CALL
JUMPE %B,NOBASE ;ERROR IN RESET OR ALLOC
MOVE BASE,%B
TTCALL 3,[ASCIZ/?ERROR OCCURRED IN /]
TRACE: HLRZ HEADER,-1(BASE) ;GET DESCRIPTOR INFO
HRRZ WORK,-1(HEADER) ;LIKE PROCEDURE NAME
TTCALL 3,(WORK)
HRRZ WORK,-2(HEADER) ;SEE IF LINE NUMBER TABLE
JUMPN WORK,EDTLNE
NOLINE: TTCALL 3,[ASCIZ/ AT LOCATION /]
SUBI ERROR,1
ANDI ERROR,777777 ;EDIT ABSOLUTE ADDRESS
PUSHJ %P,PRTOCT
JRST ENDERL ;LOOK FOR CALLER
EDTLNE: HRLI WORK,(POINT ^D18,0)
MOVEI LINENO,1 ;SET UP FOR SEARCH OF TABLE
ILDB LNEADR,WORK ;FIND FIRST LINE
CAIL LNEADR,140
JRST .+3
ADDI LINENO,(LNEADR) ;NOT ADDRESS, LINE INCREMENT
JRST .-4
CAILE LNEADR,-1(ERROR) ;ADDRESS IN TABLE
JRST NOLINE
LOOKLP: ILDB LNEADR,WORK ;SEARCH FOR MATCH
JUMPE LNEADR,NOLINE ;END OF TABLE
CAIL LNEADR,140
JRST .+3
ADDI LINENO,(LNEADR) ;NOT ADDRESS, LINE INCREMENT
JRST LOOKLP
CAIG LNEADR,-1(ERROR)
AOJA LINENO,LOOKLP ;NO MATCH, INCREMENT LINE NO
TTCALL 3,[ASCIZ/ IN LINE /]
MOVE ERROR,LINENO
PUSHJ %P,PRTNUM ;EDIT LINE NUMBER
ENDERL: TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
NXTLVL: MOVE ERROR,1(BASE) ;GET CALLER
MOVE BASE,(BASE) ;AND HIS BASE
JUMPE BASE,EREXIT ;NONE, THEN DONE
JUMPE ERROR,NXTLVL ;NO CALLER, TRY NEXT LEVEL
TTCALL 3,[ASCIZ/CALLED FROM /]
JRST TRACE ;EDIT STUFF
NOBASE: TTCALL 3,[ASCIZ/?ERROR OCCURRED AT LOCATION /]
SUBI ERROR,1
ANDI ERROR,777777
PUSHJ %P,PRTOCT ;EDIT ABSOLUTE ADDRESS
TTCALL 3,[BYTE (7) 015,012,0] ;CRLF
EREXIT: POPJ %P, ;RETURN TO USER
PRGEND
TITLE %ARITH -- ALGOLW ARITHMETIC ROUTINES -- MICHAEL GREEN
HISEG
ENTRY %DADD,%DSUB,%DMULT,%DDIV,%CMULT,%CDIV,%DCMUL,%DCDIV
ENTRY %FIX,%FLOAT,%DFIX,%DFLOT
EXTERN %XUUO,%SAVE,%UUO,%DCSAV,%HDBLK
EXTERN .jbUUO
%P= 17
T= 7
A= 10
MBASE= 13
ACBASE= 12
RESULT= 14
AC0= 0
AC1= 2
AC2= 4
ACAC= 6
MAC= 7
OPDEF DADD [BYTE (9) 15]
OPDEF DSUB [BYTE (9) 16]
OPDEF DMUL [BYTE (9) 17]
OPDEF DDIV [BYTE (9) 20]
%DADD: LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;SET AC, DESTINATION
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO ;AC OR MEMORY
MOVE A,(ACBASE)
MOVE A+1,1(ACBASE) ;SETUP
HRRZ MBASE,.jbUUO
UFA A+1,1(MBASE) ;TAKEN FROM PDP-10 HANDBOOK
FADL A,(MBASE)
UFA A+1,A+2
FADL A,A+2
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO ;EXIT
%DSUB: LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;SET AC, DESTINATION
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO ;AC OR MEMORY
MOVE A,(ACBASE)
MOVE A+1,1(ACBASE) ;SETUP
HRRZ MBASE,.jbUUO
DFN A,A+1 ;NEGATE
UFA A+1,1(MBASE) ;COPY OF ADD ROUTINE
FADL A,(MBASE)
UFA A+1,A+2
FADL A,A+2
DFN A,A+1 ;NEGATE ANSWER
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO ;EXIT
%DMULT: LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;SET AC, DESTINATION
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO ;AC OR MEMORY
MOVE A,(ACBASE)
MOVE A+1,1(ACBASE) ;SETUP
HRRZ MBASE,.jbUUO
MOVEM A,A+2 ;ALSO TAKEN FROM PDP-10 HANDBOOK
FMPR A+2,1(MBASE)
FMPR A+1,(MBASE)
UFA A+1,A+2
FMPL A,(MBASE)
UFA A+1,A+2
FADL A,A+2
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO ;EXIT
%DDIV: LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;SET AC, DESTINATION
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO ;AC OR MEMORY
MOVE A,(ACBASE)
MOVE A+1,1(ACBASE) ;SETUP
HRRZ MBASE,.jbUUO
FDVL A,(MBASE) ;TAKEN FROM PDP-10 HANDBOOK
MOVN A+2,A
FMPR A+2,1(MBASE)
UFA A+1,A+2
FDVR A+2,(MBASE)
FADL A,A+2
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO ;EXIT
%CMULT: LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;SET AC, DESTINATION
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO ;AC OR MEMORY
HRRZ MBASE,.jbUUO
MOVE A,(ACBASE) ;(A+BI)(C+DI)=
FMPR A,(MBASE) ; (AC-BD)+(AD+BC)I
MOVE A+1,1(ACBASE)
FMPR A+1,1(MBASE)
FSBR A,A+1
MOVE A+1,(ACBASE)
FMPR A+1,1(MBASE)
MOVE A+2,1(ACBASE)
FMPR A+2,(MBASE)
FADR A+1,A+2
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO ;EXIT
%CDIV: PUSH %P,T ;SAVE WORK REGISTER
LDB ACBASE,[POINT 4,.jbUUO,^D12]
TRZN ACBASE,1 ;AC OR MEMORY
SKIPA RESULT,ACBASE
HRRZ RESULT,.jbUUO
HRRZ MBASE,.jbUUO
MOVE T,(MBASE) ;(A+BI)/(C+DI)=
FMPR T,T ; ((AC+BD)+(BC-AD)I)/(CC+DD)
MOVE A,1(MBASE)
FMPR A,A
FADR T,A
MOVE A,(ACBASE)
FMPR A,(MBASE)
MOVE A+1,1(ACBASE)
FMPR A+1,1(MBASE)
FADR A,A+1
FDVR A,T
MOVE A+1,1(ACBASE)
FMPR A+1,(MBASE)
MOVE A+2,(ACBASE)
FMPR A+2,1(MBASE)
FSBR A+1,A+2
FDVR A+1,T
POP %P,T
MOVEM A,(RESULT) ;STORE RESULT
MOVEM A+1,1(RESULT)
JRST %XUUO
%DCMUL: MOVEI RESULT,%SAVE ;SAVE REGISTERS
BLT RESULT,%SAVE+7
MOVE RESULT,%UUO ;SETUP FOR RECURSIVE CALL ON %ARITH
MOVEM RESULT,%DCSAV
MOVE RESULT,%HDBLK+3
LDB ACAC,[POINT 4,.jbUUO,^D12]
TRZN ACAC,1 ;SET AC, DESTINATION
SKIPA MAC,ACAC
HRRZ MAC,.jbUUO ;AC OR MEMORY
HRLI ACAC,(MAC) ;SAVE DESTINATION
HRRZ MAC,.jbUUO
CAIG MAC,17 ;MEMORY IS SAVED
ADDI MAC,%SAVE
MOVE AC0,%SAVE(ACAC) ;SAME AS %CMULT BUT DOUBLE PRECISION
MOVE AC0+1,%SAVE+1(ACAC)
DMUL AC0,(MAC)
MOVE AC1,%SAVE+2(ACAC)
MOVE AC1+1,%SAVE+3(ACAC)
DMUL AC1,2(MAC)
DSUB AC0,AC1
MOVE AC1,%SAVE(ACAC)
MOVE AC1+1,%SAVE+1(ACAC)
DMUL AC1,2(MAC)
MOVE AC2,(MAC)
MOVE AC2+1,1(MAC)
DMUL AC2,%SAVE+2(ACAC)
DADD AC1,AC2
HLRZ ACAC,ACAC ;STORE RESULT
CAIG ACAC,17
ADDI ACAC,%SAVE ;SAVED REGISTERS
MOVEM AC0,(ACAC)
MOVEM AC0+1,1(ACAC)
MOVEM AC1,2(ACAC)
MOVEM AC1+1,3(ACAC)
MOVSI RESULT,%SAVE ;RESTORE REGISTERS
BLT RESULT,7
MOVE RESULT,%DCSAV
MOVEM RESULT,%UUO ;UNDO RECURSION
SETZM %DCSAV
JRST %XUUO ;AND EXIT
%DCDIV: MOVEI RESULT,%SAVE ;SAVE REGISTERS
BLT RESULT,%SAVE+7
MOVE RESULT,%UUO ;SETUP FOR RECURSIVE CALL ON %ARITH
MOVEM RESULT,%DCSAV
MOVE RESULT,%HDBLK+3
LDB ACAC,[POINT 4,.jbUUO,^D12]
TRZN ACAC,1 ;SET AC, DESTINATION
SKIPA MAC,ACAC
HRRZ MAC,.jbUUO ;AC OR MEMORY
HRLI ACAC,(MAC) ;SAVE DESTINATION
HRRZ MAC,.jbUUO
CAIG MAC,17 ;SAVED MEMORY
ADDI MAC,%SAVE
MOVE AC0,(MAC) ;SAME AS %CDIV BUT DOUBLE PRECISION
MOVE AC0+1,1(MAC)
DMUL AC0,AC0
MOVE AC1,2(MAC)
MOVE AC1+1,3(MAC)
DMUL AC1,AC1
DADD AC0,AC1
PUSH %P,AC0 ;USE STACK AS TEMPORARY STORAGE
PUSH %P,AC0+1
MOVE AC0,%SAVE(ACAC)
MOVE AC0+1,%SAVE+1(ACAC)
DMUL AC0,(MAC)
MOVE AC1,%SAVE+2(ACAC)
MOVE AC1+1,%SAVE+3(ACAC)
DMUL AC1,2(MAC)
DADD AC0,AC1
DDIV AC0,-1(%P)
MOVE AC1,%SAVE+2(ACAC)
MOVE AC1+1,%SAVE+3(ACAC)
DMUL AC1,(MAC)
MOVE AC2,%SAVE(ACAC)
MOVE AC2+1,%SAVE+1(ACAC)
DMUL AC2,2(MAC)
DSUB AC1,AC2
DDIV AC1,-1(%P)
SUB %P,[XWD 2,2] ;ADJUST STACK
HLRZ ACAC,ACAC ;STORE RESULT
CAIG ACAC,17 ;SAVED REGISTERS
ADDI ACAC,%SAVE
MOVEM AC0,(ACAC)
MOVEM AC0+1,1(ACAC)
MOVEM AC1,2(ACAC)
MOVEM AC1+1,3(ACAC)
MOVSI RESULT,%SAVE ;RESTORE REGISTERS
BLT RESULT,7
MOVE RESULT,%DCSAV ;UNDO RECURSION
MOVEM RESULT,%UUO
SETZM %DCSAV
JRST %XUUO ;EXIT
%FIX: MOVM A+1,@.jbUUO ;GET MAGNITUDE OF NUMBER
CAMG A+1,[200777777777] ;IS < 1.0
JRST FIXZER ;ASSUME 0
CAMLE A+1,[243777777777] ;IS TOO BIG
JRST FIXOVF ;YES, FORCE OVERFLOW
SETZ A,
LSHC A,^D9 ;GET EXPONENT
FIXSHL: LSH A+1,-244(A) ;ADJUST MANTISSA ACCORDINGLY
FIXSTO: EXCH A+1,@.jbUUO ;STORE NUMBER
JUMPGE A+1,%XUUO ;IF ORIGINAL WAS NEGATIVE,
MOVNS @.jbUUO ; NEGATE ANSWER
JRST %XUUO ;EXIT
FIXZER: SETZM @.jbUUO ;FORCE ZERO ANSWER
JRST %XUUO ;EXIT
FIXOVF: MOVE A+1,[377777777777] ;FORCE OVERFLOW
AOJA A+1,FIXSTO ;CONTINUE IF OVERFLOW IGNORED
%FLOAT: MOVM A,@.jbUUO ;GET MAGNITUDE OF NUMBER
JUMPE A,%XUUO ;ZERO, QUIT
IDIVI A,400000 ;BREAK NUMBER INTO TWO PARTS
HRLI A+1,233000 ;SET EXPONENT
JUMPE A,.+2 ;IF < 18 BITS, SECOND NUMBER IS ZERO
HRLI A,254000
FAD A+1,A ;USE FAD TO COMBINE AND NORMALIZE
EXCH A+1,@.jbUUO ;STORE
JUMPGE A+1,%XUUO ;IF ORIGINAL WAS NEGATIVE,
MOVNS @.jbUUO ; NEGATE ANSWER
JRST %XUUO ;EXIT
%DFIX: HRRZ MBASE,.jbUUO ;GET ADDRESS
MOVM A+1,(MBASE) ;LOOK AT FIRST WORD
CAMG A+1,[200777777777] ;IS < 1.0L
JRST FIXZER ;ASSUME ZERO
CAMLE A+1,[243777777777] ;IS TOO BIG
JRST FIXOVF ;YES, FORCE OVERFLOW
SKIPL (MBASE) ;GET MAGNITUDE OF SECOND WORD
SKIPA A+2,1(MBASE)
MOVN A+2,1(MBASE)
HLRZ A+2,A+2 ;ONLY FIRST 9 BITS OF SECOND WORD
ANDI A+2,777 ; ARE OF INTEREST
SETZ A,
LSHC A,^D9 ;GET EXPONENT
ORI A+1,(A+2) ; AND EXTRA 9 BITS
JRST FIXSHL ;CONTINUE AS FOR %FIX
%DFLOT: HRRZ MBASE,.jbUUO ;GET ADDRESS
SETZM 1(MBASE) ;POSSIBLE ZERO RESULT
MOVM A,(MBASE) ;GET MAGNITUDE
JUMPE A,%XUUO ;DONE IF ZERO
IDIVI A,400000 ;BREAK NUMBER INTO TWO PARTS
HRLI A+1,233000 ;SET EXPONENT
JUMPE A,.+2 ;IF < 18 BITS, SECOND NUMBER IS ZERO
HRLI A,254000
FADL A,A+1 ;USE LONG FORM HERE
SKIPGE (MBASE) ;IF ORIGINAL WAS NEGATIVE,
DFN A,A+1 ; NEGATE THE ANSWER
MOVEM A,(MBASE) ;STORE RESULT
MOVEM A+1,1(MBASE)
JRST %XUUO ;EXIT
PRGEND
TITLE %STRNG -- ALGOLW STRING ROUTINES -- MICHAEL GREEN
HISEG
ENTRY %CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE
ENTRY %IS,%SMOVE,%SUBST,%SUBSC
ENTRY %STRIN,%BITIN,%INTBI,%INTST
EXTERN %XUUO,%UUO,%ERROR,%ERRNM
EXTERN .jbUUO
%P= 17
VALUE= 10
DIGITS= 12
SIGN= 13
LEN1= 10
BYTEP1= 11
LEN2= 12
BYTEP2= 13
PAD= 11
CHAR= 12
TEMP= 14
ERROR= 14
SETUP: LDB TEMP,[POINT 4,.jbUUO,^D12]
TRZE TEMP,1 ;OPERANDS IN REVERSE ORDER?
JRST SETUP2
MOVE BYTEP1,(TEMP) ;GET STRING DV AT AC
MOVE LEN1,1(TEMP)
ADDI BYTEP1,(LEN1) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LEN1,LEN1 ;GET LENGTH FIELD
HRRZ TEMP,.jbUUO
MOVE BYTEP2,(TEMP) ;GET STRING DV AT ADDRESS
MOVE LEN2,1(TEMP)
ADDI BYTEP2,(LEN2) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LEN2,LEN2 ;GET LENGTH FIELD
POPJ %P, ;RETURN
SETUP2: MOVE BYTEP2,(TEMP) ;GET STRING DV AT AC
MOVE LEN2,1(TEMP)
ADDI BYTEP2,(LEN2) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LEN2,LEN2 ;GET LENGTH FIELD
HRRZ TEMP,.jbUUO
MOVE BYTEP1,(TEMP) ;GET STRING DV AT ADDRESS
MOVE LEN1,1(TEMP)
ADDI BYTEP1,(LEN1) ;MAKE BYTEPT ADDR ABSOLUTE
HLRZ LEN1,LEN1 ;GET LENGTH FIELD
POPJ %P, ;RETURN
%CSTE: PUSHJ %P,SETUP ;SETUP REGISTERS
HRLI LEN1,(LEN2) ;PUT BOTH LENGTHS TOGETHER
JUMPE LEN1,SUCCES ;NULL STRINGS ARE EQUAL
CSTEL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
JRST .+3
SUBI LEN1,1 ;YEP, GET A CHARACTER
JRST .+4
HRRI BYTEP1,[XWD 200000,0]
TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
ILDB CHAR,BYTEP1
TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
JRST .+3
SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
JRST .+4
HRRI BYTEP2,[XWD 200000,0]
TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
ILDB TEMP,BYTEP2
CAIE CHAR,(TEMP) ;COMPARE BYTES
JRST %XUUO ;NOT EQUAL
JUMPN LEN1,CSTEL ;IF MORE, PROCESS THEM
SUCCES: AOS %UUO ;SUCCES RETURN, SKIP
JRST %XUUO
%CSTN: PUSHJ %P,SETUP ;SETUP REGISTERS
HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
JUMPE LEN1,%XUUO ;NULL STRINGS, FAIL
CSTNL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
JRST .+3
SUBI LEN1,1 ;YEP, GET A BYTE
JRST .+4
HRRI BYTEP1,[XWD 200000,0]
TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
ILDB CHAR,BYTEP1
TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
JRST .+3
SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
JRST .+4
HRRI BYTEP2,[XWD 200000,0]
TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
ILDB TEMP,BYTEP2
CAIE CHAR,(TEMP) ;COMPARE
JRST SUCCES ;NOT =, SUCCEED
JUMPN LEN1,CSTNL ;=, CONTINUE COMPARE
JRST %XUUO ;END OF STRING, FAIL
CSTL: PUSHJ %P,SETUP ;SETUP REGISTERS
HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
JUMPE LEN1,CSTEXT ;NULL STRINGS ARE EQUAL
CSTLL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
JRST .+3
SUBI LEN1,1 ;YEP, GET A BYTE
JRST .+4
HRRI BYTEP1,[XWD 200000,0]
TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
ILDB CHAR,BYTEP1
TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
JRST .+3
SUB LEN1,[XWD 1,0] ;YEP, GET A BYTE
JRST .+4
HRRI BYTEP2,[XWD 200000,0]
TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
ILDB TEMP,BYTEP2
CAIE CHAR,(TEMP) ;COMPARE THEM
JRST LSSNEQ ;NOT =, CHECK FURTHER
JUMPN LEN1,CSTLL ;=, CONTINUE COMPARE
CSTEXT: POPJ %P, ;RETURN
LSSNEQ: CAIL CHAR,(TEMP) ;COMPARE NEQ CHARACTERS
JRST PFAIL ;>, FAIL
PSUCCE: POP %P,TEMP ;DISCARD RETURN
AOS %UUO ;SKIP RETURN
JRST %XUUO
PFAIL: POP %P,TEMP ;DISCARD RETURN
JRST %XUUO ;NON SKIP RETURN
%CSTL: PUSHJ %P,CSTL ;CALL LSS COMPARE
JRST %XUUO ;IF =, FAIL
%CSTLE: PUSHJ %P,CSTL ;CALL LSS COMPARE
JRST SUCCES ;IF =, SUCCEED
CSTG: PUSHJ %P,SETUP ;SETUP REGISTERS
HRLI LEN1,(LEN2) ;PUT LENGTHS TOGETHER
JUMPE LEN1,CSTEXT ;NULL STRINGS ARE EQUAL
CSTGL: TRNN LEN1,777777 ;ANY LEFT IN FIRST OPERAND
JRST .+3
SUBI LEN1,1 ;YEP, GET A CHARACTER
JRST .+4
HRRI BYTEP1,[XWD 200000,0]
TLZ BYTEP1,770000 ;NOPE, FAKE A BYTE
TLO BYTEP1,440000 ;WORKS WITH BITS OR STRING
ILDB CHAR,BYTEP1
TLNN LEN1,777777 ;ANY LEFT IN SECOND OPERAND
JRST .+3
SUB LEN1,[XWD 1,0] ;YEP, GET A CHARACTER
JRST .+4
HRRI BYTEP2,[XWD 200000,0]
TLZ BYTEP2,770000 ;NOPE, FAKE A BYTE
TLO BYTEP2,440000 ;WORKS WITH BITS OR STRING
ILDB TEMP,BYTEP2
CAIE CHAR,(TEMP) ;COMPARE THEM
JRST GTRNEQ ;NOT =, CHECK FURTHER
JUMPN LEN1,CSTGL ;=, CONTINUE COMPARE
POPJ %P, ;RETURN
GTRNEQ: CAIG CHAR,(TEMP) ;COMPARE NEQ CHARACTERS
JRST PFAIL ;<, FAIL
JRST PSUCCE ;>, SUCCEED
%CSTG: PUSHJ %P,CSTG ;CALL GTR COMPARE
JRST %XUUO ;IF =, FAIL
%CSTGE: PUSHJ %P,CSTG ;CALL GTR COMPARE
JRST SUCCES ;IF =, SUCCEED
%SMOVE: PUSHJ %P,SETUP ;SETUP REGISTERS
JUMPE LEN2,%XUUO ;NULL DESTINATION, DONE
TLNE BYTEP1,007600 ;CHECK FOR SAME BYTE SIZE
JRST SMOVET
TLNE BYTEP2,007600 ;PERHAPS BOTH BITS
JRST SMOVEP
SMOVEL: JUMPE LEN1,.+3 ;NO MORE SOURCE, SUPPLY BLANKS
ILDB TEMP,BYTEP1 ;ELSE GET SOURCE CHARACTER
SOJA LEN1,.+2 ;ADJUST LENGTH
MOVEI TEMP," "
IDPB TEMP,BYTEP2 ;STORE CHARACTER
SOJG LEN2,SMOVEL ;PROCESS NEXT
JRST %XUUO ;DONE
SMOVET: TLNE BYTEP2,007600 ;FIRST NOT BITS
JRST SMOVEL ;SECOND NOT BITS EITHER
SMOVEU: JUMPE LEN1,.+3 ;NO MORE SOURCE IN
ILDB TEMP,BYTEP1 ; STRING TO BITS MOVE
SOJA LEN1,.+2 ;ADJUST LENGTH
MOVEI TEMP," " ;PAD OUT SOURCE WITH BLANKS
LSH TEMP,^D29 ;UNPACK LEFT TO RIGHT
TLO TEMP,002000 ;ADD BIT TO MARK END
SMOVER: TLNN TEMP,376000 ;NOW CHECK FOR NO MORE BITS
JRST SMOVEU ;IF SO, GET NEXT SOURCE
ROT TEMP,1 ;IF NOT, ROTATE NEW BIT
IDPB TEMP,BYTEP2 ; TO STORE POSITION
SOJG LEN2,SMOVER ;IF DESTINATION ROOM, CONTINUE
JRST %XUUO ; ELSE QUIT
SMOVEP: HRLI LEN2,1 ;SET UP FOR BITS TO STRING MOVE
JUMPE LEN1,.+4 ;CHECK FOR NO MORE SOURCE
ILDB TEMP,BYTEP1 ;IF NOT, GET A BYTE
LSH TEMP,^D17 ; AND PUT IN HIGH ORDER OF HALF
SOJA LEN1,.+2 ;ADJUST LENGTH
MOVEI TEMP,0 ;PAD OUT SOURCE WITH ZEROES
HLL TEMP,LEN2
LSH TEMP,1 ;PACK IN NEW BIT
HLL LEN2,TEMP
TLNN TEMP,000200 ;CHECK FOR FINISHED BYTE
JRST SMOVEP+1
HRLI LEN2,0 ;RESET LEFT HALF OF LENGTH
HLRZS TEMP ;RIGHT JUSTIFY
IDPB TEMP,BYTEP2 ;AND STORE AWAY
SOJG LEN2,SMOVEP ;ADJUST DEST. LENGTH
JRST %XUUO ;EXIT IF DONE
%IS: LDB TEMP,[POINT 4,.jbUUO,^D12]
MOVE TEMP,(TEMP) ;GET RECORD DESCRIPTOR
JUMPE TEMP,%XUUO ;MAYBE IS NULL POINTER
HLRZ TEMP,-1(TEMP)
CAIN TEMP,@.jbUUO ;IF SAME AS ASKED RECORD,
JRST RECDIS ; SHORT CUT CHECK
HRRZ TEMP,(TEMP) ;GET NAME ADDRESS
HRRZ LEN1,@.jbUUO
MOVE CHAR,(TEMP) ;GET A WORD OF NAME
CAME CHAR,(LEN1) ;COMPARE TO OTHER NAME
JRST %XUUO ;FAIL IF NOT =
ADDI TEMP,1
TRNE CHAR,376 ;IF END OF ASCIZ, SUCCEED
AOJA LEN1,.-5 ; ELSE TRY NEXT WORDS
RECDIS: AOS %UUO
JRST %XUUO ;SKIP RETURN
%SUBST: HRRZ TEMP,.jbUUO ;GET DV
MOVE BYTEP1,(TEMP)
MOVS LEN1,1(TEMP) ;SWAPPED LENGTH
LDB TEMP,[POINT 4,.jbUUO,^D12]
TRZN TEMP,1
JRST .+3
MOVE LEN2,(TEMP) ;SPECIAL CASE, STRING SUBSCRIPTING
JRST SPECSB
MOVE LEN2,(TEMP) ;GET NEW START POSITION
CAILE LEN2,(LEN1) ;COMPARE TO OLD LENGTH
JRST ERR2 ;ERROR IF >
SOJL LEN2,ERR1 ; OR IF <= 0
SUBI LEN1,(LEN2) ;ADJUST OLD LENGTH
MOVE BYTEP2,1(TEMP) ;GET NEW LENGTH
JUMPL BYTEP2,ERR3 ;ERROR IF < 0
CAILE BYTEP2,(LEN1) ; OR IF > ADJUSTED LENGTH
JRST ERR4
HRRI LEN1,(BYTEP2) ;SET NEW LENGTH
SPECSB: LDB BYTEP2,[POINT 6,BYTEP1,^D11]
MOVEI TEMP,^D36 ;HOW MANY BYTES PER WORD
IDIVM TEMP,BYTEP2
IDIVI LEN2,(BYTEP2) ;GET WORD OFFSET AND REMAINDER
ADDI BYTEP1,(LEN2)
JUMPE BYTEP2,.+3 ;ADJUST BYTE POINTER ACCORDINGLY
IBP BYTEP1
SOJG BYTEP2,.-1
LDB TEMP,[POINT 4,.jbUUO,^D12]
ANDI TEMP,16
MOVEM BYTEP1,(TEMP) ;STORE ADJUSTED DV
MOVSM LEN1,1(TEMP)
JRST %XUUO ;AND RETURN
ERR1: MOVE LEN2,(TEMP) ;SAVE START
MOVEI ERROR,[ASCIZ/SUBSTRING - START $ <= 0/]
EDIT: PUSHJ %P,%ERROR
MOVE ERROR,LEN2
PUSHJ %P,%ERRNM
EXIT ;QUIT
ERR2: MOVE LEN2,(TEMP) ;SAVE START
MOVEI ERROR,[ASCIZ/SUBSTRING - START $ > STRING LENGTH $/]
PUSHJ %P,%ERROR
MOVE ERROR,LEN2
PUSHJ %P,%ERRNM
MOVEI ERROR,(LEN1) ;GET STRING LENGTH
PUSHJ %P,%ERRNM
EXIT ;QUIT
ERR3: MOVE LEN2,1(TEMP) ;SAVE LENGTH
MOVEI ERROR,[ASCIZ/SUBSTRING - LENGTH $ < 0/]
JRST EDIT
ERR4: MOVE LEN2,(TEMP) ;SAVE START
MOVE BYTEP2,1(TEMP) ; AND LENGTH
MOVEI ERROR,[ASCIZ/SUBSTRING - LENGTH $ > STRING LENGTH $ - START $ + 1/]
PUSHJ %P,%ERROR
MOVE ERROR,BYTEP2
PUSHJ %P,%ERRNM
MOVEI ERROR,(LEN1) ;GET STRING LENGTH
PUSHJ %P,%ERRNM
JRST EDIT+1
%SUBSC: LDB TEMP,[POINT 4,.jbUUO,^D12]
HRRZ LEN1,.jbUUO ;SUBSCRIPT CHECKING
MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
SUB LEN2,1(LEN1) ;SUBTRACT LOWER BOUND
JUMPL LEN2,LOWERR
CAML LEN2,2(LEN1) ;CHECK UPPER BOUND
JRST HGHERR
IMUL LEN2,(LEN1) ;MULTIPLY BY DIMENSION UNITS
ADDM LEN2,(TEMP) ;ADD IN TO TOTAL
JRST %XUUO
LOWERR: MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
MOVEI ERROR,[ASCIZ/SUBSCRIPT - $ < LOWER BOUND $/]
PUSHJ %P,%ERROR
MOVE ERROR,LEN2
PUSHJ %P,%ERRNM
MOVE ERROR,1(LEN1)
PUSHJ %P,%ERRNM
EXIT
HGHERR: MOVE LEN2,1(TEMP) ;GET SUBSCRIPT
MOVEI ERROR,[ASCIZ/SUBSCRIPT - $ > UPPER BOUND $/]
PUSHJ %P,%ERROR
MOVE ERROR,LEN2
PUSHJ %P,%ERRNM
MOVE ERROR,2(LEN1) ;CALCULATE UPPER BOUND
ADD ERROR,1(LEN1)
SUBI ERROR,1
PUSHJ %P,%ERRNM
EXIT
%INTST: MOVEI SIGN," " ;INTEGER TO STRING CONVERSION
SKIPGE -3(%P) ;CHECK SIGN OF VALUE
MOVEI SIGN,"-"
MOVM VALUE,-3(%P) ;GET MAGNITUDE OF VALUE
MOVE DIGITS,[XWD 2,2];MINIMUM OF 2 CHARACTERS
INTSTD: IDIVI VALUE,^D10
JUMPE VALUE,INTSTE ;PUSH DIGITS INTO STACK
ADDI VALUE+1,"0"
PUSH %P,VALUE+1 ;THEY ARE IN REVERSE ORDER
AOBJP DIGITS,INTSTD ;KEEP TRACK OF HOW MANY
INTSTE: ADDI VALUE+1,"0"
PUSH %P,VALUE+1 ;DO LAST DIGIT
PUSH %P,SIGN ; AND SIGN
SUB %P,DIGITS ;NOW ADJUST STACK
MOVE LEN1,-1(%P)
SUBI LEN1,(DIGITS) ;HOW MANY LEADING BLANKS
JUMPL LEN1,INTSTX ; OR MAYBE AN ERROR
JUMPE LEN1,INTSTC
MOVEI PAD," "
IDPB PAD,-2(%P) ;STORE LEADING BLANKS
SOJG LEN1,.-1
INTSTC: ADDI DIGITS,(%P) ;POINT TO START OF NUMBER
SUB DIGITS,[XWD 1,0]
MOVE PAD,(DIGITS) ;GET A CHARACTER
IDPB PAD,-2(%P) ; AND STORE IT
SUB DIGITS,[XWD 1,1]
JUMPGE DIGITS,.-3 ;LOOP UNTIL DONE
POP %P,-3(%P)
SUB %P,[XWD 2,2] ;CLOSE UP STACK
POPJ %P, ;AND EXIT
INTSTX: MOVEI ERROR,[ASCIZ/INTSTR - $ TOO BIG FOR $ CHARACTER STRING/]
PUSHJ %P,%ERROR
MOVE ERROR,-3(%P) ;EDIT IN INTEGER
PUSHJ %P,%ERRNM
MOVE ERROR,-1(%P) ;AND STRING LENGTH
PUSHJ %P,%ERRNM
EXIT
%STRIN: MOVE LEN2,-1(%P) ;STRING TO INTEGER CONVERSION
SOJL LEN2,FMTERR
ILDB SIGN,-2(%P) ;SKIP LEADING BLANKS
CAIN SIGN," "
JRST .-3
CAIE SIGN,"+" ;ALLOW LEADING PLUS
CAIN SIGN,"-" ; OR MINUS
JRST STRINS
CAIGE SIGN,"0" ;MAKE SURE VALID DIGIT
JRST FMTERR
CAILE SIGN,"9"
JRST FMTERR
MOVEI VALUE,-"0"(SIGN);ASSUME POSITIVE
SOJL LEN2,STRINE
STRINL: ILDB VALUE+1,-2(%P) ;GET NEXT CHARACTER
CAIGE VALUE+1,"0"
JRST FMTERR ;ALLOW ONLY DIGITS
CAILE VALUE+1,"9"
JRST FMTERR
CAMLE VALUE,[DEC <^O377777777777-9>/10]
JRST SIZERR ;CHECK FOR SIZE
IMULI VALUE,^D10
ADDI VALUE,-"0"(VALUE+1)
SOJGE LEN2,STRINL ;PACK IN AND TRY AGAIN
STRINE: CAIN SIGN,"-"
MOVN VALUE,VALUE ;NEGATE IF MINUS SIGN
MOVEM VALUE,-2(%P)
POP %P,-1(%P) ;CLOSE UP STACK
POPJ %P,
STRINS: SOJL LEN2,FMTERR ;SIGN, CHECK FOR FOLLOWING
MOVEI VALUE,0 ; DIGIT
JRST STRINL
SIZERR: MOVEI ERROR,[ASCIZ/STRINT - INTEGER TOO LARGE/]
PUSHJ %P,%ERROR
EXIT
FMTERR: MOVEI ERROR,[ASCIZ/STRINT - STRING DOESN'T CONTAIN INTEGER/]
PUSHJ %P,%ERROR
EXIT
%INTBI: MOVE LEN2,-1(%P) ;INTEGER TO BITS CONVERSION
MOVEI VALUE,0
CAIG LEN2,^D36 ;PAD ON LEFT WITH ZEROES
JRST .+3
IDPB VALUE,-2(%P)
SOJA LEN2,.-3
MOVE VALUE,-3(%P) ;LEFT SHIFT FOR SHORT BITSTRINGS
HRREI SIGN,-^D36(CHAR)
JUMPE SIGN,INTBIS ;36 BITS, NO SHIFT NEEDED
JUMPL VALUE,BITSIZ ;CHECK FOR NOT ENOUGH ROOM
LSH VALUE,1
AOJL SIGN,.-2
INTBIS: JUMPE LEN2,INTBIE ;COPY BITS NOW
ROT VALUE,1
IDPB VALUE,-2(%P)
SOJG LEN2,.-2
INTBIE: POP %P,-3(%P) ;CLOSE UP STACK
SUB %P,[XWD 2,2]
POPJ %P,
BITSIZ: MOVEI ERROR,[ASCIZ/INTBIT - $ TOO BIG FOR $ BIT BITSTRING/]
PUSHJ %P,%ERROR
MOVE ERROR,-3(%P) ;EDIT IN INTEGER
PUSHJ %P,%ERRNM
MOVE ERROR,-1(%P) ;EDIT IN LENGTH
PUSHJ %P,%ERRNM
EXIT
%BITIN: MOVE LEN2,-1(%P) ;BITSTRING TO INTEGER CONVERSION
MOVEI VALUE,0
JUMPE LEN2,BITINE ;NULL BITSTRING ALLOWED
BITINL: JUMPL VALUE,INTSIZ ;TOO BIG
ILDB VALUE+1,-2(%P)
ROT VALUE+1,-1 ;GET BIT INTO POSITION
LSHC VALUE,1
SOJG LEN2,BITINL ;MERGE AND GET NEXT ONE
BITINE: MOVEM VALUE,-2(%P) ;SAVE VALUE
POP %P,-1(%P) ; AND CLOSE UP STACK
POPJ %P,
INTSIZ: MOVEI ERROR,[ASCIZ/BITINT - MORE THAN 36 SIGNIFICANT BITS/]
PUSHJ %P,%ERROR
EXIT
PRGEND
TITLE %RUN ROUTINE FOR ALGOLW -- MICHAEL GREEN
HISEG
ENTRY %RUN
EXTERN %ERROR,%ERRSB,%OPNSW
%P= 17
CHAR= 10
ASSEMB= 11
LENGTH= 12
FLAG= 13
ERROR= 14
LOOKNM= 400000 ;FLAGS IN LH OF FLAG
FINDNM= 200000
LOOKDG= 100000
FINDDG= 040000
LOOKDV= 020000
LOOKFL= 010000
PASTFL= 004000
LOOKPP= 002000
OCTAL= 001000
LOOKPG= 000400
FINDPP= 000200
LOOKEN= 000100
FINDEN= 000040
LOOKST= 000020
FINDST= 000010
CONDRN= 000004
DEV= %OPNSW ;DEVICE NAME
NAME= %OPNSW+1 ;FILE NAME
EXT= %OPNSW+2 ;EXTENSION
PPNO= %OPNSW+4 ;PROJECT-PROGRAMMER NUMBER
LOWMEM= %OPNSW+5 ;LOW SEGMENT LENGTH
ENTRY= %OPNSW+6 ;RELATIVE ENTRY POINT
%RUN: SETZB FLAG,NAME ;CLEAR FLAGS AND CONTROL BLOCK
MOVE CHAR,[XWD NAME,EXT]
BLT CHAR,ENTRY
MOVSI CHAR,(SIXBIT/DSK/)
MOVEM CHAR,DEV ;DEFAULT DEVICE IS DSK
MOVE LENGTH,-1(%P) ;GET STRING LENGTH
NEWITM: SETZ ASSEMB, ;START NEW FIELD
JUMPL LENGTH,GORUN ; UNLESS NO MORE STRING
NEXTCH: SOJL LENGTH,ENDFLD ;END OF FIELD AT STRING END
ILDB CHAR,-2(%P)
CAIN CHAR,":" ;END OF DEVICE
JRST DEVCHK
CAIN CHAR,"." ;END OF FILE NAME
JRST NAMCHK
CAIN CHAR,"[" ;START OF PROJECT-PROGRAMMER
JRST STRTPP
CAIN CHAR,"," ;START OF PROGRAMMER
JRST COMMA
CAIN CHAR,"]" ;END OF PROGRAMMER NUMBER
JRST ENDPP
CAIN CHAR,"?" ;CONDITIONAL RUN
JRST CONDCD
CAIN CHAR,"@" ;START OF ENTRY POINT
JRST STRTEN
CAIN CHAR,"=" ;START OF LOW SEGMENT LENGTH
JRST STRTST
CAIN CHAR,"K" ;MAYBE END OF LOW SEGMENT LENGTH
JRST ENDSTU
CAIN CHAR,"K"+40 ;ALSO MAYBE END OF LOW SEGMENT LENGTH
JRST ENDSTL
CAIGE CHAR,"0" ;CHECK FOR DIGIT
JRST .+3
CAIG CHAR,"9"
JRST DIGIT
CAIGE CHAR,"A" ;CHECK FOR UPPER CASE LETTER
JRST .+3
CAIG CHAR,"Z"
JRST LETTER
CAIGE CHAR,"A"+40 ;CHECK FOR LOWER CASE LETTER
JRST .+3
CAIG CHAR,"Z"+40
JRST LOWERC
UNKNOW: MOVEI ERROR,[ASCIZ/RUN - UNRECOGNIZABLE FILE DESCRIPTOR/]
PUSHJ %P,%ERROR
EXIT
LOWERC: TRZ CHAR,40 ;FORCE TO UPPER CASE
LETTER: TLNE FLAG,LOOKNM
JRST UNKNOW ;MUST BE LOOKING FOR NAME
TLO FLAG,FINDNM
TLNE ASSEMB,770000 ;USE ONLY FIRST 6 CHARACTERS
JRST NEXTCH
TRC CHAR,40
ROT CHAR,-6
ROTC CHAR,6 ;PACK IN USING SIXBIT
JRST NEXTCH
DIGIT: TLNN FLAG,LOOKDG ;ARE WE LOOKING FOR DIGIT
JRST LETTER ; NO, MAYBE PART OF NAME
TLO FLAG,FINDDG
TLNE FLAG,OCTAL ;TAKE CARE OF OCTAL NUMBER
JRST POCTAL
CAIL ASSEMB,^D100 ;MAXIMUM OF 3 DIGITS
JRST UNKNOW
IMULI ASSEMB,^D10 ;OK, PACK IN DIGIT
ADDI ASSEMB,-"0"(CHAR)
JRST NEXTCH
POCTAL: CAIL CHAR,"8" ;CHECK FOR LEGAL OCTAL DIGIT
JRST UNKNOW
CAIL ASSEMB,100000 ;MAXIMUM OF 18 BITS
JRST UNKNOW
ROT CHAR,-3 ;PACK IN
ROTC CHAR,3
JRST NEXTCH
DEVCHK: TLOE FLAG,LOOKDV ;LOOKING FOR DEVICE NAME
JRST UNKNOW
TLZN FLAG,FINDNM ;LOOKING FOR NAME
JRST UNKNOW
TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
JRST .+3
LSH ASSEMB,6
JRST .-3
MOVEM ASSEMB,DEV ;SAVE EXPLICIT DEVICE NAME
JRST NEWITM
NAMCHK: TLOE FLAG,LOOKFL ;LOOKING FOR FILE NAME
JRST UNKNOW
TLZN FLAG,FINDNM ;LOOKING FOR NAME
JRST UNKNOW
TLO FLAG,LOOKDV ;NO MORE DEVICE NAMES
STORFL: TLNE ASSEMB,770000 ;LEFT JUSTIFY NAME
JRST .+3
LSH ASSEMB,6
JRST .-3
MOVEM ASSEMB,NAME ;STORE IT AWAY
JRST NEWITM
ENDFLD: TLOE FLAG,PASTFL ;PAST DEV:FILE.EXT
JRST CHKENT
TLO FLAG,LOOKNM ;NO, NO MORE NAMES
TLZN FLAG,FINDNM
JRST NEWITM ;NO NAME
TLON FLAG,LOOKFL
JRST STORFL ;LOOKING FOR FILE NAME
TLNE ASSEMB,770000
JRST .+3 ;NO, FOUND EXTENSION
LSH ASSEMB,6
JRST .-3
HLLZM ASSEMB,EXT ;SO STORE IT
JRST NEWITM
STRTPP: TLNE FLAG,LOOKPP+FINDPP+LOOKST+LOOKPG
JRST UNKNOWN ;NOT IN PROJ-PROG OR LOW SEG SIZE
TLO FLAG,LOOKDG+OCTAL+LOOKPP
JRST ENDFLD ;LOOK FOR OCTAL PROJECT NO.
CHKENT: TLZN FLAG,LOOKEN ;CHECK IN ENTRY POINT
JRST NEWITM
TLZN FLAG,FINDDG ;MUST HAVE NUMBER
JRST UNKNOW
TLO FLAG,FINDEN ;FOUND ENTRY POINT
HRLZM ASSEMB,ENTRY ; SO SAVE IT
JRST NEWITM
STRTEN: TLNE FLAG,LOOKEN+FINDEN
JRST UNKNOW ;NOT IN ENTRY AND NOT FOUND ONE
TLO FLAG,LOOKDG+LOOKEN+OCTAL
TLOE FLAG,PASTFL ;CHECK PAST FILE
JRST NEWITM ; IF SO, DON'T USE ENDFLD
JRST ENDFLD+2 ; IF NOT, BYPASS CHKENT TEST
COMMA: TLZN FLAG,LOOKPP ;MUST BE LOOKING FOR PROJECT
JRST UNKNOW
TLZN FLAG,FINDDG ;MUST HAVE FOUND THE NUMBER
JRST UNKNOW
TLO FLAG,LOOKPG ;LOOK FOR PROGRAMMER NUMBER
HRLZM ASSEMB,PPNO
JRST NEWITM ;STORE PROJECT NUMBER
ENDPP: TLZN FLAG,LOOKPG ;MUST BE LOOKING FOR PROGRAMMER NO.
JRST UNKNOW
TLZN FLAG,FINDDG ;MUST HAVE FOUND THE NUMBER
JRST UNKNOW
TLO FLAG,FINDPP ;FOUND PROJECT-PROGRAMMER
TLZ FLAG,LOOKDG
HRRM ASSEMB,PPNO ;STORE IT AWAY
JRST NEWITM
STRTST: TLNE FLAG,FINDST+LOOKST+LOOKPP+LOOKPG
JRST UNKNOW ;MUST NOT BE IN A FIELD
TLO FLAG,LOOKDG+LOOKST
TLZ FLAG,OCTAL ;LOOK FOR DECIMAL NUMBER
JRST ENDFLD
ENDSTL: TRZ CHAR,40 ;FORCE TO UPPER CASE "K"
ENDSTU: TLZN FLAG,LOOKST ;MUST BE IN ENTRY FIELD
JRST LETTER ; IF NOT, IS PART OF NAME
TLZN FLAG,FINDDG
JRST UNKNOW ;MUST HAVE FOUND NUMBER
JUMPE ASSEMB,UNKNOW
CAILE ASSEMB,^D128 ;0 < SIZE <= 128
JRST UNKNOW
TLO FLAG,FINDST ;SO FOUND LOW SEGMENT SIZE
TLZ FLAG,LOOKDG
LSH ASSEMB,^D10 ;SIZE IS IN MULTIPLES OF 1024
SUBI ASSEMB,1
HRRZM ASSEMB,LOWMEM ;STORE MAX ADDRESS OF LOW SEG
JRST NEWITM
CONDCD: TLNE FLAG,LOOKPP+LOOKST+LOOKPG
JRST UNKNOW ;NOT IN A FIELD
TLZ FLAG,LOOKDG
TLO FLAG,CONDRN ;SET CONDITIONAL RUN FLAG
JRST ENDFLD
GORUN: POP %P,-1(%P) ;CLOSE UP STACK
POP %P,-1(%P)
MOVE CHAR,ENTRY ;ENTRY POINT IN LH
HRRI CHAR,DEV ;ADDR OF BLOCK IN RH
RUN CHAR, ;ASK TO RUN IT
TLNE FLAG,CONDRN
POPJ %P, ;ERROR RETURN
MOVEI ERROR,[ASCIZ/RUN - $:$.$ CAN NOT BE RUN/]
PUSHJ %P,%ERROR ;UNCONDITIONAL RUN
MOVE ERROR,DEV
PUSHJ %P,%ERRSB ;EDIT IN DEVICE NAME
MOVE ERROR,NAME
PUSHJ %P,%ERRSB ;AND FILE NAME
MOVE ERROR,EXT
PUSHJ %P,%ERRSB ;AND EXTENSION
EXIT
END
EXIT