Trailing-Edge
-
PDP-10 Archives
-
ALGOL-20_29Jan82
-
algol-sources/algots.mac
There are 8 other files named algots.mac in the archive. Click here to see a list.
;
;
;COPYRIGHT (C) 1975,1981,1982 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;
;
SUBTTL ASSEMBLY SWITCHES, GLOBALS AND MACROS
SEARCH ALGPRM,ALGSYS ; SEARCH PARAMETER FILES
.GTLIM=40 ; [243] INDEX FOR BATCH STATUS GETTAB
JB.LBT=200 ; [243] "I'M A BATCH JOB" BIT IN GETTAB 40
SALL
%TITLE(ALGOTS,ALGOL OBJECT TIME SYSTEM)
INTERNAL .JBOPS
ENTRY %ALGDR
IFNDEF FTOVRL,<FTOVRL==-1> ; TURN ON OVERLAYS
FTGETCHK==0
IFNDEF FTGETCHK,<FTGETCHK==0> ; TURN OFF HEAP-CHECKER.
IF2, <
IFN FTGETCHK,<PRINTX HEAP INTEGRITY CHECKER LOADED>>
FTADMP==1
IFNDEF FTADMP,<FTADMP==0> ; 1 to give DUMP ALL on error in batch.
EXTERNAL .JBUUO,.JB41,.JBREL,.JBHRL,.JBSA,.JBDA,.JBSYM
EXTERNAL .JBFF,.JBAPR,.JBCNI,.JBTPC,.JBOPC
EXTERNAL .JBINT,.JBDDT
EXTERNAL %ALGDD,BREAK%,DDTOU%,DDTIN%,DDERM%,DDTER%,DUMP%
INTERNAL IPRNT%,DPRNT%,PRFPR%,STSPR%,CNCTR%,FLABL%
INTERNAL DDCON%,DDFIN%,DDBEG%,RSTRT%,SPACE%,CRLF%
MLON
IFNDEF HPCHN,<HPCHN==10>
IFNDEF OVLCHN,<OVLCHN==10>
LOC .JBVER ;[172]
EXP VERNO ;[172]
RELOC
DEFINE DPUSH(A)
< SUBI A,(DB)
PUSH SP,A
>
DEFINE RPOP(A)
< POP SP,A
ADDI A,(DB)
>
%ALGDR=. ; IF THIS LABEL IS NOT DEFINED
; REFERENCES TO IT ARE GENERATED BY
; MACRO EXPANSIONS ON PASS 1
DEFINE DDDUMP,<DUMP%> ; AVOID INFINITE LOOP !
SUBTTL ROUTINE DIRECTORY
LALL
ALGDIR ; CALL ALGDIR MACRO
SALL
SUBTTL MASTER CONTROL ROUTINE
; ENTERED FROM ALGOBJ (IN ALGLIB) WITH
; LH(AX): BIT 0 = 0 FOR START
; = 1 FOR REENTER
; RH(AX) = ADDRESS OF PARAMETER BLOCK
INITIA: RESET ; INITIALIZE IO
;
; Edit(1013) Clear overflow flags (compatability package bug)
;
JOV .+1 ; [E1013] Clear arithmetic
JFOV .+1 ; [E1013) ..and floating overflow flags.
HLRZ A3,.JBSA ; HEAP ORIGIN
HRRZ A4,3(AX) ; GET HEAP SIZE (%HEAP)
CAIGE A4,DELTA1 ; ENSURE IT'S AT LEAST
MOVEI A4,DELTA1 ; THE MINIMUM
MOVEI DB,(A3)
ADDI DB,(A4) ; DATA BASE
MOVEM DB,.JBOPS ; SAVE COPY
MOVEI SP,%DBL-1(DB) ; STACK ORIGIN
INIT0: HRRZ A2,.JBSA ; GET CURRENT START ADDRESS
CAIE A2,INIT8 ; AND IF WE HAVE NOT YET STARTED
MOVEI A2,INIT4 ; TRAP START AFTER CONTROL-C FROM
HRRM A2,.JBSA ; ALGDDT ON INITIAL REENTER
MOVEI A2,2(SP)
CAMG A2,.JBREL ; WILL STACK FIT IN CORE?
JRST INIT1 ; YES
CORE A2, ; NO - TRY TO EXPAND CORE
JRST [OUTSTR M201 ; [277] FAILED, PRINT ERROR MESSAGE
EXIT 1, ; [277] EXIT QUIETLY
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JRST INIT0] ; [277] TRY AGAIN IF "CONT"
INIT1: HRLZI A2,(A3)
HRRI A2,1(A3)
SETZM (A3)
BLT A2,@.JBREL ; CLEAR OUT DATA BASE AND STACK
HRLZM A4,(A3) ; FILL IN HEAP SIZE
MOVEM A3,%SYS21(DB) ; SAVE HEAP ORIGIN FOR HEAP-SIZE STATISTICS
HRLZI A1,HPCHN+1 ; SET UP HEAP TABLE AS A
MOVEM A1,(A3) ; USED HEAP PORTION
MOVSI A1,1-HPCHN ; [277] SETUP A COUNTER-MODIFIER
ADDI A1,1(A3) ; TO TABLE
MOVEM A1,%SYS2(DB)
ADDI A3,HPCHN+1 ; A3 POINTS TO 1ST FREE AREA
SUBI A4,HPCHN+1 ; AND A4 HAS ITS LENGTH
HRLI A3,(A4)
MOVEM A3,(A1) ; MAKE THE TABLE ENTRY
HLL A1,A3 ; AND THE
MOVEM A1,(A3) ; BACK POINTER
SETOM %CHAN(DB) ; SELECT CHANNEL -1
MOVEM AX,%SYS0(DB) ; SAVE PARAMETER BLOCK ADDRESS
HRLI A1,5(AX) ; MOVE LOAD-FILE INFO
HRRI A1,%IFDAT(DB) ; TO PERMANENT HOME
BLT A1,%IFDAT+2(DB) ; FOR OVERLAY-HANDLER
SKIPN A1,10(AX) ; GET TRACE BUFFER LENGTH
MOVEI A1,^D100 ; DEFAULT IF ZERO (COMPILER VER < 6)
HRL A1,A1 ;
MOVEM A1,%TRLNTH(DB) ; AND SAVE IT IN BOTH HALVES
MOVN A1,.JBREL
MOVNM A1,%SYS1(DB) ; SAVE INITIAL CORE SIZE
ADDI A1,(SP)
HRLI SP,(A1) ; SET UP COUNT FOR PUSH DOWN OVERFLOW
HRLZI A1,IOTTC
HRRI A1,%TTY(DB)
MOVEM A1,%IODR-1(DB) ; INITIALIZE CHANNEL -1
HRRZ A0,2(AX) ; GET %OWN
INIT2: HRRZ A1,A0 ; NEXT OWN AREA
HRRZ A2,(A1) ; GET POINTER TO NEXT
JUMPN A2,INIT2A ; NOT LAST ONE
HLRZ A2,(A1) ; GET LENGTH
CAILE A2,^D10 ; GREATER THAN LENGTH OF %SFILE AREA ?
MOVEI A2,^D10 ; YES - SET TO THAT.
ADDI A2,%SFILE-1(DB) ; GET END OF TRANSFER
HRLZI A3,1(A1) ; MAKE
HRRI A3,%SFILE(DB) ; POINTER
BLT A3,(A2) ; MOVE SYMBOL FILENAME TO DATA-BASE
INIT2A: HLRZ A2,(A1) ; GET ITS LENGTH
SOJLE A2,INIT3 ; EMPTY?
SETZM 1(A1) ; NO - ZERO FIRST FREE WORD
SOJE A2,INIT3 ; ANY MORE
HRLZI A0,1(A1) ; YES
HRRI A0,2(A1) ; PREPARE FOR BLT
ADDI A2,1(A1) ; SET UP END ADDRESS
BLT A0,(A2) ; AND ZERO AREA
INIT3: HRRZ A0,(A1)
JUMPN A0,INIT2 ; KEEP GOING IF MORE
MOVE A2,4(AX) ; GET COMPILER VERSION WORD
MOVEM A2,%SYS23(DB) ; AND SAVE IT
DATE A2,
MOVEM A2,%SYS3(DB) ; SAVE DATE IN %SYS3
MSTIME A0,
MOVEM A0,%SYS4(DB) ; SAVE TIME OF DAY IN %SYS4
MOVEI A1,0
RUNTIM A1,
MOVEM A1,%SYS5(DB) ; SAVE RUNTIME IN %SYS5
MUL A0,A1
ROT A1,(A2)
MOVEM A1,%RAND(DB) ; INITIALIZE %RAND
HRROS %DDTER(DB) ; SET REDIRECT CHAN # = -1 (TTY:)
SETOM %TTYCH(DB) ; [E132] SET TTY CHAN.NO. WORD TO -1
HRLZI A0,%ES-%DBL
HRRI A0,%ES-1(DB)
MOVEM A0,%ESP(DB) ; SET UP EMERGENCY STACK POINTER
MOVE A0,[JRST UUO]
MOVEM A0,%UUO+1(DB)
HRLZI A0,<JSR>B53
HRRI A0,%UUO(DB)
MOVEM A0,.JB41 ; SET UP UUO TRAP
MOVEI A0,APRERR
MOVEM A0,.JBAPR ; SET APR TRAP ADDRESS
MOVEI A0,APRFLG
APRENB A0, ; AND ENABLE TRAPS
SETOM %DDERD(DB) ; [E127] MARK NO ERROR DETECTED
MOVEI A0,FM6
MOVEM A0,.JBREN ; SET REENTER ADDRESS
EDIT(021); AX is clobbered by the debugger - make REE work.
MOVEM AX,%ACCS+AX(DB) ; [E021] SAVE THE ONLY AC THAT MATTERS !
JUMPL AX,FM0 ; REENTER?
DDBEG%: ; LABEL DEFINED FOR ALGDDT 'START' COMMAND
INIT4: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP A1,CONCTR ; SET UP CONTROL-C TRAP
MOVEI A2,INIT8 ; "NO SECOND START" MESSAGE.
HRRM A2,.JBSA ; PREVENT 2ND. START.
EDIT(122); RESERVE IMPURE BLOCK (IN CASE OF /OTS:NONSHARE)
PUSHJ SP,TRSTD ; TELL TRACE IT'S THE
EXP .MAIN. ; [E122] MAIN PROGRAM
MOVEI DL,(DB) ; SET UP FOR LOCAL STACK
PUSHJ SP,@(AX) ; AND ENTER PROGRAM
XWD $PRO!$N!$SIM,1
; ************************* ; PROGRAM EXECUTES (HOPEFULLY!)
DDFIN%: ; LABEL DEFINED FOR ALGDDT 'FINISH' COMMAND
INIT5: SETZM .JBINT
MOVE A0,SP ;
HRRI A0,[ ;[206] SET DRT TRAPS
PUSHJ SP,REL0 ;[206] FOR
JRST INIT7] ;[206] TRAPS 46 AND 47
MOVEM A0,%TRAPS+46(DB) ;[206]
MOVEM A0,%TRAPS+47(DB) ;[206]
MOVEI A1,37
INIT6: PUSHJ SP,RELESE ; RELEASE IO CHANNELS
JFCL .+1
INIT7: SOJGE A1,INIT6
SETOM %CHAN(DB) ; MAKE SURE WE ARE ON CHANNEL -1!!!
PUSHJ SP,BRKBYT ; BREAK OUTPUT ON CHANNEL -1
JFCL .+1
MOVEI A1,END1
PUSHJ SP,MONIT
PUSHJ SP,BRKBYT
JFCL
MOVE A1,[-1,,.GTLIM] ; [243] SET UP GETTAB TABLE # FOR OUR JOB
GETTAB A1, ; [243] GET TABLE INFORMATION
LIBERR 5, ; [243] COMPLAIN IF GETTAB FAILS
TLNN A1,JB.LBT ; [243] IS THIS A BATCH JOB?
EXIT 1, ; [243] NO, JUST EXIT
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,STSPRT ; [243] YES, PRINT ALL STATS
EDIT(235) ; [235] FIX "REENTER" AFTER FATAL BOMB ON PTY
SETOM %DDERD(DB) ; [235] RESET ERROR COUNT TO 0
EXIT ; [235] RETURN TO MONITOR, UNCONTINUABLE
.MAIN.: EXP 0 ; [E122] PROGRAM PMB
XWD 3,12 ; [E122] WORDS,,CHARS
SIXBIT/MAIN.PROGRAM / ; [E122] ACTUAL TEXT
STSPR%:
STSPRT: MOVE A0,.JBREL ; CORE SIZE IN K
LSH A0,-12
ADDI A0,1
PUSHJ SP,IPRINT
MOVEI A1,END2
PUSHJ SP,MONIT
EDIT(041); DO STATISTICS, ETC. CORRECTLY
MOVEI A0,0 ; [E041]
RUNTIM A0, ; [E041]
SUBM A0,%SYS5(DB) ; [E041] EXECUTION TIME IN MS
EXCH A0,%SYS5(DB) ; [E041] GET DIFFERENCE, STORE NEW
PUSHJ SP,PRTIME ; [E041] PRINT IT
MOVEI A1,END3
PUSHJ SP,MONIT
MSTIME A0, ; [E041] GET TIME OF DAY
SUBM A0,%SYS4(DB) ; [E041] ELAPSED TIME IN MS
EXCH A0,%SYS4(DB) ; [E041] GET DIFFERENCE, STORE NEW
DATE A1, ; [E041]
SUBM A1,%SYS3(DB) ; [E041] ELAPSED DAYS
EXCH A1,%SYS3(DB) ; [E041] GET DIFFERENCE, STORE NEW
JUMPE A1,.+3 ; NONE
IMUL A1,[
EXP ^D24*^D60*^D60*^D1000]
ADD A0,A1 ; ALLOW FOR DAYS
PUSHJ SP,PRTIME ; [E041] PRINT ELAPSED TIME
MOVEI A1,END4
PUSHJ SP,MONIT
MOVEI A0,(DB)
SUB A0,%SYS21(DB) ; WORK OUT CURRENT (LARGEST) HEAP-SIZE
PUSHJ SP,IPRINT
MOVEI A1,END5
PUSHJ SP,MONIT
MOVE A0,%SYS20(DB) ; NUMBER OF STACK-SHIFTS
PUSHJ SP,IPRINT
IFN FTGETCHK,<
MOVEI A1,END6
PUSHJ SP,MONIT
MOVE A0,%SYS24(DB)
PUSHJ SP,IPRINT
> ; END OF FTGETCHK
PUSHJ SP,DCRLF
JRST DCRLF ; EXIT VIA DCRLF
RSTRT%:
INIT8: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
OUTSTR [ASCIZ/
?ALGNSS ALGOL programs cannot be STARTed twice.
/]
EXIT
END1: ASCIZ /
End of execution.
/
END2: ASCIZ /K core
Execution time:/
END3: ASCIZ /
elapsed time: /
END4: ASCIZ/
maximum heap size: /
END5: ASCIZ/, stack-shifts: /
IFN FTGETCHK,<
END6: ASCIZ/
maximum # of used words in heap-table: /
>
SUBTTL PRTIME - PRINT TIME ROUTINE
PRTIME: ADDI A0,5
IDIVI A0,^D10 ; TIME IN 1/100'THS SECS.
IDIVI A0,^D6000
JUMPE A0,PRTIM2 ; ANY MINUTES?
PUSH SP,A1 ; YES - SAVE SECONDS
IDIVI A0,^D60
JUMPE A0,PRTIM1 ; ANY HOURS?
PUSH SP,A1 ; YES - SAVE MINUTES
PUSHJ SP,IPRINT ; PRINT HOURS
MOVEI A1,PRTIM3
PUSHJ SP,MONIT
POP SP,A1 ; RESTORE MINUTES
PRTIM1: MOVE A0,A1
PUSHJ SP,IPRINT ; PRINT MINUTES
MOVEI A1,PRTIM4
PUSHJ SP,MONIT
POP SP,A1 ; RESTORE SECONDS
PRTIM2: MOVE A0,A1
HRLI A0,233000
FDVRI A0,207620
MOVEI A2,1
MOVEI A3,1
MOVEI A4,2
PUSHJ SP,PRINT. ; PRINT SECONDS AND 1/100'THS
MOVEI A1,PRTIM5
JRST MONIT0
PRTIM3: ASCIZ / hrs./
PRTIM4: ASCIZ / mins./
PRTIM5: ASCIZ / secs.
/
SUBTTL MONIT - MONITOR ROUTINE
; ENTERED WITH A1 = ADDRESS OF MESSAGE AT
; MONIT IF BREAK NOT REQUIRED
; MONIT0 IF BREAK REQUIRED
; MONSIX IF I/P IS IN SIXBIT (NO BREAK)
DCRLF: PUSHJ SP,CRLF ; DOUBLE CRLF
CRLF%:
CRLF: MOVEI A1,MONIT4 ; SPECIAL CR-LF ENTRY
MONIT0: TDZA A0,A0 ; CLEAR NO-BREAK FLAG
MONIT: MOVEI A0,1 ; SET NO-BREAK FLAG
MOVNI A2,1
EXCH A2,%CHAN(DB) ; FAKE CHANNEL -1
HRLI A1,440700 ; PREPARE ASCII BYTE-POINTER
SKIPGE A0, ; SIXBIT ?
TLZ A1,000100 ; YES - ADJUST BYTE-POINTER
MONIT1: ILDB A13,A1 ; GET NEXT BYTE
JUMPE A13,MONIT2 ; NULL?
SKIPGE A0, ; NO - SIXBIT ?
ADDI A13,40 ; YES - MAKE ASCII
PUSHJ SP,OUBYTE ; OUTPUT IT
JFCL MONIT1
JRST MONIT1
MONIT2: JUMPN A0,MONIT3 ; BREAK REQUIRED?
PUSHJ SP,BRKBYT ; YES - BREAK OUTPUT
JFCL MONIT3
MONIT3: MOVEM A2,%CHAN(DB) ; RESTORE IO CHANNELS
POPJ SP,0
MONIT4: ASCIZ /
/
MONSIX: MOVNI A0,1
JRST MONIT+1
SUBTTL FAULT MONITOR
FM0: MOVEI A1,FM3 ; INITIAL ENTRY ON REENTER
MOVEI DL,(DB) ; GIVE DEBUGGER SOMETHING TO WORK WITH.
PUSHJ SP,MONIT0 ;
MOVEI A0,FM15
MOVEM A0,.JBOPC ; SET UP SO DDT CONTIN WILL RETURN HERE
PUSH SP,AX ; ALGDDT TENDS TO CLOBBER THIS.
JRST %ALGDD
FM15: POP SP,AX
JRST INIT4 ;
FM3: ASCIZ /
!ALGOL diagnostic system
!(H for Help) /
TRACE1: ASCIZ/
%ALGNTL No trace list entries
/
TRACE2: ASCIZ/
!
!ALGOL postmortem trace (latest first)
/
PRFMES: ASCIZ/
Profile Print.
Count Name
----- ----
/
SUBTTL Control-C Logic
CNCTR%:
CONCTR: MOVE A0,[-1,,.GTLIM] ; [243] SET UP GETTAB TABLE # FOR OUR JOB
GETTAB A0, ; [243] GET TABLE INFORMATION
LIBERR 5, ; [243] COMPLAIN IF GETTAB FAILS
TLNE A0,JB.LBT ; [243] IS THIS A BATCH JOB?
JRST (A1) ; [243] YES, JUMP TO WHERE A1 POINTS
MOVE A0,[XWD 4,CONC] ; [243] NO, KEEP GOING
MOVEM A0,%CONC(DB)
MOVEI A0,CONCF ; [E1014]
MOVEM A0,%CONC+1(DB)
SETZM %CONC+2(DB) ; MONITOR REQUIRES THIS TO BE ZEROED.
MOVEI A0,%CONC(DB)
MOVEM A0,.JBINT ; SET UP CONTROL-C TRAP
PJOB A0, ;[214] DO DUMMY UUO TO FOOL PA1050
JRST (A1)
CONC: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEM A1,.JBBLT## ; SAVE A1 IN A FIXED LOCATION
HRRZ A1,.JBINT## ; GET ADDRESS OF INTERRUPT BLOCK
CAIN A1,%CONC(DB) ; ARE WE IN THE STACK-SHIFTER ?
JRST CONCOK ; NO - NORMAL TRAP ACTION
MOVEM A2,.JBBLT##+1 ; YES - SAVE A2 AS WELL
MOVE A2,2(A1) ; GET CONTROL-C PC
SETZM 2(A1) ; AND CLEAR IT FOR MONITOR
EXCH A2,.JBBLT##+1 ; RESTORE A2,SAVE PC
MOVE A1,.JBBLT## ; RESTORE A1 CONTENTS
SKIPN %DDTCC(DB) ; IF NO TRAP YET PENDING,
HLLOS %DDTPC(DB) ; [E114] SET UP AS SOON AS POSSIBLE
JRST @.JBBLT##+1 ; AND CONTINUE EXECUTION
CONCOK: MOVE A1,.JBBLT## ; GET CORRECT A1 CONTENTS
SETZM .JBINT ; CONTROL-C - TURN IT OFF
MOVEM A0,%ACCS+A0(DB)
HLRZ A0,%CONC+3(DB)
CAIE A0,CONCF ; WAS IT CONTROL-C?
EXIT 1, ; NO - STOP
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVE A0,%CONC+2(DB)
MOVEM A0,.JBOPC ; SAVE PC
HRLZI A0,A1
HRRI A0,%ACCS+A1(DB)
BLT A0,%ACCS+SP(DB) ; SAVE AC'S
SKIPE %DDTCC(DB) ; ALREADY SEEN A CONTROL-C ?
JRST DO.CNC ; YES - TRAP ANYWAY
HRRZ A4,.JBOPC ; NO - GET P.C.
TRNE A4,400000 ; IN OTS ?
JRST OTSCNC ; YES - HANDLE DIFFERENTLY
JRST NXTCNC ; NO - TRY TO DO A 'NEXT'
DO.CNC: SETZM %DDTCC(DB) ; SAY CONTROL-C NOTICED
PUSHJ SP,BRKBYT ; FINISH OUTPUT
JFCL
MOVEI A1,[ASCIZ/
Stopped
/]
PUSHJ SP,MONIT
;[E127] 3 lines moved
JRST FM6A
CNC.AX::SKIPLE %DDTCC(DB) ; [E114] IF NOT ^C PENDING,
;
; Edit(1007) Ensure AX points below heap (avoids stack shifts)
;
CAML AX,%SYS21(DB) ; [E1007] or AX not in program
JRST (AX) ; JUST BRANCH
SETZM .JBINT## ; O.K. - TURN OFF ^C TRAP
HRRZM AX,.JBOPC## ; SAVE USER PC
MOVEM A0,%ACCS+A0(DB) ; AND USER ACCS
MOVSI A0,A1 ; ..
HRRI A0,%ACCS+A1(DB) ; ..
BLT A0,%ACCS+SP(DB) ; ..
NXTCNC: PUSHJ SP,DDT.CC## ; GO TRY TO SET UP AUTOMATIC NEXT
; **** DOES NOT RETURN IF SUCCESSFUL !
; C[E127] NO CONTEXT - CARRY ON UNTIL WE CAN STOP PROPERLY
OTSCNC: HLLOS %DDTCC(DB) ; [E114] SET R.H. OF %DDTCC TO ALL ONES
JRST FM9B ; AND CONTINUE
FM6: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
TLNE DB,INDDT ; [E127] LATER REENTER ENTER
JRST %DDREE## ; [E127] IF IN DDT GO TO CMD LVL
MOVEM A0,%ACCS+A0(DB)
HRLZI A0,A1
HRRI A0,%ACCS+A1(DB)
BLT A0,%ACCS+SP(DB) ; YES - SAVE ACCUMULATORS
PUSHJ SP,BRKBYT ; CLEAR OUTPUT
JFCL .+1
FM6A: TLO DB,TMPFL3 ; [E127]TELL HSTPRT NOT TO TYPE IF EXPERT.
EDIT (201); DELOCATE SP WHEN ABOUT TO ENTER ALGDDT ON CONTROL-C
MOVE A4,SP ;[201] GET SP
SUBI A4,0(DB) ;[201] DELOCATE IT
MOVEM A4,%ACCS+SP(DB) ;[201] AND SAVE IT
HRRZ A4,.JBOPC## ; [E127] GET PC OF ERROR
PUSHJ SP,PR.HST## ; [E127] HISTORY PRINT.
TLZ DB,INDDT
SETZM %SYS17(DB) ; INDICATE NO ERROR
MOVEI A1,FM3
PUSHJ SP,MONIT0
JRST %ALGDD ; JUMP TO DEBUGGER
DDCON%: ; LABEL DEFINED FOR ALGDDT 'CONTINUE' COMMAND
SKIPE %SYS17(DB) ; WAS IT AN ERROR
JRST FM9A ; YES
FM9B: JSP A1,CONCTR ; RESTORE CONTROL-C INTERCEPT
HRLZI A0,%ACCS+A1(DB)
HRRI A0,A1
BLT A0,A13
MOVE AX,%ACCS+AX(DB) ; DON'T RESTORE DB,DL,SP.
MOVE A0,%ACCS+A0(DB) ; RESTORE ACCUMULATORS
JRSTF @.JBOPC ; AND RETURN TO PROGRAM
EDIT(105); Force "Can't continue" error message out immediately
FM9A: MOVEI A1,FM13
PUSHJ SP,MONIT0 ; [E105] CANNOT CONTINUE
JRST %ALGDD ; JUMP TO DEBUGGER.
FM13: ASCIZ /
Can't continue after this error
/
SUBTTL PARAM - PROCEDURE CALL PARAMETER HANDLER
; MAGIC PARAMETER TYPE MATCH TABLE
; LH: FORMAL PARAMETER ENTRY
; RH: ACTUAL PARAMETER ENTRY
TYPTAB: XWD 421030,000000 ; "WILD" VARIABLE
XWD 421020,000000 ; ARITHMETIC/BOOLEAN
XWD 421022,000000 ; ARITHMETIC/BOOLEAN/NONTYPE
XWD 400020,000000 ; INTEGER/BOOLEAN
XWD 021000,000000 ; "WILD" FLOATING
XWD 000000,000000
XWD 000000,000000
XWD 444000,700000 ; INTEGER
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 222000,070000 ; REAL
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 111000,007000 ; LONG REAL
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000500,000600 ; COMPLEX
XWD 000240,000140 ; LONG COMPLEX
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 421000,000000 ; "WILD" ARITHMETIC
XWD 000000,000000
XWD 000000,000000
XWD 000020,000020 ; BOOLEAN
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000004,000004 ; LABEL
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000002,000002 ; NON-TYPE
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000010,000010 ; STRING
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
XWD 000000,000000
; PROCEDURE CALLS ARE FORMATTED AS FOLLOWS:
; PUSHJ SP,PROC
; XWD ATYPE,N+1
; XWD AT1,AA1
; XWD AT2,AA2
;
; ...............
;
; XWD ATN,AAN
; WHERE N = NUMBER OF ACTUAL PARAMETERS
; ATYPE = TYPE OF PROCEDURE REQUIRED
; ATI = TYPE OF I'TH ACTUAL PARAMETER
; AAI = ADDRESS OR VALUE OF I'TH ACTUAL PARAMETER
; THE PROCEDURE HEAD IS FORMATTED AS FOLLOWS:
; XWD DL,NA ; IF PAR0 ENTRY
; PROC: JSP AX,PARAM ; OR PAR0
; EXP PM-BLOCK-ADDRESS
; XWD PL,L
; XWD FTYPE,M+1
; XWD FT1,FA1
; XWD FT2,FA2
;
; ...............
;
; XWD FTM,FAM
; WHERE M = NUMBER OF FORMAL PARAMETERS
; PL = PROCEDURE LEVEL
; L = LENGTH OF FIXED STACK REQUIRED (NOT INCLUDING DISPLAY)
; FTYPE = TYPE OF PROCEDURE
; FTI = TYPE OF I'TH FORMAL PARAMETER
; FAI = ADDRESS OF I'TH FORMAL PARAMETER (RELATIVE TO DL)
; NA = ADDRESS FOR NUMBER OF ACTUAL PARAMETERS (PAR0 ONLY)
; TYPE ABBREVIATIONS:
; I INTEGER
; R REAL
; LR LONG REAL
; C COMPLEX (NOT IMPLEMENTED)
; LC LONG COMPLEX (NOT IMPLEMENTED)
; B BOOLEAN
; S STRING
; L LABEL
; N NON-TYPE (PROCEDURES ONLY)
SUBTTL PARAM - PROCEDURE TYPE HANDLING
PARAM: TDZA A1,A1 ; NORMAL ENTRY
PAR0: MOVEI A1,1 ; VARIABLE NUMBER OF PARAMETERS ENTRY
EDIT(100); Chain DL for debugger
MOVE A3,%DDTDL(DB) ; [E100] GET TOP-LEVEL DL
EXCH A3,(SP) ; [E100] STACK BEFORE PRGLNK
MOVEI A3,(A3) ; [E100] CLEAR PC FLAGS
HRRZ A0,(A3) ; NUMBER OF AP'S + 1
CAILE A3,(DB)
CAILE A3,(SP) ; IF THE LINK IS ABSOLUTE
JRST PAR5 ; THEN LEAVE IT ALONE
SUBI A3,(DB) ; OTHERWISE DELOCATE IT
HRLI A3,DB ; AND PUT IN THE DB BITS
PAR5: PUSH SP,[0] ; [E127] SAVE SPACE FOR LINKPC
PUSH SP,A3 ; [E100] PUT PRGLNK ON STACK
ADDM A0,(SP) ; ADVANCE LINK OVER AP'S
AOS %TRLV(DB) ; UPDATE DYNAMIC BLOCK COUNT
PUSH SP,0(AX) ; SAVE PMB POINTER
HRRZ A2,2(AX) ; NUMBER OF FP'S + 1
XCT [
CAIE A0,(A2)
CAILE A0,(A2)](A1) ; CHECK ON NUMBER OF PARAMETERS
SYSER1 10,0 ; WRONG
MOVE A4,DL ; GET CONDL INTO A4
SUBI A4,(DB) ; DELOCATE AND
PUSH SP,A4 ; SAVE CONTEXT DL
PUSH SP,[0] ; INITIALIZE BLOCK POINTER
HLLZ A5,1(AX) ; SAVE PROCEDURE LEVEL
PUSH SP,A5 ; AND INITIALIZE BLOCK LEVEL
MOVEI DL,1(SP) ; SET UP NEW DL
HLRZ A5,A5 ; PROCEDURE LEVEL
TLNE A4,-1 ; IS THIS PROCEDURE PARAMETRIC?
HLRZ A4,A4 ; YES - USE ENVIRONMENT
ADDI A4,(DB)
PAR1: SOJL A5,PAR2 ; LEVELS EXHAUSTED?
PUSH SP,(A4) ; NO - COPY DISPLAY ELEMENT
AOJA A4,PAR1 ; AND ADVANCE OLD DL
PAR2: MOVEI A4,(DL)
SUBI A4,(DB)
TLO A4,DB
PUSH SP,A4 ; ADD NEW DL
AOS %DDTPL(DB) ; UPDATE DYNAMIC PROCEDURE LEVEL
MOVEM A4,%DDTDL(DB) ; [E100] REMEMBER THIS DL
HLRZ A5,@A3
ANDI A5,$TYPE
LSH A5,-11 ; TYPE OF PROCEDURE REQUIRED
HRLZ A5,TYPTAB(A5) ; GET TABLE ENTRY FOR IT
HLRZ A6,2(AX)
ANDI A6,$TYPE
LSH A6,-11 ; TYPE OF PROCEDURE
JUMPN A5,.+2 ; ANY ACTUAL TYPE BITS?
HRLZ A5,TYPTAB(A6) ; NO - FIX FOR SPRO5!!!
AND A5,TYPTAB(A6) ; GATE TABLE ENTRIES
JFFO A5,PAR4 ; AND SORT IT OUT!!!!!!!
PAR3: SYSER1 7,0 ; MISMATCH
PAR4: SKIPN A5,PAR8(A6) ; GET MATCH ENTRY
JRST PAR3 ; NO GOOD
PUSH SP,A5 ; YES - PLANT IN EXIT FORMAL
HRRZ A5,1(AX) ; GET FIXED STACK LENGTH
CAIE A6,16 ; [E054] IS THIS A STRING PROCEDURE ?
JRST .+4 ; [254][E054] NO - RESERVE ONE MORE WORD
SUBI A5,2 ; [254] YES
PUSH SP,[0] ; [254] INITIALIZE TO NULL STRING
PUSH SP,[0] ; [254][E054] CLEAR SECOND WORD OF HEADER
ADDI SP,-1(A5) ; [254][E054] AND ADVANCE STACK
MOVE A5,.JBREL
CAIG A5,2(SP) ; STACK STILL IN CORE
CCORE 1(A5) ; NO - TRY TO EXPAND
SUBTTL PARAM - MAIN CONTROL LOOP OF PARAMETER HANDLER
MOVEI A5,(SP)
SUB A5,.JBREL
HRLI SP,(A5) ; SET UP LH NEGATIVE COUNT
MOVE A13,SP
SUBI A13,(DB)
PUSH SP,A13 ; MAKE FIRST BLOCK POINTER
AOBJN A13,.+1
PUSH SP,A13 ; AND ANOTHER TO ENCLOSE VALUE ARRAYS
AOBJN A13,.+1
MOVEM A13,BLKPTR(DL) ; AND SET UP POINTER
MOVN A13,A0
HRLZI A13,(A13)
HRRI A13,2(AX) ; COUNTER/POINTER TO FP'S
ADDI A2,2(AX)
ADDI A3,1 ; MOVE TO FIRST AP
MOVEM A2,LINKPC(DL) ; [E127] SAVE RETURN ADDRESS
JUMPE A1,PAR6 ; PAR0 ENTRY?
MOVEM A0,@-2(AX) ; YES - FILL IN NUMBER OF AP'S
PAR6: AOBJP A13,PAR9 ; EXIT IF NO MORE PARAMETERS
HRRZ A2,@A3 ; GET AP ADDRESS
MOVE A4,(A13) ; GET FP WORD
ADDI A4,(DL) ; AND RELOCATE IT
HLLZ A5,@A3 ; GET LEFT HALF OF AP WORD
SETZB A6,A10
ROTC A5,3 ; SHIFT STATIC/DYNAMIC AND KIND TO A6
EXCH A6,A10 ; AND THEN TO A10
ROTC A5,6 ; SHIFT TYPE TO A6
ROT A5,3
ANDI A5,<$STAT>B41 ; AND GET STATUS IN A5
HLRZ A7,A4
HRRZ A11,A7
ANDI A11,$KIND
LSH A11,-17 ; GET KIND OF FP
ANDI A7,$TYPE
LSH A7,-11 ; GET TYPE OF FP
CAIN A6,<$S>B44 ; STRING?
CAIE A10,4 ; YES - DYNAMIC VARIABLE?
JRST PAR10 ; NO
JUMPE A5,PAR10 ; SIMPLE AS WELL?
MOVEI A10,10 ; NO - RECODE AS SPECIAL
MOVEI A6,<$I>B44 ; - TYPE IS INTEGER
PAR10: HRLZ A6,TYPTAB(A6) ; GET ENTRY FOR AP TYPE
AND A6,TYPTAB(A7) ; GATE WITH ENTRY FOR FP TYPE
JFFO A6,@PAR7(A10) ; SORT IT OUT AND BRANCH!!!!!!!
EDIT (202);
HRRZ DL,CONDL(DL) ;[202] GET DL TO BE CONTEXT DL
ADDI DL,0(DB) ;[202] AND RELOCATE IT
SYSER1 7,0 ; MISMATCH
PAR7: JRST @SVAR(A11) ; STATIC, VARIABLE
JRST @SEXP(A11) ; STATIC, EXPRESSION
JRST @SARR(A11) ; STATIC, ARRAY
JRST @SPRO(A11) ; STATIC, PROCEDURE
JRST @DVAR(A11) ; DYNAMIC, VARIABLE
JRST @DEXP(A11) ; DYNAMIC, EXPRESSION
JRST PAR3 ; DYNAMIC, ARRAY (IMPOSSIBLE)
JRST PAR3 ; DYNAMIC, PROCEDURE (IMPOSSIBLE)
JRST @BVAR(A11) ; DYNAMIC SIMPLE VARIABLE STRING (BYTE)
SUBTTL PARAM - STATIC VARIABLE HANDLER
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
SVARD: XWD SVAR32,SVAR2 ; I -> I
XWD SVAR33,SVAR3 ; I -> R
XWD SVAR34,SVAR7 ; I -> LR
XWD SVAR35,SVAR11 ; R -> I
XWD SVAR32,SVAR2 ; R -> R
XWD SVAR36,SVAR15 ; R -> LR
XWD SVAR37,SVAR19 ; LR -> I
XWD SVAR38,SVAR23 ; LR -> R
XWD SVAR39,SVAR43 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD SVAR32,SVAR2 ; B -> B
XWD SVAR40,SVAR28 ; S -> S
XWD 0,0 ; L -> L [E053] LABELS HANDLED SPECIALLY
XWD 0,0 ; N -> N
SVAR: XWD 0,SVAR0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
EDIT(053); HANDLE FORMAL LABELS CORRECTLY.
SVAR0: CAIN A5,<$FON>B41 ; FORMAL VARIABLE?
JRST FSVR0 ; YES - SPECIAL TREATMENT
CAIN A7,17 ; [E053] LABEL ?
JRST SVAR24 ; [E053] YES - SPECIAL TREATMENT
CAIN A5,<$OWN>B41 ; FIXED VARIABLE?
JRST SVAR1 ; YES
HLRZ A6,@A3
ANDI A6,$P ; GET VARIABLE LEVEL (P ADDRESS)
ADD A6,CONDL(DL) ; ADDRESS OF DISPLAY ENTRY
ADDI A6,(DB) ; AND RELOCATE
ADD A2,(A6) ; ADD TO Q ADDRESS
SVAR1: SKIPN A6,SVARD(A7) ; LOAD UP DISPATCH ENTRY
JRST PAR3 ; ILLEGAL
TLNE A4,$VAL ; FORMAL BY VALUE?
MOVS A6,A6 ; YES - SWAP HALVES
JRST (A6) ; AND DISPATCH
; I -> I, R -> R, B -> B, BY NAME
SVAR2: TLO A2,<MOVE A0,0>B53
MOVEM A2,(A4)
TLO A2,<MOVEM A0,0>B53
MOVEM A2,1(A4) ; PLANT DIRECT CODE IN F[0],F[1]
AOJA A3,PAR6
; I -> R, BY NAME
EDIT(002); SET UP A2 ON XCTA WHEN TYPE CONVERSION IS NEEDED
SVAR3: DMOVE A5,SVAR4
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR4: PUSHJ SP,SVAR5
PUSHJ SP,SVAR6
SVAR5: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
FLTR A0,A0
POPJ SP,0
SVAR6:
DVAR5: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
FIXR A3,A0 ; F[1] CODE
MOVEM A3,@A2
POPJ SP,0
; I -> LR, BY NAME
SVAR7: DMOVE A5,SVAR8
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR8: PUSHJ SP,SVAR9
PUSHJ SP,SVAR10
SVAR9: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
JSP AX,ILR
POPJ SP,0
SVAR10:
DVAR8: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP AX,SLRI ; F[1] CODE
MOVEM A3,@A2
POPJ SP,0
; R -> I, BY NAME
SVAR11: DMOVE A5,SVAR12
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR12: PUSHJ SP,SVAR13
PUSHJ SP,SVAR14
SVAR13: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
FIXR A0,A0
POPJ SP,0
SVAR14:
DVAR11: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
FLTR A3,A0 ; F[1] CODE
MOVEM A3,@A2
POPJ SP,0
; R -> LR, BY NAME
SVAR15: DMOVE A5,SVAR16
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR16: PUSHJ SP,SVAR17
PUSHJ SP,SVAR18
SVAR17: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
MOVEI A1,0
POPJ SP,0
SVAR18:
DVAR14: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP AX,SLRR ; F[1] CODE
MOVEM A3,@A2
POPJ SP,0
; LR -> I, BY NAME
SVAR19: DMOVE A5,SVAR20
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR20: PUSHJ SP,SVAR21
PUSHJ SP,SVAR22
SVAR21: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
ADDI A2,1
MOVE A1,@A2
SUBI A2,1
JSP AX,LRI
POPJ SP,0
SVAR22:
DVAR17: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP AX,SILR ; F[1] CODE
DMOVEM A3,@A2
POPJ SP,0
; LR -> R, BY NAME
SVAR23: DMOVE A5,SVAR25
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR25: PUSHJ SP,SVAR26
PUSHJ SP,SVAR27
SVAR26: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
MOVE A0,@A2
ADDI A2,1
MOVE A1,@A2
SUBI A2,1
JSP AX,LRR
POPJ SP,0
SVAR27:
DVAR20: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A2,@A2 ; F[1] CODE
MOVEM A0,(A2)
SETZM 1(A2)
POPJ SP,0
; LR -> LR, BY NAME
SVAR43: TLO A2,<DMOVE A0,0>B53
MOVEM A2,(A4)
TLO A2,<DMOVEM A0,0>B53
MOVEM A2,1(A4)
AOJA A3,PAR6
; S -> S, BY NAME
SVAR28: DMOVE A5,SVAR29 ; LOAD UP CODE
DMOVEM A5,(A4) ; PLANT INDIRECT CODE IN F[0],F[1]
MOVEM A2,2(A4) ; AND ADDRESS IN F[2]
AOJA A3,PAR6
SVAR29: PUSHJ SP,SVAR30 ; F[0] CODE
PUSHJ SP,SVAR44 ; F[1] CODE
;
; THIS SUBROUTINE RETURNS A STRING HEADER IN A0, A1.
;
SVAR30: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVEI A2,@-1(A2)
MOVE A2,2(A2)
DMOVE A0,@A2
POPJ SP,0
DVAR23: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
DMOVEM A0,@A2 ; F[1] CODE
POPJ SP,0
EDIT(055); REVISE ASSIGNMENT TO FORMAL STRINGS
SVAR44: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; [E055] SAVE R.H. STRING ON STACK
PUSH SP,A1 ; [E055] FOR CALL TO STRASS
DMOVE A0,@A2 ; [E055] LOAD UP STRING HEADER
JSP AX,STRASX ; [E055] LET STRASS DO THE WORK
DMOVEM A0,@A2 ; [E055] AND STORE NEW STRING
POPJ SP, ; [E055] RETURN
; I -> I, R -> R, B -> B, BY VALUE
SVAR32:
DVAR25: MOVE A0,@A2
DEXP18: MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; I -> R, BY VALUE
SVAR33:
DVAR26: MOVE A0,@A2
DEXP19: FLTR A0,A0
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; I -> LR, BY VALUE
SVAR34:
DVAR27: MOVE A0,@A2
DEXP20: JSP AX,ILR
DMOVEM A0,(A4) ; PLANT VALUE IN F[0],F[1]
AOJA A3,PAR6
; R -> I, BY VALUE
SVAR35:
DVAR29: MOVE A0,@A2
DEXP21: FIXR A0,A0
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; R -> LR, BY VALUE
SVAR36:
DVAR30: MOVE A0,@A2
DEXP22: MOVEM A0,(A4)
SETZM 1(A4) ; PLANT VALUE IN F[0],F[1]
AOJA A3,PAR6
; LR -> I, BY VALUE
SVAR37:
SEXP26:
DVAR31: DMOVE A0,@A2
DEXP23: JSP AX,LRI
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; LR -> R, BY VALUE
SVAR38:
SEXP27: DMOVE A0,@A2
JSP AX,LRR
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; LR -> LR, BY VALUE
SVAR39:
DVAR28:
SEXP29:
SARR2: DMOVE A0,@A2
DEXP25: DMOVEM A0,(A4) ; PLANT VALUE IN F[0],F[1]
AOJA A3,PAR6
; S -> S, BY VALUE
SVAR40:
SEXP28: DMOVE A0,@A2
EDIT(045); Pass strings by value correctly
DEXP26: MOVEI A2,(A4) ; [E045] GET LOCAL STACK ADDRESS
SUBI A2,(DB) ; [E045] AND DELOCATE IT
HRLI A2,(<Z @(DB)>) ; [E045] SET POINTER THROUGH STRING HEADER
EXCH A2,(SP) ; [E045] ADD TO LIST ON THE STACK
PUSH SP,A2 ; [E045] AND MAKE NEW BLOCK POINTER
MOVE A2,SP ; [E045] THEN GET DELOCATED TOP OF
SUBI A2,(DB) ; [E045] STACK FRAME AT THIS MOMENT
MOVEM A2,BLKPTR(DL) ; [E045] AND SAVE IT IN DISPLAY
PUSH SP,A0 ; [E045] PUSH POINTER TO THE ACTUAL
PUSH SP,A1 ; [E045] STRING ONTO THE STACK
JSP AX,STRAS0 ; [E045] GET A COPY OF THE ACTUAL BYTES
HRRZ A2,-1(SP) ; [E045] GET STRING HEADER ADDRESS
ADDI A2,(DB) ; [E045] AND RELOCATE IT
DMOVEM A0,(A2) ; [E045] AND POINT TO THE NEW STRING
AOJA A3,PAR6
; L -> L, BY NAME, BY VALUE
EDIT(053); MAKE FORMAL SWITCHES WORK PROPERLY
SVAR24: CAIN A5,<$FOV>B41 ; [E053] FORMAL LABEL BY VALUE ?
JRST FSVR0 ; [E053] YES - LABELS BY VALUE ARE SPECIAL
SVAR41:
DEXP17: MOVE A5,[
PUSHJ SP,SVAR42]
MOVEM A5,(A4) ; PLANT CODE IN F[0]
MOVEM A2,1(A4) ; [E053] LABEL ADDRESS IN F[1]
HRRZ A5,CONDL(DL) ; AND CONTEXT DL
HRLZM A5,2(A4) ; IN LEFT HALF OF F[2]
AOJA A3,PAR6
SVAR42: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A1,(SP) ; [E053] DONT OVERWRITE A2 YET !
SKIPA A1,-1(A1) ; [E053] GET XCT INSTRUCTION
MOVE A1,@A1 ; [E053] FOLLOW XCT CHAIN
HLRZ A0,@A1 ; [E053] GET THE TARGET INSTRUCTION
ANDI A0,777000 ; [E053] CLEAR AC AND INDEX FIELDS
CAIN A0,(XCT 0,0) ; [E053] WAS THIS AN XCT INSTRUCTION ?
JRST .-4 ; [E053] YES - FIND OUT WHAT IT POINTS TO
MOVEI AX,@A1 ; [E053] NO - GET FORMAL ADDRESS
MOVE A2,1(AX) ; [E053] NOW GET F[1]
TRNE A2,-1 ; [E053] IF SWITCH OUT OF RANGE
TLNE A2,-1 ; [E053] OR ALREADY A FORMAL
POPJ SP, ; [E053] THEN RETURN
SUBI AX,(DB) ; DELOCATE FORMAL ADDRESS
HRLZI A2,(AX)
HRRI A2,FORLAB ; AND PREPARE FOR FORLAB
POPJ SP,0
; FORMAL STATIC VARIABLES
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
FSVARD: XWD DEXP18,FSVR2 ; I -> I
XWD DEXP19,FSVR4 ; I -> R
XWD DEXP20,FSVR7 ; I -> LR
XWD DEXP21,FSVR10 ; R -> I
XWD DEXP18,FSVR2 ; R -> R
XWD DEXP22,FSVR13 ; R -> LR
XWD DEXP23,FSVR16 ; LR -> I
XWD DEXP24,FSVR19 ; LR -> R
XWD DEXP25,FSVR2 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD DEXP18,FSVR2 ; B -> B
XWD DEXP26,FSVR2 ; S -> S
XWD DEXP17,FLAB01 ; L -> L
XWD 0,0 ; N -> N
FSVR0: HLRZ A1,@A3
ANDI A1,$P ; VARIABLE LEVEL (P ADDRESS)
ADD A1,CONDL(DL) ; ADDRESS OF DISPLAY ENTRY
ADDI A1,(DB)
ADD A2,(A1) ; ADD TO Q ADDRESS
SKIPN A6,FSVARD(A7) ; LOAD UP DISPATCH TABLE ENTRY
JRST PAR3 ; ILLEGAL
TLNN A4,$VAL ; FORMAL BY NAME?
JRST FSVR1 ; YES
SKIPA A5,A2 ; NO - GET ADDRESS IN A5
DEXP14: MOVEI A5,[
PUSHJ SP,(A2)] ; DYNAMIC EXPRESSION ENTRY
MOVS A6,A6 ; TAKE LEFT HALF OF DISPATCH ENTRY
PUSH SP,A6 ; AND SAVE IT
PUSH SP,A3
DPUSH A4
PUSH SP,A13 ; SAVE VALUABLE ACCUMULATORS
MOVEI A1,(DL)
DPUSH DL ; SAVE CURRENT DL
HRRZ DL,CONDL(A1)
ADDI DL,(DB)
XCT @A5 ; EVALUATE FORMAL OR THUNK
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE DL
POP SP,A13
RPOP A4
POP SP,A3 ; RESTORE VALUABLE ACCUMULATORS
POP SP,A6 ; AND DISPATCH ADDRESS
JRST (A6) ; DISPATCH
FSVR1: HRL A2,(A1) ; GET CORRECT DL
FSVR22: MOVEM A2,2(A4) ; AND PLANT IN F[2]
DMOVE A5,(A6)
DMOVEM A5,(A4) ; AND CODE IN F[0],F[1]
AOJA A3,PAR6
; ROUTINES FOR HANDLING ACTUALS THAT ARE ARE FORMALS
FSVRC0: MOVE A2,-1(SP) ; INDIRECT ENTRY ON F[0]
MOVE A0,-1(A2) ; GET XCT ORDER
MOVEI A2,@A0
MOVE AX,2(A2) ; GET CONTEXT DL AND ADDRESS
DPUSH DL ; SAVE CURRENT DL
HLRZ DL,AX ; AND ASSUME FORMAL'S DL
ADDI DL,(DB)
ADDI AX,(DB)
TLNE A0,$A ; XCTA?
JRST FSVRCA ; YES
XCT (AX) ; NO - GET VALUE OF FORMAL
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE CURRENT DL
POPJ SP,0
FSVRCA: XCT 1,(AX) ; GET ADDRESS OF FORMAL
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE CURRENT DL
POP SP,AX ; LOSE F[0]'S LINK
POPJ SP,0
; N.B. A2 IS SET UP FROM FSVRCA
EDIT(101); Remember values are stored on the stack
FSVRD1: MOVE A3,(SP) ; [E101] DIRECT ENTRY ON F[1]
JRST FSVRDC ; [E101] JOIN COMMON CODE
FSVRC1: SKIPA A3,-2(SP) ; [E101] INDIRECT ENTRY ON F[1]
FSVRC2: MOVE A3,-3(SP) ; [E101] DITTO, TWO WORD VARIABLE
FSVRDC: MOVEI A3,@-1(A3) ; [E101] ADD LABEL FSVRDC
MOVE AX,1(A3) ; GET CONTEXT DL AND ADDRESS
DPUSH DL ; SAVE CURRENT DL
HLRZ DL,AX ; AND ASSUME FORMAL'S DL
ADDI DL,(DB)
ADDI AX,(DB)
XCT 1(AX) ; STORE RESULT IN FORMAL
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE CURRENT DL
POPJ SP,0
; I -> I, R -> R, LR -> LR, B -> B, S -> S, L -> L, BY NAME
FSVR2: PUSHJ SP,FSVR3
PUSHJ SP,FSVRD1 ; DIRECT F[1] CODE
FSVR3: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
POPJ SP,0
; I -> R, BY NAME
FSVR4: PUSHJ SP,FSVR5
PUSHJ SP,FSVR6
FSVR5: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
FLTR A0,A0
POPJ SP,0
FSVR6: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; INDIRECT F[1] CODE
FIXR A0,A0
PUSHJ SP,FSVRC1
POP SP,A0
POPJ SP,0
; I -> LR, BY NAME
FSVR7: PUSHJ SP,FSVR8
PUSHJ SP,FSVR9
FSVR8: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
PUSH SP,AX ;[173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,ILR
POP SP,AX ;[173] RESTORE SAVED AX
POPJ SP,0
FSVR9: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; INDIRECT F[1] CODE
PUSH SP,A1
PUSH SP,AX ;[173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,LRI
POP SP,AX ;[173] RESTORE SAVED AX
PUSHJ SP,FSVRC2
POP SP,A1
POP SP,A0
POPJ SP,0
; R -> I, BY NAME
FSVR10: PUSHJ SP,FSVR11
PUSHJ SP,FSVR12
FSVR11: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
FIXR A0,A0
POPJ SP,0
FSVR12: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; INDIRECT F[1] CODE
FLTR A0,A0
PUSHJ SP,FSVRC1
POP SP,A0
POPJ SP,0
; R -> LR, BY NAME
FSVR13: PUSHJ SP,FSVR14
PUSHJ SP,FSVR15
FSVR14: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
MOVEI A1,0
POPJ SP,0
FSVR15: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; INDIRECT F[1] CODE
PUSH SP,A1
PUSH SP,AX ; [173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,LRR
POP SP,AX ; [173] RESTORE SAVED AX
PUSHJ SP,FSVRC2
POP SP,A1
POP SP,A0
POPJ SP,0
; LR -> I, BY NAME
FSVR16: PUSHJ SP,FSVR17
PUSHJ SP,FSVR18
FSVR17: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
PUSH SP,AX ;[173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,LRI
POP SP,AX ;[173] RESTORE SAVED AX
POPJ SP,0
FSVR18: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,A0 ; INDIRECT F[1] CODE
PUSH SP,AX ;[173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,ILR
POP SP,AX ;[173] RESTORE SAVED AX
PUSHJ SP,FSVRC1
POP SP,A0
POPJ SP,0
; LR -> R, BY NAME
FSVR19: PUSHJ SP,FSVR20
PUSHJ SP,FSVR21
FSVR20: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,FSVRC0 ; INDIRECT F[0] CODE
PUSH SP,AX ;[173] SAVE AX IN CASE OF RECURSIVE CALL
JSP AX,LRR
POP SP,AX ;[173] RESTORE SAVED AX
POPJ SP,0
FSVR21: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSH SP,0 ; INDIRECT F[1] CODE
MOVEI A1,0
PUSHJ SP,FSVRC1
POP SP,A0
POPJ SP,0
SUBTTL PARAM - STATIC EXPRESSION HANDLER
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
SEXPD: XWD SEXP21,SEXP1 ; I -> I
XWD SEXP22,SEXP5 ; I -> R
XWD SEXP23,SEXP6 ; I -> LR
XWD SEXP24,SEXP13 ; R -> I
XWD SEXP30,SEXP14 ; R -> R
XWD SEXP25,SEXP15 ; R -> LR
XWD SEXP26,SEXP16 ; LR -> I
XWD SEXP27,SEXP17 ; LR -> R
XWD SEXP29,SEXP18 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD SEXP21,SEXP1 ; B -> B
XWD SEXP28,SEXP18 ; S -> S
XWD 0,0 ; L -> L
XWD 0,0 ; N -> N
SEXP: XWD 0,SEXP0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
SEXP0: SKIPN A6,SEXPD(A7) ; LOAD UP DISPATCH ENTRY
JRST PAR3 ; ILLEGAL
TLNE A4,$VAL ; FORMAL BY VALUE?
MOVS A6,A6 ; YES - SWAP HALVES
TRNE A5,<$REG>B41 ; REGULAR?
JRST (A6) ; YES - DISPATCH TO REGULAR ADDRESS
JRST 1(A6) ; NO - DISPATCH TO SIMPLE ADDRESS
; I -> I, B -> B, BY NAME
SEXP1: SKIPA A1,(A2) ; REGULAR
HRRZI A1,(A2) ; SIMPLE
MOVE A0,A1
SEXP2: MOVEM A0,2(A4) ; PLANT VALUE IN F[2]
DMOVE A5,SEXP3 ; PLANT INDIRECT CODE IN F[0]
DMOVEM A5,(A4) ; PLANT DIRECT CODE IN F[1]
AOJA A3,PAR6
SEXP3: PUSHJ SP,SEXP4
SYSER1 11,0
SEXP4: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVE A0,-1(A2)
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
MOVEI A2,@A0
MOVE A0,2(A2) ; VALUE
POPJ SP,0
; I -> R, BY NAME
SEXP5: SKIPA A1,(A2) ; REGULAR
HRRZI A1,(A2) ; SIMPLE
MOVE A0,A1
FLTR A0,A0
JRST SEXP2
; I -> LR, BY NAME
SEXP6: JRST SEXP10 ; REGULAR
HRRZI A0,(A2) ; SIMPLE
FSC A0,233
SEXP7: MOVEM A0,2(A4) ; PLANT VALUE IN F[2]
DMOVE A5,SEXP8 ; PLANT INDIRECT CODE IN F[0]
DMOVEM A5,(A4) ; PLANT DIRECT CODE IN F[1]
AOJA A3,PAR6
SEXP8: PUSHJ SP,SEXP9
SYSER1 11,0
SEXP9: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVE A0,-1(A2)
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
MOVEI A2,@A0
MOVE A0,2(A2) ; VALUE
MOVEI A1,0
POPJ SP,0
SEXP10: MOVE A0,(A2) ; REGULAR CASE
JSP AX,ILR
JUMPE A1,SEXP7 ; EASY CASE IF NO LOW WORD
MOVEM A2,2(A4) ; PLANT ADDRESS IN F[2]
DMOVE A5,SEXP11 ; PLANT INDIRECT CODE IN F[0]
DMOVEM A5,(A4) ; PLANT DIRECT CODE IN F[1]
SEXP11: PUSHJ SP,SEXP12
SYSER1 11,0
SEXP12: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVE A0,-1(SP)
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
MOVEI A2,@A0
MOVE A0,@2(A2) ; VALUE
JSP AX,ILR
POPJ SP,0
; R -> I, BY NAME
SEXP13: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVE A0,A1
FIXR A0,A0
JRST SEXP2
; R -> R, BY NAME
SEXP14: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVE A0,A1
JRST SEXP2
; R -> LR, BY NAME
SEXP15: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVE A0,A1
JRST SEXP7
; LR -> I, BY NAME
SEXP16: DMOVE A0,(A2)
JSP AX,LRI
JRST SEXP2
; LR -> R, BY NAME
SEXP17: DMOVE A0,(A2)
JSP AX,LRR
JRST SEXP2
; LR -> LR, S -> S, BY NAME
SEXP18: MOVEM A2,2(A4) ; PLANT ADDRESS IN F[2]
DMOVE A5,SEXP19 ; PLANT INDIRECT CODE IN F[0]
DMOVEM A5,(A4) ; PLANT DIRECT CODE IN F[1]
AOJA A3,PAR6
SEXP19: PUSHJ SP,SEXP20
SYSER1 11,0
SEXP20: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE
MOVE A0,-1(A2)
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
MOVEI A2,@A0
HRRZ A2,2(A2)
DMOVE A0,(A2) ; VALUE
POPJ SP,0
; I -> I, B -> B, BY VALUE
SEXP21: SKIPA A1,(A2) ; REGULAR
HRRZI A1,(A2) ; SIMPLE
MOVEM A1,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; I -> R, BY VALUE
SEXP22: SKIPA A1,(A2) ; REGULAR
HRRZI A1,(A2) ; SIMPLE
MOVE A0,A1
FLTR A0,A0
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; I -> LR, BY VALUE
SEXP23: SKIPA A1,(A2) ; REGULAR
HRRZI A1,(A2) ; SIMPLE
MOVE A0,A1
JSP AX,ILR
DMOVEM A0,(A4) ; PLANT VALUE IN F[0],F[1]
AOJA A3,PAR6
; R -> I, BY VALUE
SEXP24: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVE A0,A1
FIXR A0,A0
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; R -> R, BY VALUE
SEXP30: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVEM A1,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
; R -> LR, BY VALUE
SEXP25: SKIPA A1,(A2) ; REGULAR
MOVSI A1,(A2) ; SIMPLE
MOVEM A1,(A4)
SETZM 1(A4) ; PLANT VALUE IN F[0],F[1]
AOJA A3,PAR6
SUBTTL PARAM - STATIC ARRAY HANDLER
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
SARRD: XWD SARR3,SARR2 ; I -> I
XWD SARR3,0 ; I -> R
XWD SARR3,0 ; I -> LR
XWD SARR3,0 ; R -> I
XWD SARR3,SARR2 ; R -> R
XWD SARR3,0 ; R -> LR
XWD SARR3,0 ; LR -> I
XWD SARR3,0 ; LR -> R
XWD SARR3,SARR2 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD SARR3,SARR2 ; B -> B
EDIT(045); String arrays by value don't work, so don't let users try
XWD SARR4,SARR2 ; S -> S
XWD 0,0 ; L -> L
XWD 0,0 ; N -> N
SARR: XWD 0,PAR3 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,SARR0 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
SARR0: CAIN A5,<$OWN>B41 ; FIXED VARIABLE?
JRST SARR1 ; YES
HLRZ A6,@A3
ANDI A6,$P ; GET VARIABLE LEVEL (P ADDRESS)
ADD A6,CONDL(DL) ; ADDRESS OF DISPLAY ENTRY
ADDI A6,(DB)
ADD A2,(A6) ; ADD TO Q ADDRESS
SARR1: HRRZ A6,SARRD(A7) ; LOAD UP NAME DISPATCH ENTRY
TLNE A4,$VAL ; FORMAL BY VALUE
HLRZ A6,SARRD(A7) ; YES - LOAD UP VALUE DISPATCH ENTRY
JUMPN A6,(A6) ; DISPATCH UNLESS
JRST PAR3 ; ILLEGAL
; ALL VALID COMBINATIONS, BY VALUE
EDIT(057); MAKE STRINGS BY VALUE AS WELL IN STRING ARRAYS
SARR3: TDZA AX,AX ; [E057] EVERYTHING EXCEPT STRING ARRAYS
SARR4: MOVEI AX,1 ; [E057] STRING ARRAYS - MORE DIFFICULT
MOVEI A1,@A2
PUSH SP,A3
PUSH SP,A13
PUSH SP,AX ; [E057] SAVE ARRAY TYPE FLAG
PUSH SP,A2 ; SAVE VALUABLE ACCS. AND HEADER ADDRESS
MOVE A1,1(A1) ; GET SECOND WORD OF HEADER
SARR5: PUSH SP,(A1) ; AND COPY DOPE VECTOR TO THE STACK
PUSH SP,1(A1)
ADDI A1,1
AOBJN A1,SARR5
HLRZ A1,A4 ; GET FP TYPE
ANDCMI A1,$STAT ; AND CLEAR STATUS BITS TO FOOL
; $OWN TEST IN ARRAY
MOVNI A3,1 ; ONE ARRAY
EXCH A2,A4 ; ADDRESS OF NEW HEADER
MOVEI A4,@A4
HLRE A4,1(A4) ; -NUMBER OF DIMENSIONS
JSP AX,ARRAY ; LAY OUT NEW ARRAY
POP SP,A1 ; RESTORE ADDRESS OF OLD HEADER
MOVEI A1,@A1 ; AND MAKE IT ABSOLUTE
SUBI A2,2 ; RETARD NEW ARRAY WORD POINTER
PUSH SP,A2 ; [E057] KEEP HEADER ADDRESS
PUSHJ SP,CPYARR ; AND COPY OLD TO NEW
POP SP,A2 ; [E057] GET HEADER ADDRESS AGAIN
POP SP,AX ; [E057] POP OFF POINTER LEFT BY ARRAY
EXCH AX,(SP) ; [E057] SWAP WITH ARRAY TYPE FLAG
JUMPE AX,SARR7 ; [E057] CARRY ON IF NOT STRING ARRAY
HRRZ A1,1(A2) ; [E057] GET ADDRESS OF DOPE VECTOR
HRRZ A2,-2(A1) ; [E057] GET SIZE OF ILIFFE VECTOR(S)
ADD A2,-1(A1) ; [E057] PICK UP POINTER OVER DATA
SARR6: PUSH SP,STR1(A2) ; [E057] PUSH STRING HEADER
PUSH SP,STR2(A2) ; [E057] ONTO THE STACK
JSP AX,STRAS0 ; [E057] FORM A COPY OF IT
DMOVEM A0,(A2) ; [E057] AND WRITE NEW HEADER
ADDI A2,1 ; [E057] STEP ON TO NEXT STRING
AOBJN A2,SARR6 ; [E057] AND REPEAT FOR ENTIRE ARRAY
SARR7: POP SP,A1 ; SAVE THE POINTER THAT ARRAY CREATED
POP SP,A13
POP SP,A3 ; RESTORE VALUABLE ACCS.
JSP AX,ARR16A ; [E057] ADJUST BLKPTR PROPERLY
AOJA A3,PAR6
SUBTTL PARAM - STATIC PROCEDURE HANDLER
SPRO: XWD 0,SPRO0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,SPRO0 ; PROCEDURE
EDIT(053); MAKE FORMAL SWITCHES WORK PROPERLY
SPRO0: CAIN A7,17 ; [E053] IS THIS A SWITCH ?
JRST SLAB0 ; [E053] YES - HANDLE IT
CAIE A5,<$FON>B41 ; IS THE ACTUAL A FORMAL?
JRST SPRO1 ; NO
HLRZ A6,@A3
ANDI A6,$P ; GET PROCEDURE LEVEL (P ADDRESS)
HRRZ A5,CONDL(DL) ; GET TRUE CONTEXT DL
ADDI A6,(A5) ; ADDRESS OF DISPLAY ENTRY
ADDI A6,(DB)
ADD A2,(A6) ; YES - ADD DISPLAY ELEMENT TO Q ADDRESS
HRLI A2,<XCT (DB)>B53
; AND PREPARE OPERATIONAL ORDER
JRST SPRO2
SPRO1: HRLI A2,<PUSHJ SP,0>B53
; IF NOT FORMAL, THIS IS THE ORDER
SPRO2: JUMPE A11,SPRO6 ; FORMAL PARAMETER A VARIABLE?
MOVEM A2,1(A4) ; NO - PLANT OPERATION IN F[1]
MOVE A5,%PROF0
MOVEM A5,(A4) ; PLANT ENTRY IN F[0]
MOVE A5,CONDL(DL)
MOVEM A5,2(A4) ; AND CONDL IN F[2]
AOJA A3,PAR6
%PROF0::PUSHJ SP,SPRO3 ; Defined internal for ALGDDT
; for breakpoint logic
SPRO3: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A1,(SP) ; F[0] CODE: GET LINK
MOVEI A2,@-1(A1) ; GET ADDRESS OF F[0]
%SPRO3::HRL DL,2(A2) ; GET ENVIRONMENT DL
; THE CONTENTS OF F[1] WILL BE
; EITHER "PUSHJ SP,ROUTINE"
; OR "XCT n(DB)", WHICH WILL
; BE ANOTHER CALL TO SPRO3
MOVEI A2,@1(A2) ; GET EFFECTIVE ADDRESS
MOVE A3,(A2) ; GET ADDRESSED INSTRUCTION
CAMN A3,%PROF0 ; ANOTHER CALL TO SPRO3 ?
JRST %SPRO3 ; YES - TRY AGAIN
JRST (A2) ; NO - GO TO ROUTINE
; CASE OF A PARAMETERLESS PROCEDURE ASSIGNED TO A VARIABLE
SPRO6: TLNE A4,$VAL ; FORMAL BY VALUE?
JRST SPRO9 ; YES
MOVEM A2,1(A4) ; PLANT OPERATIONAL ORDER IN F[1]
HLLZ A6,A4
TLZ A6,$KIND!$STAT
TLO A6,$PRO!$SIM ; CONSTRUCT MATCHED TYPE DESCRIPTOR
HRR A6,CONDL(DL) ; AND CONDL
MOVEM A6,2(A4) ; PLANT IN F[2]
MOVE A5,[
PUSHJ SP,SPRO7]
MOVEM A5,(A4) ; PLANT ENTRY IN F[0]
AOJA A3,PAR6
SPRO7: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP) ; F[0] CODE: GET LINK
MOVE A0,-1(A2) ; GET CALLING ORDER
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
CAILE A2,(DB)
CAILE A2,(SP) ; IF THE LINK IS ABSOLUTE
JRST SPRO14 ; THEN LEAVE IT ALONE
SUBI A2,(DB) ; OTHERWISE DELOCATE IT
HRLI A2,DB ; AND PUT THE DB BITS IN THE LH
MOVEM A2,(SP)
SPRO14: MOVEI A2,@A0 ; GET ADDRESS OF F[0]
MOVE A3,DL
DPUSH A3 ; SAVE CURRENT DL
PUSH SP,1(A2) ; STACK OPERATIONAL ORDER
MOVE A0,2(A2) ; GET F[2]
HRL DL,A0 ; SET UP CORRECT DL
HRRI A0,1 ; SET UP FOR NO ACTUALS
PUSH SP,A0 ; AND STACK TYPE DESCRIPTOR
PUSH SP,[
JRST SPRO8] ; STACK RETURN JUMP
JRST -2(SP) ; AND ENTER CALL SEQUENCE INTERLUDE
SPRO8: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
SUB SP,[3,,3] ; [303] GET RID OF UNWANTED STACK
RPOP DL ; RESTORE CURRENT DL
POP SP,AX
JRST @AX ; AND EXIT
SPRO9: PUSH SP,A3
DPUSH A4
PUSH SP,A13 ; SAVE VALUABLE ACCUMULATORS
MOVE A0,DL
DPUSH A0 ; SAVE CURRENT DL
HRRZ DL,CONDL(DL)
ADDI DL,(DB) ; AND ASSUME THAT OF CONTEXT
PUSH SP,A2 ; STACK OPERATIONAL ORDER
TLZ A4,$KIND!$STAT
TLO A4,$PRO!$SIM
HRRI A4,1 ; MAKE TYPE DESCRIPTOR
PUSH SP,A4 ; FROM FORMAL - AND STACK IT
PUSH SP,[
JRST SPRO10] ; STACK RETURN JUMP
JRST -2(SP) ; AND ENTER CALL SEQUENCE INTERLUDE
SPRO10: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
SUB SP,[3,,3] ; [303] GET RID OF UNWANTED STACK
RPOP DL ; RESTORE CURRENT DL
POP SP,A13
RPOP A4
POP SP,A3 ; RESTORE VALUABLE ACCUMULATORS
;
Edit(151); Don't assume result of formal procedure to be double length.
;
TLNN A4,$VAR2 ; [E151] Is the result double length ?
MOVEM A1,1(A4) ; [E151] Yes - plant the high order word
MOVEM A0,0(A4) ; [E151] Plant result in formal.
AOJA A3,PAR6
; CASE OF A SWITCH (LABEL PROCEDURE)
SLAB0: JUMPE A11,PAR3 ; [E053] CAN'T ASSIGN SWITCH TO LABEL
CAIE A5,<$FON>B41 ; [E053] IS THE ACTUAL A FORMAL ?
JRST SLAB1 ; [E053] NO - A2 CONTAINS ADDRESS OF CODE
HLRZ A1,@A3 ; [E053] YES - GET L.H. OF LEXEME
ANDI A1,$P ; [E053] MASK TO P ADDRESS
ADD A1,CONDL(DL) ; [E053] GET ADRESS OF DISPLAY
ADDI A1,(DB) ; [E053] ENTRY FOR CONTEXT
ADD A2,(A1) ; [E053] GET Q ADDRESS
SKIPA A5,FLAB01 ; [E053] LOAD A5 WITH "PUSHJ SP,FLABF0"
SLAB1: MOVE A5,[
PUSHJ SP,SWITCH] ; [E053] NON-FORMAL SWITCH - GET F[0] CODE
MOVEM A5,(A4) ; [E053] STORE INSTRUCTION IN F[0]
HRL A2,CONDL(DL) ; [E053] SET CONTEXT DL IN L.H. OF ADDRESS
MOVEM A2,2(A4) ; [E053] AND STORE IT INTO F[2]
AOJA A3,PAR6 ; [E053] GO DEAL WITH NEXT PARAMETER
; L -> L, SW -> SW WHEN ACTUALS ARE FORMALS
FLABL%: ; ENTRY POINT DEFINED FOR ALGDDT
FLAB01: PUSHJ SP,FLABF0 ; [E053] F[0] CODE
SYSER1 11,0 ; [E053] F[1] CODE
FLABF0: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVE A1,0(SP) ; [E053] DIRECT ENTRY ON F[0]
SKIPA A1,-1(A1) ; [E053] GET XCT ORDER
MOVE A1,@A1 ; [E053] FOLLOW XCT CHAIN
HLRZ A0,@A1 ; [E053] GET TARGET INSTRUCTION
ANDI A0,777000 ; [E053] MASK TO OPCODE ONLY
CAIN A0,(XCT 0,0) ; [E053] IS THIS ANOTHER XCT ?
JRST .-4 ; [E053] YES - REPEAT THIS STEP
MOVEI AX,@A1 ; [E053] NO - GET FORMAL ADDRESS
MOVE AX,2(AX) ; [E053] GET CONTEXT DL AND ADDRESS
DPUSH DL ; [E053] SAVE CURRENT DL
HLRZ DL,AX ; [E053] AND ASSUME FORMAL'S DL
ADDI DL,(DB) ; [E053] RELOCATE DL
ADDI AX,(DB) ; [E053] AND FORMAL ADDRESS
XCT (AX) ; [E053] GET VALUE OF FORMAL
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; [E053] RESTORE CURRENT DL
POPJ SP,0 ; [E053] AND RETURN
; ROUTINE TO EVALUATE A SWITCH PASSED AS A PARAMETER
SWITCH: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVE A1,0(SP) ; [E053] DIRECT ENTRY ON F[0]
MOVE A1,-1(A1) ; [E053] GET XCT INSTRUCTION
MOVEI AX,@A1 ; [E053] GET ADDRESS OF FORMAL
MOVE A1,AX ; [E053] AND SAVE THE ADDRESS
DPUSH A1 ; [E053] TO SET UP F[1]
DPUSH DL ; [E053] SAVE CURRENT DL
MOVE AX,2(AX) ; [E053] GET CONTENTS OF F[2]
HLRZ DL,AX ; [E053] GET CONTEXT DL
ADDI DL,(DB) ; [E053] RELOCATE IT
PUSHJ SP,(AX) ; [E053] EVALUATE THE SWITCH
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; [E053] RESTORE CURRENT DL
RPOP AX ; [E053] AND ADDRESS OF FORMAL
MOVEM A2,1(AX) ; [E053] STORE VALUE IN F[1]
TRNE A2,-1 ; [E053] IF OUT OF RANGE
TLNE A2,-1 ; [E053] OR ALREADY A FORMAL
POPJ SP, ; [E053] JUST RETURN
SUBI AX,(DB) ; [E053] OTHERWISE GET F[0] ADDRESS
HRLZI A2,(AX) ; [E053] IN LEFT HALF OF A2
HRRI A2,FORLAB ; [E053] AND FORLAB IN RIGHT HALF
POPJ SP, ; [E053] AND RETURN
SUBTTL PARAM - DYNAMIC VARIABLE HANDLER
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
DVARD: XWD DVAR25,DVAR1 ; I -> I
XWD DVAR26,DVAR3 ; I -> R
XWD DVAR27,DVAR6 ; I -> LR
XWD DVAR29,DVAR9 ; R -> I
XWD DVAR25,DVAR1 ; R -> R
XWD DVAR30,DVAR12 ; R -> LR
XWD DVAR31,DVAR15 ; LR -> I
XWD DVAR32,DVAR18 ; LR -> R
XWD DVAR28,DVAR21 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD DVAR25,DVAR1 ; B -> B
XWD SVAR40,DVAR44 ; S -> S
XWD 0,0 ; L -> L
XWD 0,0 ; N -> N
DVAR: XWD 0,DVAR0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
DVAR0: SKIPN A6,DVARD(A7) ; LOAD UP DISPATCH ENTRY
JRST PAR3 ; ILLEGAL
DVAR33: TLNE A4,$VAL ; FORMAL BY VALUE?
JRST DVAR24 ; YES
HRL A2,CONDL(DL) ; ADD CONTEXT DL TO THUNK ADDRESS
JRST FSVR22
; ROUTINE FOR EVALUATING DYNAMIC VARIABLE THUNKS
DVARC: MOVE A1,-1(SP)
PUSH SP,-1(A1) ; SAVE XCT(A) ORDER
MOVEI A1,@(SP)
MOVE A1,2(A1) ; GET THUNK'S DL AND ADDRESS
DPUSH DL ; SAVE CURRENT DL
HLRZ DL,A1 ; AND ASSUME THUNK'S
ADDI DL,(DB)
PUSHJ SP,(A1) ; EVALUATE THUNK
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE CURRENT DL
POP SP,A1 ; RESTORE XCT(A) ORDER
TLNE A1,$A ; XCTA?
POP SP,A1 ; YES - LOSE F[0]'S LINK
POPJ SP,0
; I -> I, R -> R, B-> B, BY NAME
DVAR1: PUSHJ SP,DVAR2
MOVEM A0,(A2) ; DIRECT F[1] CODE
DVAR2: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; INDIRECT F[0] CODE
MOVE A0,(A2)
POPJ SP,0
; I -> R, BY NAME
DVAR3: PUSHJ SP,DVAR4
PUSHJ SP,DVAR5
DVAR4: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
MOVE A0,(A2)
FLTR A0,A0
POPJ SP,0
; I -> LR, BY NAME
DVAR6: PUSHJ SP,DVAR7
PUSHJ SP,DVAR8
DVAR7: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
MOVE A0,(A2)
JSP AX,ILR
POPJ SP,0
; R -> I, BY NAME
DVAR9: PUSHJ SP,DVAR10
PUSHJ SP,DVAR11
DVAR10: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
MOVE A0,(A2)
FIXR A0,A0
POPJ SP,0
; R -> LR, BY NAME
DVAR12: PUSHJ SP,DVAR13
PUSHJ SP,DVAR14
DVAR13: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
MOVE A0,(A2)
MOVEI A1,0
POPJ SP,0
; LR -> I, BY NAME
DVAR15: PUSHJ SP,DVAR16
PUSHJ SP,DVAR17
DVAR16: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
DMOVE A0,(A2)
JSP AX,LRI
POPJ SP,0
; LR -> R, BY NAME
DVAR18: PUSHJ SP,DVAR19
PUSHJ SP,DVAR20
DVAR19: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
DMOVE A0,(A2)
JSP AX,LRR
POPJ SP,0
; LR -> LR, BY NAME
DVAR21: PUSHJ SP,DVAR22
PUSHJ SP,DVAR23
DVAR22: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
DMOVE A0,@A2
POPJ SP,0
; S-> S, BY NAME
DVAR44: PUSHJ SP,DVAR22
PUSHJ SP,SVAR44
; FORMAL BY VALUE
DVAR24: HLRZ A6,A6 ; TAKE LEFT HALF DISPATCH ENTRY
PUSH SP,A6 ; AND SAVE IT
PUSH SP,A3
DPUSH A4
PUSH SP,A13 ; SAVE VALUABLE ACCUMULATORS
MOVE A5,DL
DPUSH A5 ; SAVE CONTEXT DL
HRRZ DL,CONDL(DL)
ADDI DL,(DB) ; AND USE CONTEXT DL
PUSHJ SP,(A2) ; EVALUATE THUNK
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE DL
POP SP,A13
RPOP A4
POP SP,A3 ; RESTORE VALUABLE ACCUMULATORS
POP SP,A6 ; AND DISPATCH ADDRESS
CAIGE A6,BVAR10 ; BUT IT MIGHT BE A BYTE POINTER
TLZ A2,-1 ; CLEAR LEFT HALF OF POINTER.
JRST (A6) ; DISPATCH
; LR -> R, BY VALUE
DVAR32: DMOVE A0,(A2)
DEXP24: JSP AX,LRR
MOVEM A0,(A4) ; PLANT VALUE IN F[0]
AOJA A3,PAR6
SUBTTL PARAM - DYNAMIC EXPRESSION HANDLER
; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME
DEXPD: XWD DEXP18,DEXP1 ; I -> I
XWD DEXP19,DEXP2 ; I -> R
XWD DEXP20,DEXP4 ; I -> LR
XWD DEXP21,DEXP6 ; R -> I
XWD DEXP18,DEXP1 ; R -> R
XWD DEXP22,DEXP8 ; R -> LR
XWD DEXP23,DEXP10 ; LR -> I
XWD DEXP24,DEXP12 ; LR -> R
XWD DEXP25,DEXP1 ; LR -> LR
XWD 0,0 ; C -> C
XWD 0,0 ; C -> LC
XWD 0,0 ; LC -> C
XWD 0,0 ; LC -> LC
XWD DEXP18,DEXP1 ; B -> B
XWD DEXP26,DEXP27 ; S -> S
XWD DEXP17,DEXP15 ; L -> L
XWD 0,0 ; N -> N
DEXP: XWD 0,DEXP0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
DEXP0: SKIPN A6,DEXPD(A7) ; LOAD UP DISPATCH ENTRY
JRST PAR3 ; ILLEGAL
TLNE A4,$VAL ; FORMAL BY VALUE?
JRST DEXP14 ; YES
HRL A2,CONDL(DL) ; ADD CONTEXT DL TO THUNK ADDRESS
MOVEM A2,2(A4) ; AND PLANT IN F[2]
MOVE A5,[
SYSER1 11,0]
MOVEM A5,1(A4) ; PLANT F[1] CODE
MOVE A5,(A6)
MOVEM A5,(A4) ; PLANT F[0] CODE
AOJA A3,PAR6
; ROUTINE FOR EVALUATING DYNAMIC EXPRESSION THUNKS
DEXPDR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
SKIPA A2,(SP) ; DIRECT ENTRY
DEXPC: MOVE A2,-1(SP) ; INDIRECT ENTRY
MOVE A0,-1(A2) ; GET XCT ORDER
TLNE A0,$A ; ADDRESS REQUIRED?
SYSER1 11,0 ; YES - YOU LOSE
MOVEI A2,@A0
MOVE A2,2(A2) ; GET CONTEXT DL AND THUNK ADDRESS
DPUSH DL ; SAVE CURRENT DL
HLRZ DL,A2 ; AND ASSUME THUNK'S DL
ADDI DL,(DB)
PUSHJ SP,(A2) ; EVALUATE THUNK
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE CURRENT DL
POPJ SP,0
; I -> I, R -> R, B -> B, LR -> LR, BY NAME
DEXP1: PUSHJ SP,DEXPDR ; DIRECT F[0] CODE
; I -> R, BY NAME
DEXP2: PUSHJ SP,DEXP3
DEXP3: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
FLTR A0,A0
POPJ SP,0
; I -> LR, BY NAME
DEXP4: PUSHJ SP,DEXP5
DEXP5: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
JSP AX,ILR
POPJ SP,0
; R -> I, BY NAME
DEXP6: PUSHJ SP,DEXP7
DEXP7: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
FIXR A0,A0
POPJ SP,0
; R -> LR, BY NAME
DEXP8: PUSHJ SP,DEXP9
DEXP9: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
MOVEI A1,0
POPJ SP,0
; LR -> I, BY NAME
DEXP10: PUSHJ SP,DEXP11
DEXP11: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
JSP AX,LRI
POPJ SP,0
; LR -> R, BY NAME
DEXP12: PUSHJ SP,DEXP13
DEXP13: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
JSP AX,LRR
POPJ SP,0
; S -> S, BY NAME
DEXP27: PUSHJ SP,DEXP28
DEXP28: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DEXPC ; F[0] CODE
MOVEI A2,0
POPJ SP,0
; L -> L, BY NAME
DEXP15: PUSHJ SP,DEXP16
DEXP16: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HRRZ A2,(SP)
MOVEI AX,@-1(A2) ; GET ADDRESS OF FORMAL
EDIT(053); SAVE ADDRESS OF F[0] IN CASE IT WAS 'XCT'-ED BY AN "XCT (AX)"
MOVEI A2,(AX) ; [E053] GET PHYSICAL ADDRESS
DPUSH A2 ; [E053] AND SAVE IT (DELOCATED)
MOVE AX,2(AX) ; GET THUNK'S DL AND ADDRESS
DPUSH DL ; SAVE CURRENT DL
HLRZ DL,AX ; ASSSUME DL FOR LABEL
ADDI DL,(DB)
PUSHJ SP,(AX) ; EXECUTE THUNK
PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
RPOP DL ; RESTORE DL
RPOP AX ; [E053] RESTORE ADDRESS OF FORMAL
MOVEM A2,1(AX) ; AND STORE LABEL ADDRESS IN F[1]
TRNE A2,-1 ; SWITCH OUT OF RANGE?
TLNE A2,-1 ; NO - FORMAL?
POPJ SP,0 ; NO
SUBI AX,(DB)
HRLZI A2,(AX) ; YES - GET ADDRESS OF F[0]
HRRI A2,FORLAB ; AND LET FORLAB DO THE WORK
POPJ SP,0 ; IF REQUIRED
; BYTE VARIABLE (DYNAMIC SIMPLE VARIABLE STRING)
BVARD: XWD BVAR10,BVAR1 ; BYTE -> I
XWD BVAR11,BVAR4 ; BYTE -> R
XWD BVAR12,BVAR7 ; BYTE -> LR
BVAR: XWD 0,BVAR0 ; VARIABLE
XWD 0,PAR3 ; EXPRESSION
XWD 0,PAR3 ; ARRAY
XWD 0,PAR3 ; PROCEDURE
BVAR0: MOVE A6,BVARD(A7) ; LOAD UP DISPATCH ENTRY
JRST DVAR33
; BYTE -> I, BY NAME
BVAR1: PUSHJ SP,BVAR2
PUSHJ SP,BVAR3
BVAR2: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
LDB A0,A2
POPJ SP,0
BVAR3: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
DPB A0,A2 ; F[1] CODE
POPJ SP,0
; BYTE -> R, BY NAME
BVAR4: PUSHJ SP,BVAR5
PUSHJ SP,BVAR6
BVAR5: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
LDB A0,A2
FLTR A0,A0
POPJ SP,0
BVAR6: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
FIXR A3,A0 ; F[1] CODE
DPB A3,A2
POPJ SP,0
; BYTE -> LR, BY NAME
BVAR7: PUSHJ SP,BVAR8
PUSHJ SP,BVAR9
BVAR8: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
PUSHJ SP,DVARC ; F[0] CODE
LDB A0,A2
JSP AX,ILR
POPJ SP,0
BVAR9: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP AX,SLRI ; F[1] CODE
DPB A3,A2
POPJ SP,0
; BYTE -> I, BY VALUE
BVAR10: LDB A0,A2
JRST DEXP18
; BYTE -> R, BY VALUE
BVAR11: LDB A0,A2
JRST DEXP19
; BYTE -> LR, BY VALUE
BVAR12: LDB A0,A2
JRST DEXP20
; EXIT DESTINATION TABLE
EDIT(047); Do type conversion on procedure exit correctly
PAR8: JSP AX,FII ; [E047] I <- I
JSP AX,FRI ; [E047] I <- R
JSP AX,FLRI ; [E047] I <- LR
JSP AX,FIR ; [E047] R <- I
JSP AX,FRR ; [E047] R <- R
JSP AX,FLRR ; [E047] R <- LR
JSP AX,FILR ; [E047] LR <- I
JSP AX,FRLR ; [E047] LR <- R
JSP AX,FLRLR ; [E047] LR <- LR
0 ; [E047] C <- C
0 ; [E047] C <- LC
0 ; [E047] LC <- C
0 ; [E047] LC <- LC
JSP AX,FBB ; [E047] B <- B
JSP AX,FSS ; [E047] S <- S
0 ; [E047] L <- L
JSP AX,FNN ; [E047] N <- N
PAR9: PUSHJ SP,TRLMAN ; MAKE TRACE ENTRY
MOVE AX,LINKPC(DL) ; [E127] GET LINK PC
MOVEI DL,(DL) ; CLEAR LH OF DL
JRST CNC.AX
; EXIT SEQUENCES
FIR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,IR
JRST FNN0
FILR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,ILR
JRST FNN0
FRI: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,RI
JRST FNN0
FRLR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP A13,FNN0
MOVEI A1,0
JRST CNC.AX
FLRI: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,LRI
JRST FNN0
FLRR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,LRR
JRST FNN0
EDIT(054); RETURN VALUE CORRECTLY FROM STRING PROCEDURES
EDIT(224); CORRECT EDIT 054 [JBS 4/1/80]
FSS: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
JSP A13,FNN0 ; [E054] TIDY UP THE STACK
TLO A1,STRPRC ; [E054] MARK AS PROCEDURE RESULT
SETZ A2, ; [307] [E054] [224] POINT A2 TO HEADER IN A0
JRST CNC.AX ; [E054] AND EXIT
FNN: FII: FRR: FBB:
FLRLR: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
MOVEI A13,FX3
;
Edit(152); Save AX over possible stack shifts.
;
FNN0: SUBI AX,(DB) ; [E152] Delocate AX over GETOWN
TLO AX,DB ; [E152] "
MOVEI A0,0 ; SET UP FOR GETOWN TO DELETE
POP SP,A1 ; LOSE BLOCK POINTER
SOS %TRLV(DB) ; UPDATE TRACE DYNAMIC BLOCK-LEVEL
SOS %DDTPL(DB) ; AND PROCEDURE LEVEL
FX1: POP SP,A1 ; UNSTACK
JUMPL A1,FX2 ; BOTTOM BLOCK POINTER?
TLZE A1,(<Z 17,0>) ; [E057] IS THIS A STRING ARRAY ?
PUSHJ SP,DELSCN ; [E057] YES - DELETE SUB-STRINGS
MOVEI A1,@A1 ; [E045] GET REAL ADDRESS, IF STRING
JUMPE A1,FX1 ; [E045] DON'T DELETE NULL STRING
PUSHJ SP,GETOWN ; NO - DELETE ITEM
JRST FX1
FX2: MOVEI SP,PRGLNK(DL) ; RESET STACK POINTER
HRRZ DL,CONDL(DL) ; GET CONTEXT DL
ADDI DL,(DB) ; AND RELOCATE IT
MOVEI A1,(SP)
SUB A1,.JBREL
HRLI SP,(A1) ; SET UP LH OF STACK POINTER
MOVEI AX,@AX ; [E152] Relocate AX.
DMOVE A0,(AX) ; GET RESULT
POP SP,AX ; GET LINK
SUB SP,[1,,1] ; [E127] STEP OVER LINKPC
POP SP,%DDTDL(DB) ; [E100] RESET DL CHAIN
MOVEI AX,@AX ; STATICISE AX
JRST (A13) ; AND EXIT AS REQUIRED
FX3: JRST CNC.AX ; [E127]
SUBTTL GOLAB - GENERAL GOTO LABEL ROUTINE
; CALLED FROM LABEL WITH LINK IN AX
; WORD FOLLOWING CALL IS FORMATTED AS FOLLOWS:
; BITS 0 - 12: LEVEL OF BLOCK CONTAINING LABEL
; RELATIVE TO ENCLOSING PROCEDURE
; BITS 13 - 17: BITS FOR MODIFYING ADDRESS BY DL
; BITS 18 - 35: STATIC PROCEDURE LEVEL OF PROCEDURE
; ENCLOSING LABEL
GOLAB: HRRZ A13,@(AX) ; GET DESTINATION DL
ADDI A13,(DB) ; AND RELOCATE IT
EDIT(107); Make sure all local arrays, Etc. get deleted
GOLAB0: MOVEI DL,@%DDTDL(DB) ; [E107] SET DL TO TOP LEVEL
MOVEI A0,0 ; SET A0 FOR GETOWN TO DELETE
GOLAB1: CAIN A13,(DL) ; ARRIVED AT THE PROCEDURE LEVEL?
JRST GOLAB5 ; YES
HRRZ A12,PLBLKL(DL) ; GET BLOCK LEVEL
POP SP,A1 ; LOSE BLOCK POINTER
GOLAB2: SOS %TRLV(DB) ; ADJUST DYNAMIC BLOCK POINTER
SOJL A12,GOLAB4(A12) ; ANY MORE BLOCKS?
GOLAB3: POP SP,A1 ; UNSTACK
JUMPL A1,GOLAB2 ; BLOCK POINTER?
TLZE A1,(<Z 17,0>) ; [E057] IS THIS A STRING ARRAY ?
PUSHJ SP,DELSCN ; [E057] YES - DELETE SUB-STRINGS
MOVEI A1,@A1 ; [E045] GET REAL ADDRESS, IF A STRING
JUMPE A1,GOLAB3 ; [E045] DON'T DELETE IF NULL
SUBI A13,(DB) ; [304] DELOCATE TARGET BEFORE GETOWN
PUSHJ SP,GETOWN ; NO - DELETE ITEM
ADDI A13,(DB) ; [304] RELOCATE AFTER POSSIBLE STACK SHIFT
JRST GOLAB3
SKIPA DL,LINKDL(DL) ; 2ND TIME: GET PREVIOUS DL [E107]
GOLAB4: JRST GOLAB3 ; 1ST TIME: FUDGE FOR VALUE ARRAYS
SOS %DDTPL(DB) ; ADJUST PROCEDURE LEVEL
HRRM DL,%DDTDL(DB) ; [E100] RESET DL CHAIN
AOS %TRLV(DB) ; AND FUDGE 'COS 1 TOO MANY SOS'S
MOVEI DL,@DL ; RELOCATE DL
MOVE SP,BLKPTR(DL)
ADDI SP,(DB) ; GET BLOCK POINTER
JRST GOLAB1
GOLAB5: HRRZM AX,LINKPC(DL) ; [E127] STORE CONTEXT PC
AOS LINKPC(DL) ; [E127] POINT TO CORRECT PLACE
HLRZ A13,(AX)
LSH A13,-5 ; DESTINATION BLOCK LEVEL
HRRZ A12,PLBLKL(DL) ; CURRENT BLOCK LEVEL
HRRM A13,PLBLKL(DL) ; REPLACE BY LABEL BLOCK LEVEL
SUBI A12,(A13) ; FORM DIFFERENCE
JUMPE A12,GO.NXT## ; EXIT IF THERE
POP SP,A1 ; LOSE BLOCK POINTER
GOLAB8: SOS %TRLV(DB) ; DECREMENT FOR EACH BLOCK
GOLAB6: POP SP,A1 ; UNSTACK
JUMPL A1,GOLAB7 ; BLOCK POINTER?
TLZE A1,(<Z 17,0>) ; [E057] IS THIS A STRING ARRAY ?
PUSHJ SP,DELSCN ; [E057] YES - DELETE SUB-STRINGS
MOVEI A1,@A1 ; [E045] GET REAL ADDRESS, IF A STRING
JUMPE A1,GOLAB6 ; [E045] DON'T DELETE IF NULL
PUSHJ SP,GETOWN ; NO - DELETE ITEM
JRST GOLAB6
GOLAB7: SOJG A12,GOLAB8 ; ANY MORE BLOCKS?
PUSH SP,A1 ; AND ENTRY
MOVE A1,SP
SUBI A1,(DB)
MOVEM A1,BLKPTR(DL) ; RESET BLOCK POINTER
JRST GO.NXT## ; EXIT
; PRELUDE FOR GOING TO A FORMAL LABEL
%FRLAB::; Label for ALGDDT
FORLAB: PORTAL .+1 ; [303] HANDLE EXECUTE-ONLY
HLRZ A2,A2 ; GET ADDRESS OF FORMAL LABEL
ADDI A2,(DB)
MOVE A0,DL ; SAVE CURRENT DL
HLRZ DL,2(A2) ; GET LABEL'S DL
ADDI DL,(DB) ; AND RELOCATE IT
MOVE AX,1(A2) ; GET ADDRESS OF LABEL
HRRZ A13,@1(AX) ; GET DL OF DESTINATION
ADDI A13,(DB) ; AND RELOCATE IT
MOVE DL,A0 ; RESTORE CURRENT DL
AOJA AX,GOLAB0 ; AND SIMULATE JSP
EDIT(057); RETURN INDIVIDUAL STRING SPACE FOR STRING ARRAYS
DELSCN: PUSH SP,A1 ; [E057] SAVE TOTAL HEAP SPACE ADDRESS
MOVE A3,(A1) ; [E057] GET -# OF ARRAYS,,ILIFFE VECTOR SIZE
MOVE A2,1(A1) ; [E057] AND -DATA AREA SIZE,,FIRST ADDRESS
PUSH SP,A2 ; [E057] SAVE THESE ON THE STACK
DELSC1: PUSH SP,A3 ; [E057] FOR LOOP CONTROL
ADDI A2,(A3) ; [E057] STEP OVER ILIFFE VECTOR(S), IF ANY
DELSC2: MOVE A1,STR2(A2) ; [E057] GET NUMBER OF BYTES IN THE STRING
TDNE A1,[77,,777777] ; [E057] IF BYTE COUNT IS ZERO
SKIPN A1,STR1(A2) ; [E057] OR THIS IS A REAL NULL STRING
JRST DELSC3 ; [E057] THEN TRY THE NEXT ONE
MOVEI A1,(A1) ; [E057] OTHERWISE JUST GET ADDRESS
PUSH SP,A2 ; [E057] SAVE HEADER ADDRESS
SUBI A13,(DB) ; [304] DELOCATE TARGET BEFORE GETOWN
PUSHJ SP,GETOWN ; [E057] AND RETURN THE SPACE USED
ADDI A13,(DB) ; [304] RELOCATE AFTER POSSIBLE STACK SHIFT
POP SP,A2 ; [E057] RESTORE HEADER ADDRESS
DELSC3: ADDI A2,1 ; [E057] STEP TO NEXT HEADER, AND REPEAT
AOBJN A2,DELSC2 ; [E057] FOR EACH STRING IN THE ARRAY
POP SP,A3 ; [E057] THEN RESTORE COUNT OF ARRAYS
AOBJP A3,DELSC4 ; [E057] WAS THAT THE LAST ARRAY ?
HLL A2,(SP) ; [E057] NO - RESTORE COUNT OF STRINGS
SOJA A3,DELSC1 ; [E057] AND REPEAT FOR THE NEXT ARRAY
DELSC4: POP SP,A2 ; [E057] YES - LOSE SAVED POINTER
POP SP,A1 ; [E057] RESTORE ADDRESS OF ARRAY SPACE
POPJ SP, ; [E057] AND RETURN TO DELETE THE ARRAY
SUBTTL BLKBEG/BLKEND - BLOCK ENTRY/EXIT
BLKBEG: AOS PLBLKL(DL) ; INCREMENT BLOCK LEVEL
AOS %TRLV(DB) ; AND DYNAMIC BLOCK POINTER
PUSH SP,BLKPTR(DL) ; MAKE NEW BLOCK POINTER
MOVE A0,SP
SUBI A0,(DB)
MOVEM A0,BLKPTR(DL) ; AND RESET BLOCK POINTER
HRRZM AX,LINKPC(DL) ; [E127] STORE UPDATED PC
JRST CNC.AX
BLKEND: SOS PLBLKL(DL) ; DECREMENT BLOCK LEVEL
SOS %TRLV(DB) ; AND DYNAMIC BLOCK LEVEL
POP SP,BLKPTR(DL) ; RESET BLOCK POINTER
MOVEI A0,0 ; SET A0 FOR GETOWN
BLKE1: POP SP,A1 ; UNSTACK
JUMPL A1,BLKE2 ; BLOCK POINTER?
TLZE A1,(<Z 17,0>) ; [E057] IS THIS A STRING ARRAY ?
PUSHJ SP,DELSCN ; [E057] YES - DELETE SUB-STRINGS
MOVEI A1,@A1 ; GETSTRING ITSELF, IF STRING VARIABLE.
JUMPE A1,BLKE1 ; IF NO STRING ASSIGNED, DON'T DELETE.
PUSHJ SP,GETOWN ; NO - DELETE ITEM
JRST BLKE1
BLKE2: PUSH SP,A1 ; PUT BACK LAST BLOCK POINTER
HRRZM AX,LINKPC(DL) ; [E127] STORE UPDATED PC
JRST CNC.AX ; AND EXIT
SUBTTL ARRAY - ARRAY LAYOUT ROUTINE
; AN ARRAY HEADER WORD PAIR IS FORMATTED AS FOLLOWS:
; FIRST WORD: LH: TYPE OF ARRAY
; RH: POINTER TO 0TH ELEMENT OF ARRAY IF VECTOR,
; OTHERWISE 0TH ELEMENT OF PRIMARY ILIFFE VECTOR
; SECOND WORD: LH: - NUMBER OF DIMENSIONS
; RH: POINTER TO DOPE VECTOR
; THE I'TH ELEMENT OF THE J'TH LEVEL ILIFFE VECTOR (J = 1,2, ..... N-1)
; CONTAINS THE ADDRESS OF THE 0TH ELEMENT OF THE J+1'TH ILIFFE
; VECTOR (OR N'TH ROW IF J=N-1)
; THE DOPE VECTOR CONTAINS THE BOUND PAIRS
; ARRAY - NORMAL ENTRY
; OARRAY - OWN ARRAY ENTRY
; THE BOUND PAIRS ARE ON THE STACK (DOPE VECTOR)
; AND THE LINK IS IN AX
; A1 = ARRAY TYPE (T)
; A2 = ADDRESS OF FIRST HEADER WORD (A)
; A3 = - NO. OF ARRAYS (M)
; A4 = - NO. OF DIMENSIONS (N)
ARRAY: TDZA A11,A11 ; NORMAL ENTRY
OARRAY: MOVEI A11,1 ; OWN ARRAY ENTRY
MOVN A10,A3 ; SAVE NO. OF ARRAYS
HRLI A2,(A3) ; -M,A
HRLZI A3,(A4)
ASH A4,1
MOVN A13,A4 ; LENGTH OF DOPE VECTOR
HRRI A3,1(SP)
SUBI A3,(A13) ; -N,DV
JUMPN A11,ARR10 ; OWN ARRAY?
ARR1: HRLZ A1,A1 ; T,0
MOVE A4,A3 ; DOPE VECTOR (DV) POINTER
SETZB A5,A6 ; A5 = SPACE ACCUMULATOR
MOVEI A7,1 ; A6,7 = MULTIPLIER ACCUMULATOR
ARR2: MOVM A0,(A4) ; ABS(LB(I))
TLNE A0,-1 ; OK?
SYSER1 4,(AX) ; NO
MOVM A0,1(A4) ; ABS(UB(I))
TLNE A0,-1 ; OK?
SYSER1 4,(AX) ; NO
MOVE A0,1(A4)
SUB A0,(A4) ; UB(I) - LB(I)
AOJG A0,.+2 ; FORM D(I). OK?
SYSER1 3,(AX) ; NO
MOVE A6,A7
MUL A6,A0 ; ACCUMULATE PRODUCT
JUMPN A6,.+2
TLNE A7,-1
SYSER1 4,(AX) ; TOO LARGE
ADD A5,A7 ; ACCUMULATE SUM OF PRODUCTS
ADDI A4,1
AOBJN A4,ARR2 ; RETURN IF MORE SUBSCRIPTS
TLNN A1,$VAR2 ; ALLOW FOR LONG REAL, ETC.
ADD A5,A7
TLNE A5,-1 ; TOO BIG FOR PDP-10?
SYSER1 4,(AX) ; UNFORTUNATELY, YES
JRST ARR12
ARR3: ADDI A13,1
ARR4: MOVE A5,A3 ; START OF DOPE VECTOR
MOVE A4,1(A5)
SUB A4,(A5)
ADDI A4,1 ; DIMENSION OF FIRST BOUND
MOVE A7,A13
SUB A7,(A5) ; ADDRESS OF 0TH ELEMENT
HRRI A1,(A7)
ADDI A5,1 ; MOVE UP DOPE VECTOR POINTER
AOBJN A5,ARR5 ; AND JUMP UNLESS VECTOR
TLNE A1,$VAR2
JRST ARR8 ; CHECK FOR LONG REAL, ETC.
ASH A4,1 ; DOUBLE LAST SUBSCRIPT
MOVE A7,-2(A5) ; GET BACK LAST LOWER BOUND
SUB A1,A7 ; RECALCULATE ADDRESS OF 0TH ELEMENT
JRST ARR8
ARR5: MOVE A10,A13 ; NOT A VECTOR
ARR6: ADDI A10,(A4) ; NEXT ILIFFE VECTOR OR ARRAY
MOVE A6,1(A5)
SUB A6,(A5)
ADDI A6,1 ; DIMENSION OF I'TH BOUND
MOVE A7,A10
SUB A7,(A5) ; ADDRESS OF 0TH ELEMENT
ADDI A5,1 ; MOVE UP DOPE VECTOR POINTER
AOBJN A5,ARR7 ; AND JUMP UNLESS LAST SUBSCRIPT
TLNE A1,$VAR2 ; CHECK FOR LONG REAL, ETC.
JRST ARR7 ; NO
SUB A7,-2(A5) ; ALLOW FOR DOUBLING OF SUBSCRIPT
ASH A6,1
ARR7: MOVEM A7,(A13) ; FILL IN ILIFFE VECTOR ELEMENT
ADDI A7,(A6) ; ADVANCE ENTRY
ADDI A13,1 ; INCREMENT ILIFFE VECTOR
CAIE A13,(A10) ; COMPLETE?
JRST ARR7 ; NO - KEEP GOING
IMULI A4,(A6) ; NEW PRODUCT
TLNE A5,-1 ; ANY MORE DIMENSIONS?
JRST ARR6 ; YES
ARR8: ADDI A13,(A4) ; MOVE A13 OVER ARRAY
MOVEM A1,(A2)
MOVEM A3,1(A2) ; FILL IN HEADER WORDS
ADDI A2,1 ; MORE ARRAYS?
AOBJN A2,ARR4 ; YES
JUMPN A11,ARR14 ; OWN ARRAY?
ARR9: MOVE SP,%SYS13(DB) ; RESTORE STACK POINTER
ADDI SP,-1(DB)
ARR16: MOVEI A1,(SP)
SUB A1,.JBREL
HRLI SP,(A1) ; AND SET UP LEFT HALF
JUMPN A11,CNC.AX ; EXIT IF OWN ARRAY
HRRZ A1,-1(A2) ; OTHERWISE GET ADDRESS OF ARRAY
EDIT(057) ; RETURN INDIVIDUAL SPACE FOR STRING ARRAYS
MOVE A6,%SYS11(DB) ; [E057] GET TYPE OF ARRAY AGAIN
TLNN A6,$TYPE-$S ; [E057] IS IT A STRING ARRAY ?
ADD A1,[<Z 1,0>-2] ; [E057] YES - SET TYPE CODE INTO DESCRIPTOR
ARR16A: EXCH A1,(SP) ; AND ADD TO ITEM LIST ON STACK
PUSH SP,A1 ; AND MAKE NEW BLOCK POINTER
MOVE A1,SP ; MAKE NEW POINTER
SUBI A1,(DB)
MOVEM A1,BLKPTR(DL)
JRST CNC.AX ; AND EXIT
ARR10: SKIPN A4,1(A2) ; VIRGIN ARRAY?
JRST ARR1 ; YES - RETURN TO MAIN SEQUENCE
MOVE A5,A3
ARR11: MOVE A0,(A5) ; COMPARE NEW DOPE VECTOR WITH OLD
CAME A0,(A4) ; LOWER BOUNDS THE SAME?
JRST ARR1 ; NO
MOVE A0,1(A5)
CAME A0,1(A4) ; UPPER BOUNDS THE SAME?
JRST ARR1 ; NO
ADDI A5,2
ADDI A4,1
AOBJN A4,ARR11 ; MOVE TO NEXT SUBSCRIPT IF ANY
SUBI SP,(A13) ; SAME BOUNDS - LOSE NEW DOPE VECTOR
JRST ARR16 ; AND EXIT
ARR12: JUMPN A11,.+2 ; UNLESS OWN ARRAY
IMULI A5,(A10) ; ALLOW FOR THEM ALL
ADDI A5,(A13) ; ALLOW FOR DOPE VECTOR
MOVEM A5,%SYS7(DB) ; SAVE IT
MOVEM A13,%SYS10(DB) ; DOPE VECTOR LENGTH
MOVEM A1,%SYS11(DB) ; SAVE A1
TLNN A1,$OWN ; IF NOT FIXED ADDRESS
SUBI A2,(DB) ; THEN DELOCATE
MOVEM A2,%SYS12(DB) ; SAVE A2
SUBI A3,(DB)
MOVEM A3,%SYS13(DB) ; SAVE A3
ARR13: MOVE A0,%SYS7(DB) ; SPACE REQUIRED
EDIT(057); RETURN INDIVIDUAL STRING SPACE FOR STRING ARRAYS
PUSH SP,[0] ; [E057] PUT A ZERO WORD ON THE STACK
JUMPN A11,ARR13A ; [E057] NOTHING TO DO IF OWN ARRAY
MOVSI A1,$TYPE-$S ; [E057] WHAT TYPE OF ARRAY IS THIS ?
TDNE A1,%SYS11(DB) ; [E057] IS IT A STRING ARRAY ?
JRST ARR13A ; [E057] NO - CARRY ON
SETOM (SP) ; [E057] YES - SET FLAG WORD
ADDI A0,2 ; [E057] ACCOUNT FOR EXTRA WORDS NEEDED
ARR13A: PUSHJ SP,GETCLR ; [E057] TRY TO GET IT (ZEROED)
POP SP,A4 ; [E057] RESTORE TYPE-CODED WORD
JUMPE A4,ARR13D ; [E057] CARRY ON IF NOT STRING ARRAY
HLLZ A4,%SYS12(DB) ; [E057] OTHERWISE GET NUMBER OF ARRAYS
MOVEM A4,(A1) ; [E057] STORE IT IN LEFT HALF OF WORD 1
HRRZ A4,%SYS10(DB) ; [E057] GET DOPE VECTOR SIZE
ADDI A4,2(A1) ; [E057] AND GET ADDRESS OF NEXT WORD
MOVEM A4,1(A1) ; [E057] STORE THIS IN SECOND WORD
PUSH SP,A1 ; [E057] SAVE ADDRESS
MOVE A1,%SYS13(DB) ; [E057] GET DOPE VECTOR POINTER
ADDI A1,(DB) ; [E057] AND RELOCATE IT
SETZ A2, ; [E057] CLEAR TOTAL ILIFFE SIZE
MOVEI A3,1 ; [E057] AND TOTAL DATA SIZE
ARR13B: MOVN A4,(A1) ; [E057] GET LOWER BOUND
ADD A4,1(A1) ; [E057] GET DIFFERENCE
IMULI A3,1(A4) ; [E057] ACCUMULATE PRODUCT
AOBJP A1,ARR13C ; [E057] EXIT IF LAST DIMENSION
ADD A2,A3 ; [E057] OTHERWISE ACCUMULATE TOTAL
AOJA A1,ARR13B ; [E057] AND LOOP FOR NEXT DIMENSION
ARR13C: POP SP,A1 ; [E057] RESTORE DATA AREA AGAIN
HRRM A2,(A1) ; [E057] STORE ILIFFE VECTOR SIZE
MOVN A3,A3 ; [E057] GET -# OF ARRAY ELEMENTS
HRLM A3,1(A1) ; [E057] STORE THIS IN L.H. OF WORD 2
ADDI A1,2 ; [E057] AND STEP OVER THESE WORDS
ARR13D: MOVE A4,A1 ; [E057] ADDRESS OF SPACE
MOVE A3,%SYS13(DB) ; RESTORE TEMPORARY DOPE VECTOR POINTER
ADDI A3,(DB)
HRLI A4,(A3) ; BLT POINTER
HRRI A3,(A4) ; POINTER TO NEW DOPE VECTOR
MOVE A13,%SYS10(DB)
ADDI A13,-1(A4) ; END OF NEW DOPE VECTOR
BLT A4,(A13) ; COPY TEMPORARY TO NEW DOPE VECTOR
MOVE A1,%SYS11(DB) ; RESTORE A1
MOVE A2,%SYS12(DB)
TLNN A1,$OWN
ADDI A2,(DB) ; AND A2
JUMPE A11,ARR3 ; IF OWN ARRAY
PUSH SP,[0]
PUSH SP,[0]
HRROI A2,-1(SP) ; SET UP FOR NEW HEADER
JRST ARR3
ARR14: MOVE A1,%SYS12(DB) ; GET ADDRESS OF OLD HEADER
SKIPN 1(A1) ; VIRGIN ARRAY?
JRST ARR15 ; YES
MOVEI A2,-1(SP)
PUSHJ SP,CPYARR ; NO - COPY RELEVANT PARTS OF OLD ARRAY
MOVEI A11,1 ; RESET OWN FLAG
MOVE A1,%SYS12(DB)
HRRZ A1,1(A1) ; GET LOCATION OF OLD ARRAY
MOVEI A0,0
PUSHJ SP,GETOWN ; AND DELETE IT
ARR15: MOVE A2,%SYS12(DB) ; RESTORE ADDRESS OF HEADER
POP SP,1(A2)
POP SP,(A2) ; AND COPY NEW HEADER
ADDI A2,1
AOBJP A2,ARR9 ; ANY MORE ARRAYS?
MOVEM A2,%SYS12(DB) ; YES - MOVE TO NEXT HEADER
JRST ARR13 ; AND DEAL WITH THE NEXT ONE
SUBTTL STRDEC - DECLARE STRINGS
; CALL IS:
; MOVEI A1,<STRING-VARIABLE>
; JSP AX,STRDEC
STRDEC: SETZM (A1) ; MAKE IT A NULL STRING
SETZM 1(A1) ; [254] CLEAR SECOND WORD OF HEADER
CAIGE A1,(DL) ; [E004] DYNAMIC ?
JRST STRDC2 ; [E004] NO.
SUBI A1,(DB) ; [E004] YES -
TLO A1,DB ; [E004] DELOCATE.
EDIT(004); MAKE STRING DELETE AT BLOCK-EXIT WORK IF STACK IS SHIFTED.
STRDC2: TLO A1,(@) ; SET INDIRECT BIT
JRST ARR16A ; LEAVE ADDRESS ON STACK FOR BLKEND
SUBTTL CHKARR - CHECK ARRAY SUBSCRIPTS ROUTINE
; ON ENTRY, THE SUBSCRIPTS ARE ON THE STACK
; A0 = NUMBER OF SUBSCRIPTS PRESENTED
; A2 = ADDRESS OF ARRAY HEADER
; THE LINK IS IN AX
; ON EXIT, THE ARRAY ELEMENT ADDRESS IS IN A2
CHKARR: DMOVEM A3,%SYS12(DB) ; SAVE A3,A4
MOVE A1,1(A2) ; GET DOPE VECTOR POINTER
MOVE A2,(A2) ; GET ARRAY TYPE AND ADDRESS OF 0TH WORD
SUB SP,A0
MOVEI A3,(SP)
SUB A3,.JBREL ; RESTORE STACK POINTER
HRLI SP,(A3) ; TO POSITION BEFORE DUMPS
MOVEI A3,1(SP) ; POINTER TO SUBSCRIPTS
CHK1: MOVE A4,(A3) ; GET NEXT SUBSCRIPT
CAML A4,(A1) ; AND CHECK IF BETWEEN
CAMLE A4,1(A1) ; LOWER AND UPPER BOUNDS
SYSER1 6,(AX) ; NO - COMPLAIN
ADD A2,A4 ; OK - OFFSET ADDRESS BY SUBSCRIPT
ADDI A1,1 ; ADVANCE DOPE VECTOR POINTER
AOBJP A1,CHK2 ; ANY MORE ENTRIES IN DOPE VECTOR?
SOJE A0,CHK3 ; YES - ANY SUBSCRIPTS LEFT?
HRR A2,(A2) ; YES - LOAD ILIFFE VECTOR ENTRY
AOJA A3,CHK1 ; AND DEAL WITH NEXT SUBSCRIPT
CHK2: SOJN A0,CHK3 ; END OF DOPE VECTOR - ANY MORE SUBSCRIPTS?
TLNN A2,$VAR2 ; NO - TWO WORDS PER VARIABLE?
ADD A2,A4 ; YES - DOUBLE LAST SUBSCRIPT
DMOVE A3,%SYS12(DB) ; RESTORE A3,A4
JRST CNC.AX ; AND RETURN WITH ADDRESS OF ELEMENT
CHK3: SYSER1 5,(AX) ; WRONG NUMBER OF SUBSCRIPTS
SUBTTL COMPAR - COMPARE BYTE STRINGS ROUTINE
; STRING VARIABLES ARE FORMATTED AS FOLLOWS:
; FIRST WORD: BYTE-POINTER TO STRING (POSITION FIELD = OCTAL 44)
; SECOND WORD: BIT 0: WRITE PROTECT BIT (SET IN STRING CONSTANT
; HEADERS)
; BIT 1: DYNAMIC BIT (SET IN STRINGS CREATED
; IN THE HEAP)
; BIT 2: 1 = RESULT OF STRING-TYPE PROCEDURE
; BITS 3-11: SPARE
; BITS 12-35: NUMBER OF BYTES IN BYTE STRING
; ON ENTRY:
; A0,A1 CONTAIN THE VALUE OF THE FIRST STRING VARIABLE
; A2,A3 CONTAIN THE VALUE OF THE SECOND STRING VARIABLE
; THE LINK IS IN AX
; ON EXIT:
; A0 CONTAINS -1,0 OR +1 ACCORDING AS THE FIRST STRING IS LESS THAN,
; EQUAL TO OR GREATER THAN THE SECOND STRING
EDIT(102); Rewrite COMPAR to deal with trailing ASCII spaces/nulls properly
COMPAR: PUSH SP,A0 ; Save byte-pointer 1 on the stack
TLZ A1,STRBCC ; Mask out unwanted bits to get length 1
SKIPN A0 ; If this is a null string,
TDZA A1,A1 ; Ensure length is zero
SKIPN A1 ; Also, if length is zero,
SETZB A0,(SP) ; Make sure this is a null string.
PUSH SP,A1 ; Save length 1 on the stack
PUSH SP,A2 ; Save byte-pointer 2 on the stack
TLZ A3,STRBCC ; Mask out unwanted bits to get length 2
SKIPN A2 ; If this is a null string,
TDZA A3,A3 ; Ensure length is zero
SKIPN A3 ; Also, if length is zero,
SETZB A2,(SP) ; Make sure this is a null string.
PUSH SP,A3 ; Save length 2 on the stack
LDB A1,[POINT 6,A0,11] ; Get byte-size 1 into A1
LDB A3,[POINT 6,A2,11] ; Get byte-size 2 into A3
SETZ A0, ; Initialize A0 (result) to 0
CAMN A1,A3 ; Do byte sizes match ?
JRST CMPR2 ; Yes - compare word-at-a-time
CAIN A1,7 ; No. If first string is ASCII (byte size = 7)
JUMPE A3,CMPR5 ; and the second is a null string,
CAIN A3,7 ; or vice-versa, then check for string
JUMPE A1,CMPR5 ; consisting entirely of nulls or spaces.
; Byte-at-a-time compare. (Different byte sizes).
CMPR0: SETZB A1,A3 ; Initialize both values to nulls
SOSL -2(SP) ; If string 1 has not yet run out,
ILDB A1,-3(SP) ; Get next byte into A1.
SOSL 0(SP) ; Similarly, if string 2 not yet exhausted
ILDB A3,-1(SP) ; Get next byte into A3.
CAME A1,A3 ; Compare the two bytes
JRST CMPR9 ; Unequal - strings are different
SKIPG -2(SP) ; Equal. Continue if either string
SKIPLE 0(SP) ; not yet exhausted (padding with nulls)
JRST CMPR0 ; to try to find a difference
CMPR1: SUB SP,[ ; Both strings exhausted - compare equal.
XWD 4,4] ; Retard stack to original level
JRST CNC.AX ; & return
; Word-at-a-time compare. (Same byte-size, in A3).
CMPR2: JUMPE A3,CMPR1 ; If byte-size zero, both are (equal) null strings
MOVNI A2,^D36 ; Otherwise must do a real compare.
IDIVI A2,(A3) ; Get -(#bytes/word) in A2
CMPR3: SETZB A1,A3 ; Initialize both words to nulls
SKIPLE -2(SP) ; If still some of string 1 left,
MOVE A1,@-3(SP) ; get next word-full into A1
SKIPLE 0(SP) ; Similarly get next word-full of string 2
MOVE A3,@-1(SP) ; into A3 (unless none left).
CAME A1,A3 ; Are the words identical ?
JRST CMPR4 ; No.
ADDM A2,0(SP) ; Yes - decrement both byte-counts
ADDM A2,-2(SP) ; by number of bytes/word
AOS -3(SP) ; And increment both addresses to
AOS -1(SP) ; point to the next full word.
SKIPG (SP) ; If either string has some bytes left
SKIPLE -2(SP) ; then continue with the comparison.
JRST CMPR3 ; Otherwise strings are identical
JRST CMPR1 ; except for possible trailing nulls
CMPR4: MOVN A2,A2 ; Get +(bytes/word)
CAIE A2,5 ; Is this an ASCII comparison ?
JRST CMPR0 ; No - check for exact match
; Comparison of ASCII strings (trailing space = trailing null)
CMPR5: SETZB A1,A3 ; Initialize both values to nulls
SOSL -2(SP) ; If string 1 has not yet run out,
ILDB A1,-3(SP) ; Get the next byte into A1
SOSL 0(SP) ; And similarly get next byte of
ILDB A3,-1(SP) ; string 2, unless exhausted
CAMN A1,A3 ; Are the bytes identical ?
JRST CMPR7 ; Yes - try the next pair
CAIN A1," " ; Allow space from first string
JUMPE A3,CMPR6 ; to match null from second string
CAIN A3," " ; And allow null from first string
JUMPE A1,CMPR6 ; to match space from second string
JUMPN A0,CMPR1 ; Some other character. If some difference
JRST CMPR9 ; previously encountered, the string which
; had the space will be greater than the string
; which had the null. Otherwise, compare these
; (different) characters to order the strings.
CMPR6: JUMPN A0,CMPR8 ; Jump if already found a difference
SKIPE A1 ; Otherwise set A0 to reflect which string
AOJA A0,CMPR8 ; had the space, and which the null.
SOJA A0,CMPR8 ; (-1 if string 1 null, +1 if string 2)
CMPR7: JUMPE A1,CMPR8 ; Identical characters. If they are
CAIE A1," " ; both nulls or spaces, continue testing
JUMPN A0,CMPR1 ; If not, embedded spaces do not match nulls
CMPR8: SKIPG -2(SP) ; If only spaces or nulls found so far,
SKIPLE 0(SP) ; repeat while either string has characters
JRST CMPR5 ; which have not yet been examined
SETZ A0, ; Otherwise set result 'equal'
JRST CMPR1 ; and return (tidying up stack first)
CMPR9: CAML A1,A3 ; Strings differ - see which is "greater"
AOJA A0,CMPR1 ; A0:= +1;! string 1 > string 2;
SOJA A0,CMPR1 ; A0:= -1;! string 1 < string 2;
SUBTTL PRBYTE/PWBYTE - BYTE POINTER ROUTINES
; ON ENTRY:
; A1 = BYTE NUMBER
; A2 = ADDRESS OF STRING VARIABLE
; THE LINK IS IN AX
; ON EXIT, THE BYTE POINTER IS IN A2
; E.G.
;
; S.[I] := S.[J]
;
; COMPILES INTO
;
; MOVE A1,J
; MOVEI A2,S
; JSP AX,PBYTE
; LDB A13,A2 ; A13 := S.[J]
; MOVE A1,I
; MOVEI A2,S
; JSP AX,PBYTE
; DPB A13,A2 ; S.[I] := A13
PBYTE: MOVEI A2,@A2
DMOVEM A4,%SYS11(DB) ; SAVE A4,A5
SOJL A1,PBYT2 ; CHECK SENSIBLE BYTE NUMBER
EDIT(033); CHECK FOR NULL STRINGS
PBYT1: SKIPN STR1(A2) ; [E033] IS THIS A NULL STRING ?
JRST PBYT2 ; [E033] YES - TELL OFF BAD USER
MOVE A4,STR2(A2)
TLZ A4,STRBCC ; NUMBER OF BYTES IN STRING
CAMGE A1,A4 ; ENOUGH?
JRST PBYT3 ; YES
PBYT2: SYSER1 16,(AX) ; BYTE NUMBER OUT OF RANGE
PBYT3: HLL A2,STR1(A2) ; GET LEFT HALF OF FIRST STRING WORD
HLRZ A5,A2
ANDI A5,STRBS
LSH A5,-6 ; AND EXTRACT BYTE SIZE
MOVEI A3,44
IDIVI A3,(A5) ; CALCULATE NUMBER OF BYTES PER WORD
EXCH A1,A2 ; EXCHANGE BYTE NUMBER AND ADDRESS
IDIVI A2,(A3) ; CALCULATE WORD AND BYTE NUMBER
HRR A1,(A1) ; GET ADDRESS OF BYTE STRING
ADDI A2,(A1) ; AND GET ADDRESS OF WORD CONTAINING BYTE
CAMG A2,.JBREL ; GOOD ADDRESS IN LOW SEGMENT?
JRST PBYT4 ; YES
HRRZ A4,.JBHRL
CAILE A2,(A4) ; NO - GOOD ADDRESS IN HIGH SEGMENT
SYSER2 5,0 ; NO - COMPLAIN
PBYT4: DPB A5,[
POINT 6,A2,11] ; SET UP BYTE SIZE
IMULI A5,1(A3)
MOVEI A4,44
SUBI A4,(A5) ; POSITION OF LAST BIT IN BYTE
DPB A4,[
POINT 6,A2,5] ; SET IT IN BYTE POINTER
PBYT5: DMOVE A4,%SYS11(DB) ; RESTORE A4,A5
JRST CNC.AX
SUBTTL CPYSTR - COPY STRING ROUTINE
; ON ENTRY:
; A0,A1 CONTAIN THE VALUE OF THE OLD STRING VARIABLE
; A2 CONTAINS THE ADDRESS OF THE NEW STRING VARIABLE
; A4 CONTAINS THE ADDRESS OF THE NEW BYTE STRING
; A7 CONTAINS THE LOWEST BYTE NUMBER TO BE COPIED
; A10 CONTAINS THE NUMBER OF BYTES TO BE COPIED
; THE LINK IS IN AX
; A3 AND A13 ARE SACRED, AS THIS ROUTINE IS CALLED FROM PARAM
CPYSTR: TLO A1,STRDYN ; SET DYNAMIC BIT
MOVE A5,A1 ; TAKE COPY OF 2ND WORD
TLO A5,STRPRC ; MARK AS RESULT OF STRING PROC
MOVEM A5,STR2(A2) ; AND SET UP SECOND WORD OF STRING
DPB A10,[
POINT 24,STR2(A2),35] ; AND PLANT BYTE COUNT
JUMPE A10,CPYS7 ; SPECIAL TREATMENT IF NULL STRING
HLL A4,A0
MOVEM A4,STR1(A2) ; SET UP FIRST WORD OF STRING
MOVE A5,A0 ; GET POINTER TO OLD STRING
MOVE A2,A1 ; SAVE FLAGS
TLZ A1,STRBCC ; GET BYTE COUNT
JRST CPYS4
CPYS2: ILDB A6,A5
SOJG A7,CPYS2 ; IDLE UNTIL FIRST BYTE REQUIRED
IDPB A6,A4 ; YES COPY BYTE
SOJE A10,CNC.AX ; COUNT DOWN COPY
CPYS4: SOJGE A1,CPYS2 ; COUNT DOWN BYTES
HLRZ A1,A0 ; EXHAUSTED
CPYS7: SETZM STR1(A2) ; CLEAR FIRST WORD OF NULL STRING
JRST CNC.AX
SUBTTL STRASS - STRING ASSIGNMENT ROUTINE
; S:=T
; ENTERED WITH: 0(SP),-1(SP) LEFT-HAND STRING VARIABLE
; -2(SP),-3(SP) RIGHT-HAND STRING VARIABLE
; ON EXIT: A0,A1 NEW LEFT-HAND STRING VARIABLE
; STACK CLEARED.
;
STRAS0: PUSH SP,A2 ; [E045] SPECIAL ENTRY POINT FOR PARAM
JRST STRAS1 ; [E045] TO INITIALIZE A VALUE STRING
STRASS: POP SP,A1 ; GET L.H. STRING VARIABLE
POP SP,A0
STRASX: CAMN A0,-1(SP) ; [E055] IS L.H. = R.H. ? (S:=S; )
JRST STRAS2 ; YES - DON'T WASTE TIME
PUSH SP,A2 ; NO - SAVE A2
JUMPE A0,STRAS1 ; DOES L.H. STRING EXIST ?
TLNN A1,STRDYN ; YES - IS IT DYNAMIC ?
JRST STRAS1 ; NO
HRRZ A1,A0
SETZ A0,
PUSHJ SP,GETOWN ; YES - DELETE IT
STRAS1: SKIPE -2(SP) ; [E045] EXTRA CHECKS FOR NULL STRINGS
SKIPN A2,-1(SP) ; [E045] WHICH MAY HAVE ZERO BYTE SIZE
JRST STRAS3 ; [E045] QUICK EXIT FOR NULL STRINGS
TLNE A2,STRPRC ; IS R.H. THE RESULT OF A STRING PROC ?
JRST STRAS3 ; YES - DON'T COPY, JUST RETURN IT
LDB A2,[
POINT 6,-2(SP),11] ; GET BYTE-SIZE
MOVEI A1,^D36
IDIVI A1,(A2) ; GET # BYTES/WORD
MOVE A0,-1(SP) ; GET LENGTH IN BYTES
TLZ A0,STRBCC ; ISOLATE LENGTH
IDIVI A0,(A1) ; TO WORDS
SKIPE A1
ADDI A0,1 ; ROUND UP
JUMPE A0,STRAS3 ; DON'T ASK GETOWN FOR 0 WORDS
PUSH SP,A0 ; KEEP
PUSHJ SP,GETOWN ; GET SPACE
POP SP,A2
ADDI A2,-1(A1) ; FORM END-OF-BLT
HRLI A1,@-2(SP) ; MAKE A BLT POINTER
HRRM A1,-2(SP) ; SET NEW ADDRESS INTO STRING-VARIABLE
BLT A1,(A2) ; COPY
STRAS3: POP SP,A2 ; RESTORE A2
STRAS2: POP SP,A1 ; GET NEW
TLO A1,STRDYN ; (DYNAMIC)
TLZ A1,STRPRC ; (NON-PROCEDURE RESULT)
POP SP,A0 ; STRING VARIABLE
TLZ A0,77 ; ENSURE INDEX FIELD CLEAR
EDIT(045); Initialize null value strings properly
SKIPE A0 ; [E045] IF ALREADY A NULL STRING
TDNN A1,[77,777777] ; [E045] OR ONE WITH ZERO BYTES
SETZB A0,A1 ; [E045] CLEAR POINTER AND COUNT
JRST CNC.AX ; RETURN
SUBTTL CPYARR - COPY ARRAY ROUTINE
; ON ENTRY:
; A1 = ADDRESS OF SOURCE ARRAY (MAY BE DESTROYED)
; A2 = ADDRESS OF DESTINATION ARRAY
; THAT PART OF THE ARRAY(A1) WHICH IS COMMON WITH
; ARRAY(A2) IS COPIED, WITH APPROPRIATE TYPE CONVERSION
CPYARR: HRLZI AX,(AX) ; SAVE OLD LINK IN LH OF AX
MOVE A3,1(A1) ; DV POINTER FOR SOURCE ARRAY
MOVE A4,1(A2) ; DV POINTER FOR DESTINATION ARRAY
HLLZ A5,A3
HRRI A5,1(SP) ; COMMON DV POINTER
MOVE A13,SP ; SAVE SP
CPYA1: MOVE A6,(A3)
CAMGE A6,(A4)
MOVE A6,(A4) ; LC = MAX(LB(A1),LB(A2))
MOVE A7,1(A3)
CAML A7,1(A4)
MOVE A7,1(A4) ; UC = MIN(UB(A1),UB(A2))
CAMGE A7,A6 ; UC >= LC?
JRST CPYA3 ; NO - ABORT COPY
PUSH SP,A6 ; YES -
PUSH SP,A7 ; SET LC, UC IN COMMON DV
ADDI A3,2 ; MOVE ALONG DV POINTERS
ADDI A4,1
AOBJN A4,CPYA1 ; AND CONTINUE IF MORE SUBSCRIPTS
HLLZ A6,A3
HRRI A6,1(SP) ; WORKING SUBSCRIPTS VECTOR
MOVE A7,A5
CPYA2: PUSH SP,(A7) ; INITIALIZE WORKING VECTOR
ADDI A7,1
AOBJN A7,CPYA2 ; FROM COMMON DV
MOVE A3,(A1) ; GET TYPE AND IV ADDRESS OF SOURCE ARRAY
MOVE A4,(A2) ; GET TYPE AND IV ADDRESS OF DESTINATION ARRAY
HLRZ A7,A3
ANDI A7,$TYPE
LSH A7,-11
HRLZ A7,TYPTAB(A7) ; LOOK UP SOURCE ENTRY IN PARAM'S MAGIC TABLE
HLRZ A10,A4
ANDI A10,$TYPE
LSH A10,-11
AND A7,TYPTAB(A10) ; AND GATE WITH DESTINATION'S ENTRY
JFFO A7,CPYA4 ; AND SORT IT ALL OUT!!!!!!!
; (MISMATCHES FALL THROUGH HERE)
CPYA3: HLRZ AX,AX ; RESTORE OLD LINK
MOVE SP,A13 ; RESTORE STACK POINTER
POPJ SP,0 ; AND EXIT
CPYA4: ROT A10,-1 ; SHIFT AROUND ODD BIT
JUMPGE A10,.+2 ; ODD ENTRY?
SKIPA A10,CPYA8(A10) ; YES - LOAD IT
MOVS A10,CPYA8(A10) ; NO - LOAD EVEN ENTRY
CPYA5: MOVE A7,A6 ; TAKE COPY OF WORKING VECTOR ADDRESS
HRRZ A11,A3 ; GET 0TH ILIFFE VECTOR ENTRY FOR SOURCE
HRRZ A12,A4 ; AND FOR DESTINATION
CPYA6: ADD A11,(A7) ; ADVANCE BY NEXT SUBSCRIPT
ADD A12,(A7)
AOBJP A7,(A10) ; ANY MORE SUBSCRIPTS?
MOVE A11,(A11) ; YES - MOVE THROUGH ILIFFE VECTOR ENTRY
MOVE A12,(A12)
JRST CPYA6
CPYA8: XWD CPYA9,CPYA11 ; I -> I, I -> R
XWD CPYA12,CPYA13 ; I -> LR, R -> I
XWD CPYA9,CPYA14 ; R -> R, R -> LR
XWD CPYA15,CPYA16 ; LR -> I, LR -> R
XWD CPYA17,CPYA3 ; LR -> LR, C -> C
XWD CPYA3,CPYA3 ; C -> LC, LC -> C
XWD CPYA3,CPYA9 ; LC -> LC, B -> B
XWD CPYA17,CPYA3 ; S -> S, L -> L
XWD CPYA3,0 ; N -> N
CPYA9: MOVE A0,(A11) ; I -> I, R -> R, B -> B
CPYA10: MOVEM A0,(A12) ; GENERAL SINGLE WORD STORE
JRST CPYA19
CPYA11: FLTR A0,(A11) ; I -> R
JRST CPYA10
CPYA12: MOVE A0,(A11) ; I -> LR
JSP AX,ILR
JRST CPYA18
CPYA13: FIXR A0,(A11) ; R -> I
JRST CPYA10
CPYA14: MOVE A0,(A11) ; R -> LR
MOVEI A1,0
JRST CPYA18
CPYA15: ADD A11,-1(A7) ; DOUBLE LAST SUBSCRIPT OF SOURCE
DMOVE A0,(A11) ; LR -> I
JSP AX,LRI
JRST CPYA10
CPYA16: ADD A11,-1(A7) ; DOUBLE LAST SUBSCRIPT OF SOURCE
; LR -> R
DMOVE A0,(A11)
JSP AX,LRR
JRST CPYA10
CPYA17: ADD A11,-1(A7) ; DOUBLE LAST SUBSCRIPT OF SOURCE
DMOVE A0,(A11) ; LR -> LR, S -> S
CPYA18: ADD A12,-1(A7) ; DOUBLE LAST SUBSCRIPT OF DESTINATION
DMOVEM A0,(A12) ; GENERAL DOUBLE WORD STORE
CPYA19: MOVEI A11,(A6) ; REVERSE POINTER TO COMMON DV
CPYA20: AOS A12,-1(A7) ; GET AND INCREMENT LAST SUBSCRIPT
CAMG A12,-1(A11) ; GONE TOO HIGH?
JRST CPYA5 ; NO - GO BACK FOR NEXT ELEMENT
MOVE A12,-2(A11) ; YES - REPLACE
MOVEM A12,-1(A7) ; BY MINIMUM VALUE
SUBI A11,2 ; MOVE DOWN COMMON DV
CAIG A11,2(A13) ; DOWN TO FIRST SUBSCRIPT?
JRST CPYA3 ; YES
SOJA A7,CPYA20 ; NO - KEEP GOING
SUBTTL GETOWN - GET HEAP SPACE ROUTINE
; ON ENTRY,
; If A0 < 0, the space returned is immediately below the stack base,
; so as to be capable of extension
; If A0 = 0, A1 is the address of a space to be returned to the heap
; If A0 > 0, A0 is the number of words of heap space required.
; Where space is acquired, A1 contains the address of the first useful word
; Free heap space is referenced by a table addressed by %SYS2,
; the entries being formatted as follows:-
; 0 = null entry
; length,,pointer = free area in Heap
; The last word in a piece of table is either 0 or an AOBJN pointer
; to another piece of table (the pieces of table are themselves in
; the Heap).
; each heap area is preceeded by a 'chain word', formatted as follows:-
; LH = length of this area, including chain word
; RH = 0 area in use
; = non-zero, pointer to area's entry in heap table
GETKNL: ; KERNEL OF GETOWN - A2 = TABLE POINTER (-LENGTH,,ADDR)
Edit(062); Use current top of heap if possible
PUSH SP,A2 ; [E062] SAVE TABLE POINTER
PUSH SP,A3 ; ALL ENTRIES REQUIRE TO SAVE A3
JUMPL A0,GET3 ; FLEX ENTRY
JUMPE A0,GET2 ; RETURN SPACE
GET1: ; ORDINARY GET-N-WORDS ENTRY
ADDI A0,1 ; ALLOW FOR LINK-WORD
HRROI A3,-1 ; INITIALIZE A3 AS FLAG/COMPARE WORD
GET13: HLRZ A1,(A2) ; GET SIZE OF NEXT SLOT
SUB A1,A0 ;
JUMPL A1,GET15 ; DIFFERENCE
JUMPN A1,GET14 ; SPOT ON
EXCH A1,(A2) ; CLEAR HEAP TABLE ENTRY, LOAD POINTER
HLLZS (A1) ; CLEAR RHS OF CHAIN WORD
JRST GET97
GET14: CAIL A1,(A3) ; LARGE ENUF - CF WITH PREV
JRST GET15 ; NO BETTER
EDIT (246) ; [246] FIX HEAP ALLOCATION
PUSH SP,A5 ; [246] SAVE THIS AC BEFORE USING IT
HRRZ A5,(A2) ; [246] LOAD THIS ENTRY'S POINTER
CAIN A5,0 ; [246] IS THIS HEAP ENTRY ALREADY IN USE?
JRST [ ; [246]
POP SP,A5 ; [246] YES, IT'S NO GOOD - RESTORE A5
JRST GET15 ; [246] KEEP SCANNING HEAP TABLE
] ; [246]
POP SP,A5 ; [246] NO, RESTORE A5
MOVEI A3,(A1) ; [246] THIS ENTRY IS GOOD - REMEMBER IT
HRLI A3,(A2)
GET15: AOBJN A2,GET13 ; KEEP TRYING
SKIPE A2,(A2) ; MORE TABLE ?
JRST GET13 ; YES - USE IT
JUMPGE A3,GET17
MOVE A2,-1(SP) ; [E062] GET TABLE AGAIN
PUSH SP,A0 ; [E062] SAVE A0 (DESIRED SIZE)
SETO A0, ; [E062] FLAG NOTHING FOUND
PUSHJ SP,GETTOP ; [E062] GET TOPMOST CHUNK
TDZA A1,A1 ; [E062] NOT FOUND - LENGTH = 0
HLRZ A1,(A1) ; [E062] FOUND - GET LENGTH
MOVN A1,A1 ; [E062] A1 = -(LENGTH OF CHUNK)
ADD A1,(SP) ; [E062] A1 = LENGTH TO EXTEND BY
CCORE1 (A1) ; [E062] SHIFT THE STACK
POP SP,A0 ; [E062] GET DESIRED LENGTH AGAIN
MOVN A1,A0 ; [E062] GET WHERE IT WILL START
ADDI A1,(DB) ; [E062] BY COUNTING DOWN FROM DB
HRLZM A0,(A1) ; SET CHAIN-WORD
JRST GET97
GET17: MOVS A2,A3 ; A2 IS LENGTH,,TABLE POINTER
HRRZ A1,(A2) ; BASE ADDR OF PIECE TO GIVE AWAY
HRLZM A0,(A1) ; SET ITS LINK WORD
ADDB A0,(A2) ; INCR POINTER IN TABLE
HLLM A2,(A2) ; SET LENGTH OF FREE PIECE
HRRZ A3,A0
MOVEM A2,(A3) ; SET ITS LINK WORD
JRST GET97 ; WHICH ADDS 1 TO A1 & RETURNS
GET2: ; A0 = 0 - RETURN SPACE ADDRESSED BY A1
TLZ DB,TMPFL1!TMPFL2; CLEAR TEMPORARY FLAG BITS
HLRZ A0,-1(A1) ; A0 IS LENGTH OF RETURNED PIECE
ADDI A0,-1(A1) ; NOW TOP ADDRESS + 1
MOVEI A1,-1(A1) ; GET ADDRESS OF BOTTOM OF PIECE
GET21: SKIPN A3,(A2) ; GET TABLE ENTRY - FREE ?
JRST GET24 ; YES
CAIE A0,(A3) ; NO - PIECE IMMEDIATELY ABOVE RETURNED PIECE ?
JRST GET22 ; NO
HLLZ A3,A3 ; YES - MERGE. CLEAR RHS
HRRM A1,(A2) ; SET TABLE WORD TO POINT TO MERGED PIECES
PUSH SP,(A1) ; SAVE OLD BACK-POINTER
HRRM A2,(A1) ; AND SET BACK-POINTER TO THIS TABLE-ENTRY ADDR
JRST GET23
GET22: HLRZ A3,(A2) ; LENGTH OF TABLE'S PIECE
ADD A3,(A2) ; + ITS ADDR GIVES ITS TOP ADDR
CAIE A1,(A3) ; IMMEDIATELY BELOW RETURNED PIECE ?
JRST GET25 ; NO
PUSH SP,(A1) ; SAVE OLD UPEPER TABLE POINTER
HLLZ A3,(A1) ; YES - MERGE. GET EXTRA LENGTH
HRRZ A1,(A2) ; GET LOWER ADDRESS
EDIT(227) ; DO MEMORY MANAGEMENT MATH IN RIGHTHALF TO
; PREVENT OVERFLOWS
GET23: MOVSS (A1) ; [227] SWAP TO PREPARE FOR RIGHTHALF MATH
MOVSS A3 ; [227] SWAP A3 FOR RIGHTHALF MATH
ADDB A3,(A1) ; [227] PUT NEW LENGTH INTO LINK WORD
MOVSS (A1) ; [227] SWAP ANSWER BACK TO HOW IT SHOULD BE
HRLM A3,(A2) ; [227] PUT NEW LENGTH VALUE INTO TABLE
POP SP,A3 ; GET OLD BACK-POINTER
TRNE A3,-1 ; WAS IT FREE ?
SETZM (A3) ; YES, RELEASE ITS TABLE ENTRY
TLO DB,TMPFL1 ; NO, REMEMBER WE WON'T NEED A TABLE SLOT
JRST GET25
GET24: ; WE'VE FOUND A FREE TABLE SLOT
TLON DB,TMPFL2 ; IF WE HAVEN' FOUND ONE BEFORE,
PUSH SP,A2 ; SAVE ITS ADDRESS
GET25: AOBJN A2,GET21 ; GET NEXT TABLE ENTRY.
SKIPN (A2) ; ANY MORE BITS OF TABLE ?
JRST GET25A ; NO.
MOVE A2,(A2)
JRST GET21 ; YES - GO USE IT
GET25A: TLNE DB,TMPFL2 ; NEED TO DECREMENT STACK ?
POP SP,A3 ; YES
TLNE DB,TMPFL1 ; STILL GOT TO PLANT TABLE ENTRY ?
JRST GET99 ; NO - ALL OVER
TLNE DB,TMPFL2 ; WAS THERE A FREE SLOT ?
JRST GET26 ; YES - GO USE IT
PUSH SP,A0 ; NO FREE SPACE IN TABLE: MUST GET ANOTHER PIECE
PUSH SP,A1 ; & CHAIN IT ON
PUSH SP,A2 ; (RECURSIVE, SO SAVE EVERYTHING)
MOVEI A0,HPCHN
PUSHJ SP,GETCLR ; GET IT, ZEROED (NOTE: NO WAY WILL THIS
; NEED ANOTHER TABLE SLOT !!)
POP SP,A2 ; ADDRESS OF LAST WORD OF OLD PIECE
MOVEI A0,1-HPCHN ; LENGTH (LESS LINK-WORD) OF NEW PIECE
HRL A1,A0 ; FORM LINK-WORD
MOVEM A1,(A2) ; AND STORE IT AT END OF OLD PIECE
MOVEI A3,(A1) ; ADDR OF 1ST WORD OF NEW PIECE
POP SP,A1
POP SP,A0
GET26: HLL A1,(A1) ; LENGTH OF SPACE
MOVEM A1,(A3) ; MAKE TABLE ENTRY
HLL A3,A1 ; AND BACK-POINTER
MOVEM A3,(A1)
JRST GET97
GET3: PUSHJ SP,GETTOP ; [E062] GET TOPMOST CHUNK
JRST GET33 ; [E062] NOT AVAILABLE
HLLZS (A1) ; CLEAR CHAIN WORD
JRST GET97
GET33: PUSH SP,DB ; SAVE CURRENT STACK BASE
CCORE1 ^D128 ; SHIFT STACK 128 WORDS
POP SP,A1 ; NOW OLD STACK BASE
HRLZI A2,^D128 ; LOAD COUNT
MOVEM A2,0(A1) ; SET CHAIN WORD
GET97: MOVEI A1,1(A1) ; FIRST USEFUL WORD
GET99:
IFN FTGETCHK,< ;[251] CHECK HEAP TABLE CONSISTENCY
;[251] SCAN THE HEAP, INSURING THAT NO ENTRY OVERLAPS ANY OTHER. A2 POINTS
;[251] TO THE REFERENCE ENTRY BEING CHECKED, AND A3 SCANS THROUGH THE TABLE.
;[251] FIRST, THE UPPER ADDRESS LIMIT OF THE ENTRY POINTED TO BY A3 IS CHECKED
;[251] TO SEE IF IT IS LESS THAN OR EQUAL TO THE LOWER ADDRESS LIMIT OF THE
;[251] REFERENCE ENTRY. IF IT IS NOT, THEN ANOTHER CHECK IS MADE TO SEE
;[251] IF THE LOW ADDRESS LIMIT IS GREATER THAN OR EQUAL TO THE UPPER ADDRESS
;[251] LIMIT OF THE REFERENCE ENTRY. IF IT IS, THEN THE ENTRY IS OK. IF IT
;[251] IS NOT, THEN SOME PARTS OF EACH TABLE ENTRY OVERLAP AND THE TABLE IS BAD.
;[251] THE ENTIRE TABLE IS SCANNED AND EACH ENTRY COMPARED TO EVERY OTHER
;[251] ONE. THIS ADDS CONSIDERABLE OVERHEAD AND SHOULD NOT NORMALLY BE USED.
PUSH SP,A4 ;[251] SAVE A4 FOR HEAP ANALYSIS
PUSH SP,A5 ;[251] AND A5
MOVE A2,%SYS2(DB) ;[251] GET HEAP TABLE PTR.
GET000: MOVE A3,A2 ;[251] COPY AOBJN PTR. TO TABLE
AOBJP A3,GET002 ;[251] START SCANNING AT NEXT ENTRY UNLESS DONE
GET001: SKIPN A4,(A2) ;[251] GET REFERENCE ENTRY'S LOW ADDRESS LIMIT
JRST GET003 ;[251] NULL ENTRY, SKIP IT
TLZ A4,-1 ;[251] CLEAR LENGTH OUT OF LEFT HALF
SKIPN A5,(A3) ;[251] GET NEXT HEAP COMPARISON ENTRY
JRST GETNXT ;[251] NULL, SKIP IT
SUBI A4,(A5) ;[251] NON-NULL, CHECK IT
HLRZS A5 ;[251] MAKE 0,,LENGTH OUT OF HEAP ENTRY
SUB A4,A5 ;[251] IS AREA'S TOP ADDR. ABOVE BOTTOM ADDR.?
JUMPGE A4,GETNXT ;[251] NO, ENTIRE SPACE IS BELOW, WE'RE SAFE
HRRZ A5,(A3) ;[251] YES, CHECK OVERLAP ON OTHER SIDE TOO
MOVE A4,(A2) ;[251] GET CURRENT TABLE ENTRY
SUBI A5,(A4) ;[251] GET DIFFERENCE
HLRZS A4 ;[251] MAKE 0,,LENGTH OF CURRENT ENTRY
SUB A5,A4 ;[251] DO AREAS OVERLAP AT ALL?
JUMPL A5,GETERR ;[251] YES HEAP TABLE IS BAD
GETNXT: AOBJN A3,GET001 ;[251] NO, STEP TO NEXT ENTRY IN HEAP TABLE
GET002: SKIPE A3,(A3) ;[251] UNLESS DONE WITH THIS PART OF TABLE
JRST GET001 ;[251] MORE TABLE, GO USE IT
GET003: AOBJN A2,GET000 ;[251] STEP TO NEXT REFERENCE TABLE ENTRY
SKIPE A2,(A2) ;[251] UNLESS DONE WITH THIS PART OF TABLE
JRST GET000 ;[251] CONTINUE IF MORE TABLE EXISTS
POP SP,A5 ;[251] RESTORE AC'S
POP SP,A4 ;[251]
> ;[251] END IFN FTGETCHK
POP SP,A3
POP SP,A2 ; [E062] RESTORE A2
POPJ SP,
GETTOP: HRRZ A1,(A2) ; GET POINTER
CAIGE A0,(A1) ;
MOVEI A0,(A1) ; THIS ENTRY IS HIGHER
AOBJN A2,GETTOP
SKIPE A2,(A2) ; MORE TABLE ?
JRST GETTOP ; YES - USE IT
JUMPL A0,CPOPJ ; NONE FREE
HRRZ A1,A0 ; HIGHEST ENTRY (ADDR OF SPACE)
HLRZ A0,(A1) ; LENGTH
ADDI A0,(A1) ; PLUS ADDR
CAIE A0,(DB) ; IS IT THE TOP ?
POPJ SP, ; [E062] NO - JUST RETURN
AOS (SP) ; [E062] YES - SKIP RETURN
HRRZ A2,(A1) ; O.K.-GIVE IT AWAY
SETZM (A2) ; CLEAR TABLE ENTRY
CPOPJ: POPJ SP, ; [E062] RETURN
GETOWN: MOVE A2,%SYS2(DB) ; GET POINTER TO PUBLIC HEAP-TABLE
PUSHJ SP,GETKNL ; DO THE JOB
IFN FTGETCHK,<
; ***** OPTIONAL HEAP INTEGRITY CHECKER *****
SKIPE %SYSOV(DB) ; FUNCT PRIVATE HEAP CHANGES
JRST GETX9 ; FORMAT OF OUR HEAP, SO WE CAN'T CHECK IT
PUSH SP,A3
PUSH SP,A1
SETZ A1,
HRRZ A2,%SYS2(DB)
HLRE A3,%SYS2(DB) ; - (LENGTH OF LIST -1)
SUBI A2,-1(A3)
TLZ A2,-1 ; CLEAR LEFT HALF
GETX2: MOVE A3,(A2)
TRNE A3,-1 ; ANY RIGHT HALF ?
AOJA A1,GETX1 ; YES - UNNUSED - CHECK TABLE CONSISTENT
GETX3: HLRZ A0,A3 ; GET SIZE
JUMPE A0,GETERR ; [263] ERROR IF ENTRY IS ZERO
ADD A2,A0 ; MOVE TO NEXT CHUNK
CAIGE A2,(DB) ; END ?
JRST GETX2 ; NO - CHECK NEXT CHUNK
CAIE A2,(DB) ; EXACTLY THERE ?
JRST GETERR ; NO
CAML A1,%SYS24(DB) ; KEEP TRACK OF
MOVEM A1,%SYS24(DB) ; MAX # OF USED ENTRIES
GETX4: POP SP,A1 ; IN HEAP TABLE
POP SP,A3
JRST GETX9 ; YES - IT'S ALL OK !!!
GETX1: HRRZ A0,A3 ; [263] GET ADDRESS OF ENTRY
CAIL A0,(DB) ; [263] LEGITIMATE?
JRST GETERR ; [263] NO, ERROR
HLL A0,A3 ; SIZE FROM LINK-WORD
HRR A0,A2 ; ADDRESS OF CHUNK
CAMN A0,(A3) ; = TABLE-ENTRY ?
TLNN A0,-1 ; AND NON-ZERO SIZE ?
JRST GETERR ; NOPE
JRST GETX3 ; YES - OK
GETX9: > ; END OF FTGETCHK
SETZ A0, ; THE OUTSIDE WORLD EXPECTS A0 = 0 (FOR DELETE)
POPJ SP,
IFN FTGETCHK,<
GETERR: OUTSTR [ASCIZ/
?ALGCEH CONSISTENCY ERROR IN HEAP HANDLER/] ;[251]
EXIT> ;[251]
SUBTTL GETCLR - GET ZERO-FILLED OWN SPACE
GETCLR: PUSHJ SP,GETOWN ; GET THE SPACE
SETZM (A1)
HLRZ A2,-1(A1) ; GET LENGTH OF SPACE
SUBI A2,2
JUMPE A2,GETCL2 ; ONLY 1 WORD - DONE
MOVEI A5,1(A1) ; MAKE A
HRL A5,A1 ; BLT POINTER
ADDI A2,(A1)
BLT A5,(A2) ; ZEROES
GETCL2: POPJ SP,
SUBTTL RDOCT/PROCT - READ OCTAL WORD/PRINT OCTAL HALFWORD ROUTINES
; AN OCTAL WORD IS READ AND RETURNED IN A0
RDOCT: SETZB A0,A1 ; CLEAR ACCUMULATOR AND DIGIT FLAG
PUSHJ SP,IGNICH ; IGNORE INVISIBLE CHARACTERS
CAIN A13,"%" ; OCTAL MARKER?
JRST RDOCT1 ; YES - OK
RDOCT4: HLRZ A1,%CHAN(DB) ; GET CHANNEL #
IOERR 10,(A1) ; GO TO ERROR
RDOCT1: JSP AX,INCHR0 ; [E145] GET NEXT CHARACTER
CAIL A13,"0"
CAIL A13,"8" ; IN RANGE 0 - 7?
JRST RDOCT3 ; NO
TLNE A0,700000 ; YES - TOP OIT SET?
RDOCT2: SYSER2 3,0 ; YES - COMPLAIN ABOUT OVERFLOW
LSH A0,3 ; NO - SHIFT UP
ADDI A0,-"0"(A13) ; AND ADD IN OIT
JOV RDOCT2 ; AND CHECK FOR OVERFLOW
AOJA A1,RDOCT1 ; COUNT DIGITS AND CONTINUE
RDOCT3: JUMPE A1,RDOCT4 ; TERMINATOR - DIGIT SEEN?
POPJ SP,0 ; YES - EXIT
; ON ENTRY, THE HALFWORD IS IN A1
SPROCT: MOVNI A0,1 ; SPECIAL ENTRY FOR CHANNEL -1
EXCH A0,%CHAN(DB)
PUSHJ SP,PROCT
MOVEM A0,%CHAN(DB) ; RESTORE CHANNEL NUMBERS
POPJ SP,0
PROCT: MOVE A2,[
POINT 3,A1,17] ; SET UP BYTE POINTER
MOVEI A3,6 ; AND BYTE COUNT
PROCT1: ILDB A13,A2 ; GET NEXT OIT
ADDI A13,"0" ; ADD ASCII OFFSET
JSP AX,OUCHAR ; AND PRINT IT
SOJN A3,PROCT1 ; ANY MORE OITS?
POPJ SP,0 ; NO - EXIT
SUBTTL IO CONTROL BITS
; INBYTE FLAG BITS (LH OF CHANNEL NUMBER)
BYTLA=400000 ; LOOK AHEAD REQUIRED (MUST BE BIT 0)
; OUBYTE FLAG BITS (LH OF CHANNEL NUMBER)
OPTR=400000 ; BREAK OUTPUT
; CHANNEL BITS (RH OF CHANNEL NUMBER)
LOGCHN=000020 ; LOGICAL CHANNEL
; CONTROL AREA OFFSETS
STRPTR=0 ; STRING POINTER
BYTPTR=1 ; BYTE POINTER
BYTCNT=2 ; BYTE COUNT
BDDOFF=3 ; BIDIRECTIONAL DEVICE OUTPUT AREA OFFSET
DEVNAM=3 ; DEVICE NAME
FILNAM=4 ; FILE NAME
FILEXT=5 ; FILE EXTENSION
FILPRT=6 ; FILE PROTECTION
FILPP=7 ; FILE PROJECT-PROGRAMMER NUMBER
DEVCAL=4 ; DEVICE CONTROL AREA LENGTH
FILCAL=4 ; FILE CONTROL AREA LENGTH
SUBTTL INBYTE - BYTE INPUT ROUTINE
; INBYTE - NORMAL ENTRY
; NXTBYT - LOOK AHEAD ENTRY
; NON-SKIP EXIT FOR END-OF-FILE
; OK SKIP EXIT WITH BYTE IN A13
; USES A10,A11,A12,A13
; READ BLOCK FROM PHYSICAL DEVICE ROUTINE
INBLK: SUBI A10,(DB) ; DE-RELOCATE CHANNEL NUMBER
HRLZI A12,<IN>B53
DPB A10,[POINT 4,A12,12] ; CONSTRUCT IN UUO
XCT A12 ; AND READ BLOCK
JRST INBLK1 ; OK
MOVE A12,[STATZ 740000]
DPB A10,[POINT 4,A12,12] ; CONSTRUCT STATZ UUO
XCT A12 ; AND GET STATUS
INBLK2: IOERR 7,(A10) ; ERROR - REPORT IT
AOS (SP) ; EOF - SET UP SKIP RETURN
JRST INBLK3
INBLK1: SKIPN BYTCNT(A11) ; CHECK BYTE COUNT (TTY CROCK!)
JRST INBLK2 ; NO BYTES
;
; Edit(1010) Ignore nulls at start of buffer.
;
TLNN A11,ABMODE ; [E1010] ASCII MODE ?
JRST INBLK3 ; [E1010] NO - CONTINUE
INBLK4: MOVE A12,BYTPTR(A11) ; [E1010] YES - GET BYTE POINTER
ILDB A12,A12 ; [E1010] GET FIRST BYTE OF BUFFER
JUMPN A12,INBLK3 ; [E1010] NULL?
IBP BYTPTR(A11) ; [E1010] YES - SKIP IT
SOSN BYTCNT(A11) ; [E1010] BUFFER EMPTY ?
JRST INBLK+1 ; [216][E1010] YES - GET ANOTHER
JRST INBLK4 ; [E1010] NO -TRY NEXT BYTE
INBLK3: ADDI A10,(DB) ; RELOCATE CHANNEL NUMBER
POPJ SP,0
INBYTE: TDZA A10,A10 ; NORMAL ENTRY
NXTBYT: HRLZI A10,BYTLA ; LOOK-AHEAD ENTRY
HLR A10,%CHAN(DB) ; GET CHANNEL NUMBER
MOVEI A13,(A10) ; SAVE FOR ERROR-MESSAGES
ADDI A10,(DB) ; AND RELOCATE IN DATA BASE
SKIPN A11,%IODR(A10) ; CHANNEL DEFINED?
IOERR 2,(A13) ; NO - COMPLAIN
TLNE A11,INEOF ; END-OF-FILE?
POPJ SP,0 ; YES - TAKE ERROR RETURN
TLNE A11,TTYDEV ; TTY DEVICE?
JRST INBT6 ; YES
JUMPG A11,INBT14 ; LOGICAL DEVICE?
TLNE A11,INOK ; NO - OK TO READ?
JRST INBT1 ; YES
TLNN A11,ININT ; INITED FOR INPUT?
IOERR 2,(A13) ; NO - FORBID INPUT
TLNN A11,DIRDEV ; DIRECTORY DEVICE?
JRST .+3 ; NO
TLNN A11,INFIL ; YES - FILE OPEN
IOERR 3,(A13) ; NO
PUSHJ SP,INBLK ; READ FIRST BLOCK
JRST INBT16 ; NOT EOF
TLO A11,INEOF
MOVEM A11,%IODR(A10) ; EOF - SET FLAG
POPJ SP,0 ; AND TAKE ERROR RETURN - A13 = CHAN #
INBT16: TLO A11,INOK ; SET INOK FLAG
MOVEM A11,%IODR(A10)
INBT1: JUMPG A10,INBT4 ; LOOK AHEAD?
INBT2: MOVE A13,BYTPTR(A11) ; YES - GET BYTE POINTER
ILDB A13,A13 ; AND GET NEXT BYTE
INBT3: AOS (SP) ; OK SKIP RETURN
POPJ SP,0
INBT4: ILDB A13,BYTPTR(A11) ; NO - GET NEXT BYTE
SOSN BYTCNT(A11) ; ANY BYTES LEFT IN BUFFER
JRST INBT5 ; NO
TLNN A11,ABMODE ; YES - ASCII MODE?
JRST INBT3 ; NO - EXIT
INBT17: MOVE A12,BYTPTR(A11)
ILDB A12,A12 ; YES - LOOK AT NEXT BYTE
JUMPN A12,INBT3 ; EXIT UNLESS NULL
IBP BYTPTR(A11) ; IF SO
SOSE BYTCNT(A11) ; SEARCH FOR NON-NULL
JRST INBT17
INBT5: PUSHJ SP,INBLK ; READ NEXT BLOCK
JRST INBT3 ; OK
INBT15: TLO A11,INEOF ; END-OF-FILE
MOVEM A11,%IODR(A10)
JRST INBT3 ; SET EOF FLAG BUT EXIT OK
INBT6: TLNE A11,INOK ; TTY - OK TO READ?
JRST INBT12 ; YES
TLNE A11,TTYTTC ; NO - ON TTCALL?
JRST INBT7 ; YES
PUSHJ SP,INBLK ; NO - READ NEXT BLOCK
JRST INBT11 ; OK
MOVEI A13,CONZ ; EOF - GIVE THE USER A CONTROL-Z
JRST INBT15
INBT7: MOVE A12,[POINT 7,%IBUFF(DB)]; SET UP TTCALL BYTE POINTER
MOVEM A12,%TTY+BYTPTR(DB)
MOVEI A11,1 ; INITIALIZE BYTE COUNT
INCHWL A13 ; [255] GET FIRST CHARACTER
INBT8: IDPB A13,A12 ; [255] STORE BYTE IN BUFFER
CAIGE A11,^D80 ; [255] BUFFER FULL?
INCHSL A13 ; [255] NO, GET NEXT CHR. IF ANY
JRST INBT10 ; [255] YES, OR END-OF-LINE
AOJA A11,INBT8 ; [255] AND LOOP
INBT10: HRRI A10,-1(DB) ; POINT A10 TO CHANNEL -1
MOVEM A11,%TTY+BYTCNT(DB)
; STORE BYTE COUNT
MOVE A11,%IODR(A10) ; RESTORE CHANNEL FLAGS
INBT11: TLO A11,INOK ; SET OK TO READ
MOVEM A11,%IODR(A10)
INBT12: JUMPL A10,INBT2 ; LOOK AHEAD?
ILDB A13,BYTPTR(A11) ; NO - GET BYTE
SOSN BYTCNT(A11) ; AND DECREMENT BYTE COUNT
JRST INBT13 ; END OF BUFFER
MOVE A12,BYTPTR(A11)
ILDB A12,A12 ; LOOK AT NEXT BYTE
JUMPN A12,INBT3 ; AND EXIT UNLESS NULL
INBT13: TLZ A11,INOK
MOVEM A11,%IODR(A10) ; CLEAR INOK FLAG
JRST INBT3 ; BUT EXIT OK
INBT14: JUMPL A10,INBT2 ; LOGICAL DEVICE - LOOK AHEAD?
ILDB A13,BYTPTR(A11) ; NO - GET BYTE
SOSE BYTCNT(A11) ; ANY MORE?
JRST INBT3 ; YES
JRST INBT15 ; NO
SUBTTL OUBYTE - BYTE OUTPUT ROUTINE
; ENTRY WITH BYTE IN A13
; NON-SKIP EXIT FOR END-OF-FILE
; OK SKIP EXIT
; USES A10,A11,A12,A13
; WRITE BLOCK TO PHYSICAL DEVICE ROUTINE
OUTBLK: SUBI A10,(DB) ; DE-RELOCATE CHANNEL NUMBER
HRLZI A12,<OUT>B53
DPB A10,[
POINT 4,A12,12] ; CONSTRUCT OUT UUO
XCT A12 ; AND WRITE BLOCK
JRST OUBLK1 ; OK
MOVE A12,[
STATZ 0,700000]
DPB A10,[
POINT 4,A12,12] ; CONSTRUCT STATZ UUO
XCT A12 ; AND GET STATUS
OUBLK2: IOERR 7,(A10) ; ERROR - REPORT IT
AOS (SP) ; EOF ETC. - SET UP SKIP RETURN
JRST OUBLK3
OUBLK1: SKIPN BYTCNT(A11) ; CHECK BYTE COUNT (TTY CROCK!)
JRST OUBLK2
OUBLK3: ADDI A10,(DB) ; RELOCATE IO CHANNEL NUMBER
POPJ SP,0
OUBYTE: TDZA A10,A10 ; NORMAL ENTRY
BRKBYT: HRLZI A10,OPTR ; BREAK OUTPUT ENTRY
HRR A10,%CHAN(DB) ; GET CHANNEL NUMBER
MOVEI A12,(A10) ; SAVEE FOR ERROR MESSAGES
ADDI A10,(DB) ; AND RELOCATE IN DATA BASE
SKIPN A11,%IODR(A10) ; CHANNEL DEFINED?
IOERR 2,(A12) ; NO - COMPLAIN
TLNE A11,OUTEOF ; LOGICAL EOF?
POPJ SP,0 ; YES - TAKE ERROR RETURN
JUMPG A11,OUBT6 ; LOGICAL DEVICE?
TLNE A11,TTYDEV ; NO - TTY DEVICE?
ADDI A11,BDDOFF ; YES - OUTPUT OFFSET
TLNE A11,OUTOK ; OK TO WRITE?
JRST OUBT2 ; YES
TLNN A11,OUTINT ; INITED FOR OUTPUT?
IOERR 2,(A12) ; NO - FORBID OUTPUT
TLNN A11,DIRDEV ; DIRECTORY DEVICE?
JRST .+3 ; NO
TLNN A11,OUTFIL ; YES - FILE OPEN?
IOERR 3,(A12) ; NO
TLNE A11,TTYTTC ; TTY ON TTCALL?
PUSHJ SP,OUBT10 ; YES - INITIALIZE (SKIP RETURN)
PUSHJ SP,OUTBLK ; DO FIRST OUT
JRST OUBT1 ; OK
TLO A11,OUTEOF ; EOF
MOVEM A11,%IODR(A10) ; SET OUTEOF FLAG
HRRZ A13,%CHAN(DB) ; GET CHANNEL NUMBER
POPJ SP,0 ; AND GIVE ERROR RETURN - A13 = CHAN #
OUBT1: TLO A11,OUTOK ; SET OK TO WRITE
HLLM A11,%IODR(A10)
EDIT(112); Don't make REDIRECTed files unnecessarily large
OUBT2: TLNE DB,INDDT ; [E112] If called from ALGDDT, and
TLNE A11,TTYDEV!TTYTTC;[E112] not going to terminal, ignore.
EDIT(174); do not duplicate last byte is redirected dump mode
JRST OUBT11 ;[174] NOT ALGDDT CASE (USE EXISTING CODE)
JUMPL A10,OUBT3 ;[174] ALGDDT CASE AND BREAK OUTPUT (IGNORE)
JRST OUBT12 ;[174] ALGDDT CASE AND OUTBYTE
OUBT11: JUMPL A10,OUBT4 ;[174] BREAK OUTPUT?
OUBT12: TLNE A11,TTYTTC ; [255] NO, IF TTY DON'T SEND NULL BYTES
JUMPE A13,OUBT3 ; [255] JUMP IF NULL
IDPB A13,BYTPTR(A11) ;[174] NO - PLANT BYTE
SOSN BYTCNT(A11) ; DECREMENT BYTE COUNT
JRST OUBT4 ; EXPIRED
OUBT3: AOS (SP) ; OK - SKIP RETURN
POPJ SP,0
OUBT4: TLNE A11,TTYTTC ; TTY ON TTCALL?
JRST OUBT5 ; YES
PUSHJ SP,OUTBLK ; NO - WRITE BLOCK
JRST OUBT3 ; OK
TLO A11,OUTEOF
HLLM A11,%IODR(A10) ; SET OUTEOF FLAG
JRST OUBT3
OUBT5: MOVEI A13,0
IDPB A13,%TTY+BDDOFF+BYTPTR(DB)
; PLANT NULL TERMINATING BYTE
TTCALL 3,%OBUFF(DB) ; AND OUTPUT BUFFER
OUBT10: HRLZI A12,440700
HRRI A12,%OBUFF(DB) ; SET UP INITIAL BYTE POINTER
MOVEM A12,%TTY+BDDOFF+BYTPTR(DB)
MOVEI A12,122 ; AND INITIAL BYTE COUNT
MOVEM A12,%TTY+BDDOFF+BYTCNT(DB)
JRST OUBT3
OUBT6: JUMPL A10,OUBT7 ; BREAK OUTPUT?
IDPB A13,BYTPTR(A11) ; NO - PLANT BYTE
SOSE BYTCNT(A11) ; DECREMENT BYTE COUNT
JRST OUBT3 ; STILL OK
OUBT9: TLO A11,OUTEOF
MOVEM A11,%IODR(A10) ; SET EOF FLAG
JRST OUBT3
OUBT7: MOVEI A13,0 ; BREAK OUTPUT
OUBT8: SOSGE BYTCNT(A11)
JRST OUBT9
IDPB A13,BYTPTR(A11) ; FILL UP WITH NULL BYTES
JRST OUBT8
SUBTTL READ - READ NUMBER ROUTINE
; ON ENTRY A2 = MODE REQUIRED:
; 0 INTEGER
; 1 REAL
; 2 LONG REAL
; 4 ANY (AS IT COMES)
; ON EXIT THE NUMBER IS IN
; A0 INTEGER OR REAL
; A0,A1 LONG REAL
; AND IF THE ENTRY WAS 'ANY', THE TYPE IS IN A2
; FLAGS (LH OF A2):
DECPNT=400000 ; DECIMAL POINT SEEN (MUST BE BIT 0)
IGNDIG=200000 ; IGNORE DIGITS
MANDIG=100000 ; DIGIT SEEN IN MANTISSA
EXPDIG=040000 ; DIGIT SEEN IN EXPONENT
MANSGN=020000 ; MANTISSA SIGN
EXPSGN=010000 ; EXPONENT SIGN
EXPOVL=004000 ; EXPONENT OVERFLOW
; TYPES (LH AND RH OF A2):
SREAL=1 ; REAL
LREAL=2 ; LONG REAL
ANY=4 ; ANY
; SERVICE ROUTINES FOR READ
; SUPPLIES ASCII BYTE IN A13
; LINK IS IN AX
INCHAR:
TLNE DB,INDDT ; IF DDT
JRST DDTIN% ; LET HIM DO IT.
PUSHJ SP,INBYTE ; GET NEXT BYTE
IOERR 6,(A13) ; END OF FILE - A13 = CHAN #
JRST CNC.AX
;
EDIT(145) ; Make EOF a terminator.
;
INCHR0: TLNE DB,INDDT ; [E145] If in DDT
JRST DDTIN% ; [E145] ..then let him do it.
PUSHJ SP,INBYTE ; [E145] Get next byte.
EDIT (206); IF TRAPPING FOR EOF, USE TRAP
SKIPA ;[206] EOF, CHECK TO SEE IF WE ARE TRAPPING IT
JRST CNC.AX ; [E145]
PUSH SP,A13 ;[206] SAVE THE CHANNEL NUMBER
MOVEI A13,^D38 ;[206] CHECK TO SEE IF WE ARE TRAPPING EOF
ADDI A13,(DB) ;[206] RELOCATE THE TRAP NUMBER IN THE D.B.
HRRZ A13,%TRAPS(A13) ;[206] GET ADDRESS OF TRAP BLOCK, OR ZERO
SKIPN A13 ;[206] SKIP IF A TRAP IS SET HERE
JRST INCHR1 ;[206] NONE SET, GIVE A LF
POP SP,A13 ;[206] TRAP SET, RESTORE CHANNEL NUMBER
IOERR 6,(A13) ;[206] AND GIVE THE ERROR
JRST CNC.AX ;[206] AND RETURN
INCHR1: POP SP,A13 ;[206] NO TRAP SET, RETURN LF LIKE EDIT 145
MOVEI A13,LF ;[206] AFTER POPPING THE STACK
JRST CNC.AX ;[206] RETURN WITH FREE LF
; IGNORE INVISIBLE CHARACTERS
IGNICH: JSP AX,INCHAR ; GET CHARACTER
IGN0: JUMPE A13,IGNICH ; IGNORE NULLS
CAIE A13," "
CAIN A13," "
JRST IGNICH ; IGNORE SPACES AND TABS
CAIL A13,LF
CAILE A13,CR
POPJ SP,0
JRST IGNICH ; IGNORE CR, LF, VT AND FF
READ.: HLRZ A1,%CHAN(DB) ; GET CURRENT INPUT CHANNEL NUMBER
ADDI A1,(DB)
MOVE A1,%IODR(A1) ; GET CHANNEL ENTRY
TLNN A1,ABMODE ; ASCII OR BINARY?
JRST READ37 ; BINARY
SETZB A0,A1 ; CLEAR ACCUMULATORS
SETZB A3,A4 ; CLEAR DECIMAL PLACE COUNT
; AND BINARY EXPONENT CORRECTION
HRL A2,A2 ; COPY FLAGS TO LH OF A2
ANDCMI A2,ANY ; AND CLEAR ANY FLAG IN RH
PUSHJ SP,IGNICH ; IGNORE INVISIBLE CHARACTERS
CAIN A13,"+" ; LEADING "+"?
JRST READ1 ; YES
CAIE A13,"-" ; LEADING "-"?
JRST READ2 ; NO
TLO A2,MANSGN ; YES - FLAG MANTISSA NEGATIVE
READ1: JSP AX,INCHR0 ; [E145] GET NEXT CHARACTER
READ2: CAIL A13,"0"
CAIL A13,"0"+^D10 ; IN RANGE 0 - 9?
JRST READ10 ; NO
TLNE A2,IGNDIG ; YES - IGNORE DIGIT?
JRST READ8 ; YES
TLO A2,MANDIG ; NO - FLAG DIGIT SEEN
HLRZ AX,READ13(A2)
JRST CNC.AX ; USE APPROPRIATE SEQUENCE
; INTEGER NUMBER SEQUENCE
READ3: MOVE A0,A1
IMULI A1,^D10 ; MULTIPLY BY TEN
JOV READ4 ; OVERFLOW?
ADDI A1,-"0"(A13) ; NO - ADD IN DIGIT
JOV READ4 ; OVERFLOW NOW?
JRST READ1 ; NO - OK
READ4: IORI A2,LREAL ; CONVERT TO LONG REAL
MOVE A1,A0 ; RESTORING OLD MANTISSA
MOVEI A0,0 ; IN LONG FORM
; LONG REAL NUMBER SEQUENCE
READ5: MOVE A7,A0
MOVE A5,A1
MULI A5,^D10 ; MULTIPLY LOW ORDER WORD BY TEN
IMULI A0,^D10 ; MULTIPLY HIGH ORDER WORD BY TEN
EXCH A6,A1 ; REPLACE OLD LOW ORDER WORD BY NEW ONE,
; AND SAVE OLD ONE
ADD A0,A5 ; ADD CARRY INTO HIGH ORDER WORD
TLO A1,400000 ; FLAG LOW ORDER WORD
ADDI A1,-"0"(A13) ; AND ADD IN DIGIT
TLZN A1,400000 ; AND IF CARRY OCCURED
ADDI A0,1 ; INCREMENT HIGH ORDER WORD
TLNE A0,777000 ; NUMBER TOO LARGE?
JRST READ7 ; YES
READ6: JUMPGE A2,READ1 ; NO - DECIMAL POINT SEEN?
SOJA A3,READ1 ; YES - INCREMENT DECIMAL PLACE COUNT
READ7: TLO A2,IGNDIG ; SET IGNORE DIGIT FLAG
MOVE A0,A7
MOVE A1,A6 ; AND RESTORE OLD MANTISSA
CAIGE A13,"5" ; DIGIT >= 5?
JRST READ8 ; NO
TLO A1,400000 ; YES - FLAG LOW ORDER WORD
ADDI A1,1 ; AND INCREMENT IT
TLZN A1,400000 ; AND IF CARRY OCCURED
ADDI A0,1 ; INCREMENT HIGH ORDER WORD
TLNN A0,777000 ; TOO BIG NOW?
JRST READ8 ; NO
ASHC A0,-1 ; YES - SHIFT IT DOWN
ADDI A4,1 ; AND INCREMENT BINARY EXPONENT CORRECTION
READ8: JUMPL A2,READ1 ; DECIMAL POINT SEEN?
AOJA A3,READ1 ; NO - DECREMENT DECIMAL PLACE COUNT
; REAL NUMBER SEQUENCE
READ9: MOVE A0,A1
IMULI A1,^D10 ; MULTIPLY BY TEN
ADDI A1,-"0"(A13) ; AND ADD IN DIGIT
TLNN A1,777000 ; TOO LARGE?
JRST READ6 ; NO
TLO A2,IGNDIG ; YES - SET IGNORE DIGIT FLAG
MOVE A1,A0 ; AND RESTORE OLD MANTISSA
CAIGE A13,"5" ; DIGIT >= 5?
JRST READ8 ; NO
ADDI A1,1 ; YES - INCREMENT MANTISSA
TLNN A1,777000 ; TOO BIG NOW?
JRST READ8 ; NO
ASH A1,-1 ; YES - SHIFT IT DOWN
AOJA A4,READ8 ; AND INCREMENT BINARY EXPONENT CORRECTION
READ10: CAIE A13,"." ; DECIMAL POINT?
JRST READ12 ; NO
TLOE A2,DECPNT ; ALREADY FOUND?
JRST READ21 ; YES - GO AND COMPLAIN
MOVEI AX,READ1 ; SET RETURN LINK
; SMALL SUBROUTINE FOR CONVERTING INTEGER TO REAL OR LONG REAL
READ11: TRNE A2,SREAL!LREAL ; INTEGER TYPE?
JRST CNC.AX ; NO - RETURN
TLNN A1,777000 ; LONG MANTISSA?
TROA A2,SREAL ; NO - SET REAL TYPE
IORI A2,LREAL ; YES - SET LONG REAL TYPE
MOVEI A0,0 ; CLEAR HIGH ORDER WORD
JRST CNC.AX ; AND EXIT
; END OF MANTISSA SEQUENCE
READ12: CAIE A13,"&" ; IS IT "&"
CAIN A13,"@" ; OR "@"?
JRST READ15 ; YES
CAIE A13,"E" ; IS IT "E" (FOR FORTRAN'S SAKE)
CAIN A13,"D" ; OR "D"?
JRST READ16 ; YES
CAIE A13,"+" ; CHECK FOR
CAIN A13,"-" ; ILLEGAL TERMINATORS
JRST READ21 ; AND COMPLAIN IF FOUND
TLNN A2,MANDIG ; WAS THERE A MANTISSA?
JRST READ21 ; NO - COMPLAIN
MOVE A5,A0
MOVE A6,A1 ; TAKE COPY OF MANTISSA
HRRZ AX,READ13(A2)
JRST CNC.AX ; AND USE APPROPRIATE SEQUENCE
READ13: XWD READ3,READ14 ; SEQUENCE DISPATCH TABLE
XWD READ9,READ23
XWD READ5,READ27
; INTEGER TERMINAL SEQUENCE
READ14: MOVE A0,A1
TLNE A2,MANSGN ; SHOULD IT BE NEGATIVE?
MOVN A0,A0 ; YES - NEGATE
JRST READ35 ; PROCEDE TO EXIT SEQUENCE
; EXPONENT SEQUENCE
READ15: JSP AX,INCHR0 ; [E145] "&" OR "@" FOUND
CAIE A13,"&"
CAIN A13,"@" ; ANOTHER ONE?
JRST READ16 ; YES
PUSHJ SP,IGN0 ; IGNORE ANY INVISIBLES
JRST .+2
READ16: PUSHJ SP,IGNICH ; IGNORE INVISIBLES
JSP AX,READ11 ; FIX MANTISSA UP
TLNN A2,MANDIG ; DOES MANTISSA HAVE DIGITS?
MOVEI A1,1 ; NO - FORCE A ONE
DMOVE A5,A0 ; SAVE MANTISSA
SETZB A0,A1 ; CLEAR ACCUMULATORS
CAIN A13,"+" ; "+"?
JRST READ18 ; YES
CAIE A13,"-" ; "-"?
JRST READ19 ; NO
TLOA A2,EXPSGN ; YES - FLAG EXPONENT NEGATIVE (AND SKIP!)
READ17: TLO A2,EXPOVL ; FLAG EXPONENT OVERFLOW
READ18: JSP AX,INCHR0 ; [E145] GET NEXT CHARACTER
READ19: CAIL A13,"0"
CAIL A13,"0"+^D10 ; IN RANGE 0 - 9?
JRST READ20 ; NO
TLNE A2,EXPOVL ; YES - EXPONENT OVERFLOW SET?
JRST INCHR0 ; [E145] YES - IGNORE DIGIT
TLO A2,EXPDIG ; FLAG DIGIT SEEN
MULI A0,^D10 ; MULTIPLY BY TEN
JUMPN A0,READ17 ; OVERFLOWED?
EXCH A0,A1 ; NO
TLO A0,400000 ; FLAG EXPONENT
ADDI A0,-"0"(A13) ; AND ADD IN DIGIT
TLZN A0,400000 ; DID IT OVERFLOW?
JRST READ17 ; YES
JRST READ18 ; NO - CARRY ON
READ20: CAIE A13,"+" ; END OF EXPONENT
CAIN A13,"-" ; TEST FOR ILLEGAL TERMINATORS
JRST READ21
CAIE A13,"&"
CAIN A13,"@"
JRST READ21
CAIE A13,"D"
CAIN A13,"E"
JRST READ21
CAIE A13,"."
TLNN A2,EXPDIG ; AND CHECK DIGITS SEEN
JRST READ21 ; COMPLAIN - BAD CHARS
TLNE A2,EXPOVL ; EXPONENT OVERFLOW?
JRST READ22 ; YES - COMPLAIN
TLNN A2,EXPSGN ; SHOULD EXPONENT BE NEGATIVE?
MOVN A0,A0 ; NO - FORM NEGATIVE EXPONENT
SUB A3,A0 ; TRUE NEGATIVE EXPONENT
CAILE A3,^D38 ; TOO LARGE?
JRST READ22 ; YES - GIVE OVERFLOW
TRNN A2,LREAL ; LONG REAL TYPE
READ23: TLNE A2,LREAL ; OR LONG REAL RESULT REQUIRED?
JRST READ27 ; YES
; REAL TERMINAL SEQUENCE
MOVE A0,A6 ; NO - ONLY REAL
JUMPE A0,READ35 ; ESCAPE FOR ZERO MANTISSA
TLO A0,233000
FADRI A0,000000 ; STANDARDIZE MANTISSA
FSC A0,(A4) ; AND ALLOW FOR BINARY EXPONENT CORRECTION
TLNE A2,MANSGN ; SHOULD MANTISSA BE NEGATIVE?
MOVN A0,A0 ; YES - NEGATE IT
JUMPE A3,READ35 ; ANY EXPONENT?
MOVM A4,A3 ; EXPONENT MAGNITUDE
READ24: CAIG A4,^D38 ; EXPONENT VERY SMALL OR LARGE?
JRST READ25 ; NO
JUMPGE A3,READ22 ; IF LARGE - YOU LOSE!
FDVR A0,STEN38 ; YES - DIVIDE BY 1.0&38
JUMPE A0,READ35 ; AND EXIT IF UNDERFLOWED
SUBI A4,^D38 ; OTHERWISE CUT DOWN EXPONENT
JRST READ24 ; AND TRY AGAIN
READ25: JUMPL A3,READ26 ; POSITIVE EXPONENT?
FMPR A0,STEN(A4) ; YES - MULTIPLY
JFOV READ22 ; OVERFLOWED?
JRST READ35 ; NO - EXIT
READ26: FDVR A0,STEN(A4) ; DIVIDE
JRST READ35 ; AND EXIT
READ21: HLRZ A10,%CHAN(DB)
IOERR 10,(A10)
READ22: HLRZ A10,%CHAN(DB)
IOERR 11,(A10)
; LONG REAL TERMINAL SEQUENCE
READ27: JUMPN A5,READ28
; HIGH ORDER WORD = 0?
JUMPE A6,READ34 ; YES - LOW ORDER WORD = 0
READ28: TLNE A5,000400 ; NO - BIT 9 SET?
JRST READ29 ; YES - OK
ASHC A5,1 ; NO - SHIFT UP
SOJA A4,READ28 ; AND INCREMENT BINARY EXPONENT CORRECTION
READ29: ADDI A4,276 ; CALCULATE CORRECT EXPONENT
DPB A4,[
POINT 9,A5,8] ; AND FORM HIGH WORD
TLNE A2,MANSGN ; SHOULD IT BE NEGATIVE?
DMOVN A5,A5 ; YES - NEGATE IT
JUMPE A3,READ34 ; ANY EXPONENT?
MOVM A4,A3 ; EXPONENT MAGNITUDE
READ31: CAIG A4,^D38 ; EXPONENT VERY SMALL OR LARGE
JRST READ32 ; NO
JUMPGE A3,READ22 ; IF LARGE - YOU LOSE!
MOVEI A10,^D38
JSP AX,DFDVR ; YES - DIVIDE BY 1.0&&38
JUMPE A5,READ34 ; EXIT IF UNDERFLOWED
SUBI A4,^D38 ; OTHERWISE CUT DOWN EXPONENT
JRST READ31 ; AND TRY AGAIN
READ32: MOVE A10,A4
JUMPL A3,READ33 ; POSITIVE EXPONENT?
JSP AX,DFMPR ; YES - MULTIPLY
JRST READ22 ; OVERFLOW?
JRST READ34 ; NO - EXIT
READ33: JSP AX,DFDVR ; DIVIDE
JRST READ34
READ34: DMOVE A0,A5
; EXIT SEQUENCE
READ35: LDB A3,[
POINT 3,A2,17]
ANDI A2,-1 ; DATA TYPE
POP SP,AX ; MOVE LINK TO AX
XCT READ36(A2)
READ36: JRST CNC.AX ; INTEGER NUMBER
JUMPE A3,RI ; REAL NUMBER
JUMPE A3,LRI ; LONG REAL NUMBER
; BINARY READ
READ37: PUSHJ SP,INBYTE ; READ NEXT WORD
IOERR 6,(A13) ; EOF - CHANNEL # IN A13
MOVE A0,A13
CAIE A2,2 ; LONG REAL?
POPJ SP,0 ; NO
PUSHJ SP,INBYTE ; YES - READ SECOND WORD
IOERR 6,(A13) ; EOF - CHANNEL # IN A13
MOVE A1,A13
POPJ SP,0
SUBTTL PRINT - PRINT NUMBER ROUTINE
; ON ENTRY THE NUMBER IS IN
; A0 INTEGER, REAL
; A0,A1 LONG REAL
; A2 = TYPE OF VARIABLE:
; 0 INTEGER
; 1 REAL
; 2 LONG REAL
; A3,A4 = MODE OF PRINTING REQUIRED:
; A3 NUMBER OF DIGITS BEFORE POINT (M)
; A4 NUMBER OF DIGITS AFTER POINT (N)
; (M,0) INTEGER MODE
; (M,N) FIXED POINT MODE
; (0,N) FLOATING POINT MODE
; (0,0) 'STANDARD' MODE
; SERVICE ROUTINES FOR PRINT
; PRINTS ASCII BYTE IN A13
; LINK IS IN AX
PRIN1: SKIPA A13,["."] ; SPECIAL ENTRY FOR DECIMAL POINT
SPACE%: MOVEI A13," " ; SPECIAL ENTRY FOR SPACE
OUCHAR: PUSHJ SP,OUBYTE ; OUTPUT BYTE
EDIT(126); Channel # in A12 not A13.
IOERR 6,(A12) ; [E126] END OF FILE - CHAN # IN A12
JRST CNC.AX
BRKCHR: PUSHJ SP,BRKBYT ; BREAKOUTPUT
IOERR 6,(A12) ; [E126] END OF FILE
JRST CNC.AX
; PRINT SIGN ROUTINE
; PRINTS SPACE OR "-" ACCORDING AS NUMSGN IN A2 IS UNSET OR SET
; LINK IS IN AX
PRIN3: MOVEI A13," "
TLNE A2,NUMSGN ;
MOVEI A13,"-" ; SELECT SIGN
TLZN A2,NUMSGN ; IF NEGATIVE
TLZN A2,NOSIGN ; OR NOT NOSIGN
AOJA A3,OUCHAR ; THEN PRINT IT
JRST CNC.AX ; ELSE RETURN.
; OUTPUT DIGIT ROUTINE
; GETS DIGIT FROM DIGIT STACK AND PRINTS IT
; LINK IS IN AX
PRIN4: MOVEI A13,"0"
TLNE A2,DIGEXH ; DIGITS EXHAUSTED?
JRST OUCHAR ; YES
ADD A13,(A7) ; GET NEXT DIGIT
SOJN A6,.+2 ; TOTAL COUNT EXPIRED?
TLO A2,DIGEXH ; YES - FLAG DIGITS EXHAUSTED
AOJA A7,OUCHAR ; MOVE POINTER AND PRINT DIGIT
PRINT.: HRRZ A5,%CHAN(DB) ; GET OUTPUT CHANNEL NUMBER
ADDI A5,(DB)
MOVE A5,%IODR(A5) ; AND GET CHANNEL ENTRY
TLNN A5,ABMODE ; ASCII OR BINARY?
JRST PRIN54 ; BINARY
JUMPN A3,PRIN13 ; ANY DIGITS BEFORE POINT?
JUMPN A4,PRIN13 ; OR AFTER IT?
XCT PRIN5(A2) ; NO - 'STANDARD' MODE
JRST PRIN13
PRIN5: MOVEI A3,INTDIG ; STANDARD INTEGER FORMAT
MOVEI A4,SRDIG-2 ; STANDARD REAL FORMAT
MOVEI A4,^D15 ; STANDARD LONG REAL FORMAT - LESS 2 FOR BOTH
; INTEGER PRINT ROUTINE
DPRNT%: PUSH SP,A13 ; SAVE DEBUGGER'S FLAG REGISTER.
HRLZI A2,NOSIGN ; INTEGER SPECIAL PRINT FOR DEBUGGER.
MOVEI A4,0
MOVEI A3,1
PUSHJ SP,PRIN6
POP SP,A13 ; RESTORE DEBUGGER'S FLAGS.
POPJ SP,
IPRNT%:
IPRINT: MOVEI A3,1 ; SPECIAL INTEGER PRINT
SETZB A2,A4
PRIN6: JUMPGE A0,PRIN7 ; NEGATIVE?
TLO A2,NUMSGN ; YES - SET SIGN FLAG
MOVN A0,A0 ; AND NEGATE
JOV [TLO A2,INTOVL ; OVERFLOWED - SET FLAG
MOVE A0,[^D24359738368] ; AND LOAD 2^35 - 10^10
JRST PRIN7]
PRIN7: MOVEI A5,1 ; SET UP DIGIT COUNT
PRIN8: IDIVI A0,^D10 ; AND GENERATE DIGITS IN REVERSE
PUSH SP,A1 ; AND SAVE THEM ON THE STACK
JUMPE A0,PRIN9 ; ANY LEFT?
AOJA A5,PRIN8 ; YES - COUNT AND CARRY ON
PRIN9: TLNE A2,INTOVL ; DID OVERFLOW OCCUR?
AOS (SP) ; YES - PRODUCE 2^35!!!
PRIN10: CAML A5,A3 ; ANY LEADING SPACES?
JRST PRIN11 ; NO
JSP AX,SPACE% ; YES - PRINT ONE
SOJA A3,PRIN10 ; AND DECREASE M UNTIL FINISHED
PRIN11: MOVEI A3,(A5) ; TELL WORLD (DEBUGGER) HOW MUCH WE PRINTED.
JSP AX,PRIN3 ; PRINT SIGN
PRIN12: POP SP,A13 ; POP UP DIGIT
ADDI A13,"0" ; ADD ASCII OFFSET
JSP AX,OUCHAR ; AND PRINT IT
SOJN A5,PRIN12 ; REPEAT UNTIL FINISHED
POPJ SP,0 ; EXIT FROM ROUTINE
PRIN13: MOVEI A13,0 ; CLEAR EXPONENT
JUMPG A2,PRIN17 ; JUMP UNLESS INTEGER NUMBER
JUMPE A4,PRIN6 ; USE PRIN6 IF INTEGER MODE
JUMPE A3,PRIN14 ; JUMP IF FLOATING POINT MODE
PUSHJ SP,PRIN6 ; FIXED POINT MODE - USE PRIN6
JSP AX,PRIN1 ; PRINT DECIMAL POINT
MOVEI A13,"0"
SOJGE A4,OUCHAR ; AND N ZEROS
POPJ SP,0
PRIN14: JUMPGE A0,PRIN15 ; FLOATING POINT MODE - NEGATIVE?
TLO A2,NUMSGN ; YES - SET SIGN FLAG
MOVN A0,A0 ; AND NEGATE
JOV [
MOVSI A0,244400 ; OVERFLOW - FORM 2.0^35
JRST PRIN18]
PRIN15: CAML A0,[^D100000000] ; 9 OR MORE DIGITS?
JRST PRIN16 ; YES
FLTR A0,A0 ; NO - CONVERT TO REAL
JRST PRIN18
PRIN16: JSP AX,ILR ; CONVERT TO LONG REAL
TLO A2,LNGMAN ; AND FLAG LONG MANTISSA
JRST PRIN28
PRIN17: SOJG A2,PRIN26 ; JUMP IF LONG REAL NUMBER
; REAL STANDARDIZATION SEQUENCE
FADRI A0,000000 ; ENSURE STANDARDIZED
JFOV [
MOVEI A0,0 ; BAD NUMBER - ZERO IT
JRST PRIN22]
JUMPGE A0,PRIN18 ; NUMBER NEGATIVE?
TLO A2,NUMSGN ; YES - SET SIGN FLAG
MOVN A0,A0 ; AND NEGATE IT
PRIN18: JUMPE A0,PRIN22 ; ESCAPE IF ZERO
MOVE A5,A0
CAML A0,STEN ; NUMBER < 1.0?
JRST PRIN19 ; NO
TLO A2,NUMRNG ; YES - SET RANGE FLAG
CAML A0,STENM1 ; NUMBER < 0.1?
JRST PRIN25 ; NO - IN RANGE
CAMGE A0,[
XWD 002663,437347] ; VERY SMALL NUMBER?
JRST PRIN23 ; YES - SAVE OVERFLOWS!
MOVSI A5,(1.0)
FDVR A5,A0 ; TAKE RECIPROCAL
PRIN19: HRLZI A13,-^D38 ; LOAD COUNTER
PRIN20: CAML A5,STEN1(A13) ; COMPARE WITH TABLE
AOBJN A13,PRIN20 ; UNTIL LARGER ENTRY FOUND
JUMPL A13,PRIN21 ; ENTRY FOUND?
JUMPL A2,PRIN24 ; NO - LOW RANGE?
FDVR A0,STEN38 ; NO
FDVR A0,STEN1 ; - DIVIDE BY 1.0&39
AOJA A13,PRIN25
PRIN21: ANDI A13,-1 ; ENTRY FOUND - CLEAR OUT COUNT
JUMPL A2,PRIN24 ; LOW RANGE?
FDVR A0,STEN1(A13) ; NO - DIVIDE TO BRING INTO RANGE
PRIN22: AOJA A13,PRIN25 ; AND CORRECT EXPONENT
PRIN23: MOVEI A13,^D38 ; DEAL WITH OVERFLOW IN RECIPROCAL
PRIN24: FMPR A0,STEN(A13) ; LOW RANGE - MULTIPLY TO BRING INTO RANGE
MOVN A13,A13 ; NEGATIVE EXPONENT
PRIN25: MOVEI A5,SRDIG ; SET MAXIMUM SINGLE PRECISION LENGTH
JUMPE A0,PRIN36 ; SAVE TIME FOR ZERO
LDB A7,[
POINT 9,A0,8] ; EXTRACT EXPONENT
TLZ A0,377000 ; AND CLEAR IT OUT
ASH A0,-170(A7) ; AND CONVERT TO FRACTIONAL FORM
JOV [
MOVE A0,[
XWD 031463,146315]
AOJA A13,PRIN36] ; CORRECT IF OVERFLOWED
JRST PRIN36
; LONG REAL STANDARDIZATION SEQUENCE
PRIN26: DFAD A0,LTEN ; LTEN IS DOUBLE ZERO
JUMPGE A0,PRIN27
TLO A2,NUMSGN
DMOVN A0,A0
PRIN27: TLO A2,LNGEXP ; FLAG LONG EXPONENT
;
Edit(164); Never force single precision for KI10.
;
; [E164] Delete three lines.
;
PRIN28: TLO A2,LNGMAN ; FLAG LONG MANTISSA
DMOVE A5,A0
CAMN A0,HTEN
CAMGE A1,LTEN ; SAME IN BOTH CASES
CAML A0,HTEN ; NUMBER < 1.0?
JRST PRIN30 ; NO
TLO A2,NUMRNG ; YES - SET RANGE FLAG
MOVE A10,LTEN-1
CAMN A0,HTENM1
CAMGE A1,A10
CAML A0,HTENM1 ; NUMBER < 0.1?
JRST PRIN35 ; NO - IN RANGE
JUMPE A5,PRINGD ; [260] PRINT ZERO AS 0, NOT 0&&-39
CAMGE A5,[2663,,437347]; [260] VERY SMALL NUMBER?
JRST PRIN33 ; YES - SAVE OVERFLOWS!
MOVSI A0,(1.0)
FDVR A0,A5 ; TAKE SINGLE PRECISION RECIPROCAL
PRIN30: HRLZI A13,-^D38 ; LOAD COUNTER
PRIN31: CAML A0,HTEN1(A13) ; COMPARE WITH TABLE
AOBJN A13,PRIN31 ; UNTIL LARGER ENTRY FOUND
EDIT(231) ; FIX "PRINT" PROCEDURE FOR VALUES LESS THAN 1
; WITH MANTISSAS NEAR 1
DMOVEM A0,A01TMP(DB) ; [231] SAVE A0, A1 IN CASE OF ERROR LATER
DMOVEM A5,A56TMP(DB) ; [231] SAVE A5, A6 IN CASE OF ERROR TOO
MOVEM A13,A13TMP(DB) ; [231] SAVE A13 IN CASE OF ERROR
JBS231: JUMPL A13,PRIN32 ; NO, THEN WAS A TABLE ENTRY FOUND?
JUMPL A2,PRIN34 ; NO - LOW RANGE?
MOVEI A10,^D38 ; NO
JSP AX,DFDVR
MOVEI A10,^D1
JSP AX,DFDVR ; DIVIDE BY 1.0&&39
AOJA A13,PRIN35
PRIN32: ANDI A13,-1 ; ENTRY FOUND - CLEAR OUT COUNT
JUMPL A2,PRIN34 ; LOW RANGE?
MOVEI A10,1(A13)
JSP AX,DFDVR ; NO - DIVIDE TO BRING INTO RANGE
AOJA A13,PRIN35 ; AND CORRECT EXPONENT
PRINGD: SKIPA A13,[-1] ; [260] EXPONENT IS ZERO, COMPENSATE
PRIN33: MOVEI A13,^D38 ; DEAL WITH OVERFLOW IN RECIPROCAL
PRIN34: MOVE A10,A13 ; LOW RANGE
JSP AX,DFMPR ; MULTIPLY TO BRING INTO RANGE
HALT . ; OVERFLOW CANNOT OCCUR!
MOVN A13,A13 ; NEGATIVE EXPONENT
PRIN35: DMOVE A0,A5 ; RESTORE RESULT TO A0,A1
MOVEI A5,^D19 ; SET MAXIMUM DOUBLE PRECISION LENGTH
LDB A7,[
POINT 9,A0,8] ; EXTRACT EXPONENT
TLZ A0,377000 ; AND CLEAR IT OUT
ASHC A0,-170(A7) ; AND CONVERT TO FRACTIONAL FORM
JOV [DMOVE A0,A01TMP(DB) ; [231] RESTORE A0, A1 AFTER OVERFLOW
DMOVE A5,A56TMP(DB) ; [231] RESTORE A5, A6
MOVE A13,A13TMP(DB) ; [231] RESTORE A13
SUB A13,[1,,1] ; [231] MODIFY SO IT'LL WORK THIS TIME
JRST JBS231] ; [231] TRY AGAIN
; ROUNDING AND DIGIT GENERATION SEQUENCE
PRIN36: MOVEI A6,1(A4) ; NUMBER OF DIGITS TO BE PRINTED
JUMPE A3,PRIN37 ; = N+1 IF FLOATING POINT FORMAT,
ADD A6,A13
SOJGE A6,PRIN37
MOVEI A6,0 ; MAX (N+E, 0) IF FIXED POINT FORMAT
PRIN37: CAILE A6,(A5) ; BUT NEVER MORE THAN
MOVEI A6,(A5) ; MAXIMUM PERMITTED
MOVE A5,SP ; MARK BOTTOM OF DIGIT STACK
PUSH SP,LTEN ; AND ALLOW FOR POSSIBLE OVERFLOW
MOVEI A7,1(A6) ; NUMBER OF DIGITS TO BE PRODUCED
TLNE A2,LNGMAN ; LONG MANTISSA?
JRST PRIN39 ; YES
PRIN38: MULI A0,^D10 ; MULTIPLY BY 10
PUSH SP,A0 ; STORE DIGIT ON DIGIT STACK
MOVE A0,A1 ; AND SET UP NEW FRACTION
SOJN A7,PRIN38
JRST PRIN40
PRIN39: MOVE A10,A1
MULI A10,^D10 ; MULTIPLY LOW ORDER WORD BY 10
MOVE A1,A11 ; AND RESET LOW ORDER FRACTION
MOVE A11,A0
MULI A11,^D10 ; MULTIPLY HIGH ORDER WORD BY 10
TLO A12,400000 ; FLAG LOW ORDER SIGN BIT OF RESULT
ADD A12,A10 ; AND ADD CARRY FROM LOW ORDER MULTIPLY
TLZN A12,400000 ; AND IF IT OVERFLOWS
ADDI A11,1 ; INCREMENT HIGH ORDER CARRY
MOVE A0,A12 ; RESET HIGH ORDER FRACTION
PUSH SP,A11 ; STORE DIGIT ON DIGIT STACK
SOJN A7,PRIN39
PRIN40: MOVEI A10,-1(SP) ; ADDRESS OF LAST DIGIT TO BE PRINTED
MOVE A12,1(A10)
CAIGE A12,5 ; WOULD ROUNDING GENERATE CARRY?
JRST PRIN42 ; NO
PRIN41: AOS A12,(A10) ; INCREMENT DIGIT
CAIE A12,^D10 ; ANY CARRY?
JRST PRIN42 ; NO
SETZM (A10) ; YES - REPLACE BY ZERO
SOJA A10,PRIN41 ; KEEP GOING
PRIN42: MOVEI A7,1(A5) ; ADDRESS OF OVERFLOW DIGIT
SKIPE (A7) ; OVERFLOW OCCURRED?
AOJA A13,PRIN43 ; YES - INCREMENT EXPONENT
ADDI A7,1 ; NO - MOVE TO FIRST DIGIT
PRIN43: MOVE A0,A13 ; TRANSFER EXPONENT TO SAFE PLACE
JUMPE A3,PRIN50 ; JUMP IF FLOATING POINT MODE
; FIXED POINT PRINTING SEQUENCE
JUMPG A0,.+2
JUMPL A2,PRIN48 ; JUMP IF NUMBER < 1.0
MOVEI AX,PRIN44
PRIN44: CAMGE A0,A3 ; LEADING SPACES REQUIRED?
SOJA A3,SPACE%
JSP AX,PRIN3 ; PRINT SIGN
JSP AX,PRIN4 ; OUTPUT INTEGRAL DIGIT
SOJN A0,PRIN4 ; RETURN IF MORE DIGITS
JUMPE A4,PRIN46 ; ANY FRACTION?
JSP AX,PRIN1 ; YES - PRINT DECIMAL POINT
PRIN45: JSP AX,PRIN4 ; OUTPUT FRACTIONAL DIGIT
SOJN A4,PRIN4 ; RETURN IF MORE DIGITS
PRIN46: MOVE SP,A5 ; RESTORE STACK
POPJ SP,0 ; EXIT
PRIN47: JSP AX,SPACE% ; PRINT LEADING SPACES
PRIN48: SOJN A3,PRIN47 ; ANY LEFT?
JSP AX,PRIN3 ; NO - PRINT SIGN
MOVEI A13,"0"
JSP AX,OUCHAR ; OUTPUT A ZERO
JUMPE A4,PRIN46 ; FRACTION TO BE PRINTED?
JSP AX,PRIN1 ; YES - OUTPUT DECIMAL POINT
PRIN49: AOJG A0,PRIN45 ; OUTPUT ZEROS IF REQUIRED
MOVEI A13,"0"
JSP AX,OUCHAR
SOJN A4,PRIN49
JRST PRIN46 ; NO DIGITS REQUIRED!
; FLOATING POINT PRINTING SEQUENCE
PRIN50: JSP AX,PRIN3 ; FLOATING POINT MODE - OUTPUT SIGN
JSP AX,PRIN4 ; OUTPUT FIRST DIGIT
JSP AX,PRIN1 ; AND DECIMAL POINT
JSP AX,PRIN4 ; OUTPUT FRACTIONAL DIGIT
SOJN A4,PRIN4 ; RETURN IF MORE DIGITS
SOJE A0,PRIN52 ; CALCULATE EXPONENT - ESCAPE IF ZERO
PRIN51: MOVEI A13,"&"
JSP AX,OUCHAR ; OUTPUT "&"
TLZE A2,LNGEXP
JRST PRIN51 ; AND SECOND ONE IF LONG REAL NUMBER
MOVEI A3,2 ; AND SET DIGIT COUNT
MOVE SP,A5 ; RESTORE STACK POINTER
JRST PRIN6 ; AND LET PRIN6 DO THE WORK
PRIN52: MOVEI A3,4 ; SUPPRESS ZERO EXPONENT
TLZE A2,LNGEXP
MOVEI A3,5 ; TAKING ACCOUNT OF LONG REAL
MOVEI AX,PRIN53
PRIN53: SOJGE A3,SPACE% ; AND OUTPUT SPACES
JRST PRIN46
; BINARY READ
PRIN54: MOVE A13,A0
JSP AX,OUCHAR ; OUTPUT FIRST WORD
CAIE A2,2 ; LONG REAL?
POPJ SP,0 ; NO
MOVE A13,A1
JSP AX,OUCHAR ; YES - OUTPUT SECOND WORD
POPJ SP,0
SUBTTL DOUBLE PRECISION MULTIPLY/DIVIDE
; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A5,A6
; THE RIGHT HAND OPERAND IS IN HTEN AND LTEN, INDEXED BY A10
; THE LINK IS IN AX
; ON EXIT:
; THE RESULT IS IN A5,A6
; FOR MULTIPLY ONLY:
; ERROR RETURN IF OVERFLOW
; OK SKIP RETURN
DFMPR: MOVE A7,HTEN(A10)
MOVE A10,LTEN(A10)
DFMP A5,A7 ; MULTIPLY
JFOV CNC.AX ; OVERFLOW?
AOJA AX,CNC.AX ; NO
DFDVR: MOVE A7,HTEN(A10)
MOVE A10,LTEN(A10)
DFDV A5,A7 ; DIVIDE
JRST CNC.AX
SUBTTL SELIN/SELOUT - SELECT INPUT/OUTPUT ROUTINES
; ON ENTRY A1 = CHANNEL NUMBER TO BE SELECTED
SELIN: JUMPL A1,SEL1 ; ALWAYS ALLOW CHANNEL -1
MOVEI A2,(A1)
ADDI A2,(DB) ; RELOCATE IO DIRECTORY
SKIPE A2,%IODR(A2) ; CHANNEL DEFINED?
TLNN A2,ININT ; YES - DEVICE INITED FOR INPUT?
IOERR 2,(A1) ; NO - COMPLAIN
SEL1: HRLM A1,%CHAN(DB) ; YES - SELECT IT
POPJ SP,0
SELOUT: JUMPL A1,SEL2 ; ALWAYS ALLOW CHANNEL -1
MOVEI A2,(A1)
ADDI A2,(DB) ; RELOCATE IO DIRECTORY
SKIPE A2,%IODR(A2) ; CHANNEL DEFINED?
TLNN A2,OUTINT ; YES - DEVICE INITED FOR OUTPUT?
IOERR 2,(A1) ; NO - COMPLAIN
;
; Edit(1012) Do a BREAKOUTPUT if SELECTing away from TTY:
;
SEL2: HRRZ A2,%CHAN(DB) ; [E1012] GET CURRENT OUTPUT CHANNEL
ADDI A2,(DB) ; [E1012] RELOCATE IT
MOVE A2,%IODR(A2) ; [E1012] AND GET CHANNEL STATUS
TLNE A2,TTYDEV!TTYTTC; [E1012] IF CURRENT DEVICE IS A TTY
JSP AX,BRKCHR ; [E1012] ... THEN BREAKOUTPUT
HRRM A1,%CHAN(DB) ; [E1012] SELECT NEW CHANNEL
POPJ SP,0
SUBTTL INPT/OUTPT - INPUT/OUTPUT DEVICE INITIALIZATION ROUTINE
; ON ENTRY:
; A0 = DEVICE NAME (IF PHYSICAL DEVICE), OR STRING ADDRESS (IF LOGICAL DEVICE)
; LH(A1) = NUMBER OF BUFFERS REQUIRED (PHYSICAL DEVICES ONLY)
; RH(A1) = CHANNEL NUMBER
; A2 = MODE (PHYSICAL DEVICES ONLY)
; DEVCHR FLAGS (LH):
DEVDDS=400000 ; DTA DIRECTORY IN STORE
DEVDSK=200000 ; DSK
DEVCDR=100000 ; CDR/CDP
DEVLPT=040000 ; LPT
DEVTAJ=020000 ; TTY ATTACHED TO JOB
DEVTUC=010000 ; TTY IN USE AS USER'S CONSOLE
DEVTIO=004000 ; TTY IN USE FOR IO
DEVDSP=002000 ; DISPLAY
DEVLDT=001000 ; LONG DISPATCH TABLE
DEVPTP=000400 ; PTP
DEVPTR=000200 ; PTR
DEVDTA=000100 ; DTA
DEVAA=000040 ; DEVICE AVAILABLE OR ASSIGNED TO THIS JOB
DEVMTA=000020 ; MTA
DEVTTY=000010 ; TTY
DEVDIR=000004 ; DIRECTORY DEVICE
DEVIN=000002 ; DEVICE CAN DO INPUT
DEVOUT=000001 ; DEVICE CAN DO OUTPUT
; DEVTYP FLAGS (LH):
DEVSPL=000020 ; DEVICE IS SPOOLED
; IO FLAGS (LH OF A2):
INFLG=DEVIN ; INPUT FLAG
OUTFLG=DEVOUT ; OUTPUT FLAG
; IO DIRECTORY SETUP FLAG COMBINATIONS:
IODSKI=PLDEV!DIRDEV!INDEV!ININT!OUTDEV
IOCDR=PLDEV!INDEV!ININT
IOLPT=PLDEV!OUTDEV!OUTINT
IODSKO=PLDEV!DIRDEV!INDEV!OUTDEV!OUTINT
IOCDP=PLDEV!OUTDEV!OUTINT
IOPTP=PLDEV!OUTDEV!OUTINT
IOPTR=PLDEV!INDEV!ININT
IODTAI=PLDEV!DIRDEV!INDEV!ININT!OUTDEV
IOMTAI=PLDEV!SPOPRN!INDEV!ININT!OUTDEV
IOTTYI=PLDEV!TTYDEV!INDEV!ININT!OUTDEV
IOTTYO=PLDEV!TTYDEV!INDEV!OUTDEV!OUTINT
IOTTYB=IOTTYI!IOTTYO
IODTAO=PLDEV!DIRDEV!INDEV!OUTDEV!OUTINT
IOMTAO=PLDEV!SPOPRN!INDEV!OUTDEV!OUTINT
IOPLT=PLDEV!PLTDEV!OUTDEV!OUTINT
IOLOGI=INDEV!ININT!INOK
IOLOGO=OUTDEV!OUTINT!OUTOK
IOTTC=PLDEV!TTYDEV!TTYTTC!ABMODE!INDEV!ININT!OUTDEV!OUTINT
; JFFO IGNORE FLAGS:
JFFFLG=DEVDDS!DEVTAJ!DEVTUC!DEVTIO!DEVLDT!DEVAA!DEVDIR!DEVIN!DEVOUT
; BUFFER LENGTHS: (USED IF DEVSIZ NOT IMPLEMENTED)
DSKBL=203 ; DSK
CDRBL=36 ; CDR
LPTBL=37 ; LPT
CDPBL=36 ; CDP
PTPBL=43 ; PTP
PTRBL=43 ; PTR
DTABL=202 ; DTA
MTABL=203 ; MTA
TTYBL=23 ; TTY
PLTBL=46 ; PLT
; MAGIC TABLE OF DEVICE PROPERTIES:
; LH = IO DIRECTORY ENTRY BITS
; RH = BUFFER LENGTH (TOTAL)
INOU1=.-1
XWD IODSKI,DSKBL ; DSK (INPUT)
XWD IOCDR,CDRBL ; CDR
XWD IOLPT,LPTBL ; LPT
XWD 0,0 ; SPARE
XWD IODSKO,DSKBL ; DSK (OUTPUT)
XWD IOCDP,CDPBL ; CDP
XWD 0,0 ; DISPLAY (NOT SUPPORTED)
XWD 0,0 ; SPARE
XWD IOPTP,PTPBL ; PTP
XWD IOPTR,PTRBL ; PTR
XWD IODTAI,DTABL ; DTA (INPUT)
XWD IOPLT,PLTBL ; PLT
XWD IOMTAI,MTABL ; MTA (INPUT)
XWD IOTTYI,TTYBL ; TTY (INPUT)
XWD IODTAO,DTABL ; DTA (OUTPUT)
XWD 0,0 ; SPARE
XWD IOMTAO,MTABL ; MTA (OUTPUT)
XWD IOTTYO,TTYBL ; TTY (OUTPUT)
INOU15: XWD IOTTYB,TTYBL*2 ; TTY (BOTH WAYS)
INPT: TLOA A2,INFLG ; SET INPUT FLAG
OUTPT: TLO A2,OUTFLG ; SET OUTPUT FLAG
IFN FTOVRL,<
MOVEI A4,(A1)
ADDI A4,(DB) ; CHECK THAT HE'S NOT
MOVE A4,%IODR(A4) ; TRYING TO USE
CAMN A4,[-1] ; OVRLAY'S CHANNEL
IOERR 15,(A1) ; HE IS - COMPLAIN
>
PUSHJ SP,RELESE ; ENSURE CHANNEL IS RELEASED
JFCL .+1 ; ERROR RETURN IS OK
TRNN A1,LOGCHN ; LOGICAL CHANNEL?
JRST INOU2 ; NO
PUSH SP,A0 ; YES -
PUSH SP,A1
PUSH SP,A2 ; SAVE A0-A2
MOVEI A0,3
PUSHJ SP,GETOWN ; AND ASK FOR 3 WORDS
POP SP,A4 ; RESTORE IO FLAG
POP SP,A2 ; RESTORE CHANNEL NUMBER
ADDI A2,(DB) ; AND RELOCATE IT
POP SP,A3 ; RESTORE STRING ADDRESS
MOVEM A3,STRPTR(A1) ; FILL IN ADDRESS OF STRING
MOVEI A3,@A3 ; GET ABSOLUTE ADDRESS
HLLZ A0,STR2(A3)
HRLI A1,IOLOGI
TLNE A4,INFLG ; INPUT?
JRST INOU13 ; YES
HRLI A1,IOLOGO ; [E131] NO
SKIPE STR1(A3) ; [E131] CHECK FOR NULL STRING
SKIPN STR2(A3) ; [E131] . .
JRST INOU13 ; [E131] AND BE KIND IF IT IS
TLNN A0,STRDYN ; NO - DYNAMIC?
SYSER1 17,0 ; NO - COMPLAIN
INOU13: HLRZ A4,STR1(A3) ; GET BYTE SIZE & POSITION FROM STRING
TRZ A4,STRBSC ; ISOLATE BYTE-SIZE
LSH A4,-6
CAIE A4,^D36 ; IF NOT 36 BIT BYTES
TLO A1,ABMODE ; THEN SET ASCII MODE
MOVE A0,STR1(A3) ; GET BYTE STRING POINTER
MOVEM A0,BYTPTR(A1) ; FILL IN BYTE POINTER
MOVE A0,STR2(A3)
TLZ A0,STRBCC ; GET BYTE COUNT FROM STRING
MOVEM A0,BYTCNT(A1) ; FILL IN BYTE COUNT
SKIPE STR1(A3) ; [E131]
JUMPG A0,INOU17 ; [E131] IF NULL STRING,
TLNN A1,OUTFLG ; [E131] SET END OF FILE
TLOA A1,INEOF ; [E131] FLAG (INEOF OR
TLO A1,OUTEOF ; [E131] OUTEOF) IF NO BYTES
INOU17: MOVEM A1,%IODR(A2) ; SET UP IO DIRECTORY ENTRY
MOVEI A1,0 ; SAY OK
POPJ SP,0
INOU2: MOVEM A0,%SYS10(DB) ; SAVE DEVICE NAME
MOVE A3,A0 ; PHYSICAL DEVICE
DEVCHR A3, ; GET ITS CHARACTERISTICS
JUMPE A3,INOU3 ; CHECK IT EXISTS
SETCM A4,A3 ; GET COMPLEMENTED CHARACTERISTICS
AND A4,A2 ; AND MASK WITH IO REQUIREMENTS
TLNE A3,DEVAA ; DEVICE AVAILABLE?
TLNE A4,INFLG!OUTFLG ; AND OK FOR IO REQUIREMENTS?
JRST INOU3 ; NO
HRRZ A4,A2 ; YES - GET MODE REQUIRED
CAIL A4,15 ; DUMP MODE REQUIRED?
JRST INOU4 ; YES - CAN'T HANDLE IT
MOVEI A5,1
LSH A5,(A4) ; AND CONSTRUCT ONE BIT MASK
AND A5,A3 ; WITH DEVICE CHARACTERISTICS
JUMPE A5,INOU4 ; JUMP IF ILLEGAL MODE
HLLZ A5,A3 ; GET LH OF CHARACTERISTICS
TLZ A5,JFFFLG ; AND CLEAR UNWANTED FLAGS
JFFO A5,INOU5 ; SORT IT ALL OUT
TLNN A3,DEVOUT ; FUNNY DEVICE
JRST INOU3 ; CAN IT DO OUTPUT?
MOVEI A6,14 ; YES - MUST BE A PLOTTER
JRST INOU7
INOU3: TDOA A1,[
IOERR 0,0] ; R.H. OF A1 = CHAN #
INOU4: TDO A1,[
IOERR 1,0] ; WRONG MODE (0, ABOVE, = DEV NO GOOD)
TLZ A1,37 ; CLEAR INDEX, INDIRECT BITS
POPJ SP,
INOU5: TLNE A3,DEVDSK!DEVDTA!DEVMTA!DEVTTY
; DSK, DTA, TTY, MTA OR NUL?
JRST INOU6 ; YES
TLNN A3,DEVCDR ; NO - CDR/CDP?
JRST INOU7 ; NO
TLNE A3,DEVOUT ; YES - CAN IT DO OUTPUT ?
ADDI A6,4 ; YES - OFFSET FOR CDP
JRST INOU7
INOU6: TLNE A2,OUTFLG ; DSK ETC - REQUIRED FOR OUTPUT?
ADDI A6,4 ; YES - ADD OFFSET
TLNN A3,DEVTAJ ; TTY CONTROLLING JOB ?
JRST INOU7 ; NO
MOVE A3,%TTYCH(DB) ; [E132] SEE IF ANY
AOJN A3,INOU18 ; [E132] TTY ALREADY OPEN
MOVEI A6,INOU15-INOU1 ; [E132] YES - MAKE IT A
JRST INOU14 ; [E132] "BOTH WAY" TTY
INOU18: SUBI A3,1 ; [E132] CORRECT %TTYCH
TLNE A2,OUTFLG ; YES - NEW ONE WANTED FOR O/P ?
MOVS A3,A3 ; NO - I/P. MAKE IT = OLD O/P,,OLD I/P
TLNN A3,400000 ; [E132] OLD DIRECTION = NEW ?
JRST INOU3 ; DEVICE NOT AVAILABLE ERROR
EXCH A1,A3 ; SAVE NEW CHAN # - GET OLD ONE
MOVEI A7,1 ; SET UP TO CLOSE I/P SIDE ONLY
TLNE A2,OUTFLG ; WANTED FOR O/P ?
TRC A7,3 ; YES - CLOSE O/P SIDE ONLY (CLOSE CH,2)
PUSHJ SP,CLFIL5 ; DO IT
ADDI A1,(DB) ; RELOCATE OLD CHAN-#
MOVE A7,%IODR(A1) ; GET DIRECTORY ENTRY
TLNE A2,OUTFLG ; IF NEW DIRECTION = O/P
TLZA A7,OUTEOF!OUTOK!OUTFIL ; CLEAR OLD O/P FLAGS
TLZ A7,INEOF!INOK!INFIL ; ELSE CLEAR OLD I/P FLAGS
MOVEM A7,%IODR(A1) ; & RETURN DIRECTORY ENTRY
MOVE A1,A3 ; RESTORE NEW CHAN #
INOU14: TLNN A2,OUTFLG ; WANTED FOR O/P ?
HRLM A1,%TTYCH(DB) ; NO -SET I/P CHAN #
TLNE A2,OUTFLG
HRRM A1,%TTYCH(DB) ; YES - SET O/P CHAN #
INOU7: SKIPN A3,INOU1(A6) ; GET DEVICE PROPERTIES
JRST INOU3 ; NO GOOD FOR ALGOL (DISPLAY, ETC.)
EDIT (213);
CAIG A4,3 ;[213] NOT A BINARY MODE?
TLO A3,ABMODE ; YES - SET ASCII/BINARY FLAG
MOVEM A4,%SYS7(DB) ; SAVE DEVICE MODE
DEVTYP A0, ; FIND OUT MORE
MOVEI A0,0 ; UUO NOT IMPLEMENTED
TLNE A0,DEVSPL ; SPOOLED DEVICE?
TLO A3,SPLDEV ; YES
HLRZ A0,A1 ; GET NUMBER OF BUFFERS REQUIRED
MOVEI A5,%SYS7(DB)
DEVSIZ A5, ; GET BUFFER SIZE OF DEVICE
JRST INOU11 ; UUO NOT IMPLEMENTED
JUMPL A5,[
AOJE A5,INOU3 ; DEFENSIVE CODING
JRST INOU4]
HRR A3,A5 ; GET BUFFER SIZE
TLNE A3,TTYDEV ; TTY TYPE DEVICE?
ADDI A3,(A5) ; YES - DOUBLE UP BUFFERS
JUMPN A0,INOU12 ; ANY BUFFERS SPECIFIED?
HLRZ A0,A5 ; NO - USE DEFAULT
JRST INOU12
INOU11: JUMPN A0,INOU12 ; NO DEVSIZ - ANY BUFFERS SPECIFIED?
MOVEI A0,2 ; NO - DEFAULT IS 2
INOU12: MOVEM A0,%SYS11(DB) ; SAVE NUMBER OF BUFFERS
IMULI A0,(A3) ; MULTIPLY BY BUFFER SIZE
MOVN A4,A0 ; PREPARE TO CALCULATE BUFFER OFFSET
ADDI A0,DEVCAL ; ALLOW FOR CONTROL AREA AND DEVICE NAME
TLNE A3,TTYDEV ; TTY TYPE DEVICE?
ADDI A0,BDDOFF ; YES - ALLOW FOR SECOND CONTROL AREA
TLNE A3,DIRDEV!SPLDEV
; DIRECTORY DEVICE?
ADDI A0,FILCAL ; YES - ALLOW FOR FILE CONTROL AREA
ADD A4,A0 ; CALCULATE BUFFER OFFSET
HRL A1,A4 ; AND STORE IN LH OF CHANNEL NUMBER
MOVEM A1,%SYS12(DB) ; SAVE CHANNEL NUMBER
MOVEM A3,%SYS13(DB) ; SAVE DEVICE PROPERTIES
PUSHJ SP,GETOWN ; GET SPACE FOR CONTROL AREAS AND BUFFERS
MOVE A2,%SYS13(DB) ; DEVICE PROPERTIES
HRR A2,A1 ; ADD CONTROL AREA ADDRESS
MOVE A3,%SYS12(DB) ; RESTORE CHANNEL NUMBER
HLRZ A4,A3 ; AND BUFFER OFFSET
HRRZ A5,A1
HRLI A5,BDDOFF(A1) ; PREPARE CONTROL AREA POINTERS
TLNE A2,ININT ; I/P ?
JRST INOU16 ; YES
TLNE A2,TTYDEV ; NO - TTY ?
TRZA A5,-1 ; YES: KILL I/P, LEAVING O/P AS 2ND CNTRL AREA
HRLZ A5,A5 ; NO - KILL I/P SECTION
INOU16: TLNN A2,OUTINT ; OUTPUT ?
TLZ A5,-1 ; NO - KILL O/P SECTION
EXCH A5,%SYS11(DB) ; INTERCHANGE WITH NUMBER OF BUFFERS
HRLZI A6,<OPEN>B53
HRRI A6,%SYS7(DB)
DPB A3,[POINT 4,A6,12] ; PREPARE OPEN CH,
EXCH A3,A1 ; GET CHAN # TO A1 FOR INOU3
XCT A6 ; AND TRY TO OPEN DEVICE
JRST INOU3 ; ALAS - FAILED
MOVE A0,%SYS10(DB) ; RECOVER DEVICE NAME
ADD A4,A3 ; CALCULATE ADDRESS OF BUFFERS
MOVEM A4,.JBFF ; AND SET UP JOBFF
HRRZ A4,A2 ; LOOK FOR PLACE FOR DEVICE NAME .....
TLNN A2,ININT ; INPUT REQUIRED?
JRST INOU9 ; NO
HRLI A5,<INBUF>B53 ; YES
DPB A1,[
POINT 4,A5,12] ; PREPARE INBUF CH,
XCT A5 ; AND SET UP BUFFERS
INOU9: TLNE A2,TTYDEV!ININT ; I/P ? OR TTY ? (TTY O/P AREA IS 2ND)
ADDI A4,BDDOFF ; YES - OFFSET FOR 2ND AREA
TLNN A2,OUTINT ; OUTPUT REQUIRED?
JRST INOU10 ; NO
HRLI A5,<OUTBUF>B53 ; YES
DPB A1,[
POINT 4,A5,12] ; PREPARE OUTBUF CH,
XCT A5 ; AND SET UP BUFFERS
ADDI A4,BDDOFF ; .....
INOU10: ADDI A1,(DB) ; RELOCATE CHANNEL NUMBER
MOVEM A2,%IODR(A1) ; SET UP DIRECTORY ENTRY FOR CHANNEL
MOVEM A0,(A4) ; STORE DEVICE NAME
SETOM .JBFF ; FIX JOBFF
MOVEI A1,0 ; SAY OK
POPJ SP,0 ; AND EXIT
SUBTTL RELESE - RELEASE IO CHANNEL ROUTINE
; ON ENTRY A1 = CHANNEL NUMBER TO BE RELEASED
; NON SKIP RETURN IF CHANNEL NOT DEFINED
; OK SKIP RETURN
; A0, A1 AND A2 ARE SAVED AS THIS ROUTINE IS CALLED
; FROM INPT/OUTPT
RELESE: MOVE A4,%TTYCH(DB)
CAIN A1,(A4) ; TTY O/P ON THIS CHANNEL ?
HLLOS %TTYCH(DB) ; [E132] YES - CLEAR IT
MOVS A4,A4 ;
CAIN A1,(A4) ; SAME FOR
HRROS %TTYCH(DB) ; [E132] INPUT
MOVEI A4,(A1)
ADDI A4,(DB) ; RELOCATE CHANNEL NUMBER
SKIPN A3,%IODR(A4) ; CHANNEL DEFINED?
POPJ SP,0 ; NO - ERROR RETURN
CAMN A3,[-1] ; DID CHANNEL BELONG TO OVRLAY ?
JRST REL5 ; YES - HE DOES HIS OWN BUFFERING.
TLNN A3,OUTOK ; DEVICE DOING OUTPUT?
JRST REL1 ; NO
EXCH A1,%CHAN(DB) ; YES - FAKE THIS CHANNEL
PUSHJ SP,BRKBYT ; AND BREAK OUTPUT
JFCL .+1
REL0: EXCH A1,%CHAN(DB) ; RESTORE IO CHANNELS
REL1: SETZM %IODR(A4) ; CLEAR IO DIRECTORY ENTRY
TLNN A3,ININT ; INPUT DEVICE?
JRST REL2 ; NO
HLRZ A4,%CHAN(DB) ; YES - GET CURRENT INPUT CHANNEL NUMBER
CAIN A4,(A1) ; THIS ONE?
HRROS %CHAN(DB) ; YES - DESELECT IT
REL2: TLNN A3,OUTINT ; OUTPUT DEVICE?
JRST REL3 ; NO
HRRZ A4,%CHAN(DB) ; YES - GET CURRENT OUTPUT CHANNEL NUMBER
CAIN A4,(A1) ; THIS ONE?
HLLOS %CHAN(DB) ; YES - DESELECT IT
REL3: DMOVEM A0,%SYS10(DB)
DMOVEM A2,%SYS12(DB) ; SAVE A0-A3
HRRZ A1,A3
MOVEI A0,0
PUSHJ SP,GETOWN ; AND DELETE CONTROL AREAS AND BUFFERS
DMOVE A0,%SYS10(DB)
DMOVE A2,%SYS12(DB) ; RESTORE A0-A3
AOS (SP) ; SKIP LINK
TLNN A3,PLDEV ; LOGICAL DEVICE?
POPJ SP,0 ; YES - EXIT
TLNN A3,SPOPRN ; SPECIAL OPERATIONS PERMITTED?
JRST REL4 ; NO
HRLZI A4,<CLOSE>B53 ; YES - IT'S A MAGNETIC TAPE
DPB A1,[
POINT 4,A4,12] ; PREPARE CLOSE CH,0
XCT A4 ; AND EXECUTE IT
REL4: HRLZI A4,<RELEAS>B53
DPB A1,[
POINT 4,A4,12] ; PREPARE RELEAS CH,
XCT A4 ; AND RELEASE DEVICE
POPJ SP,0 ; EXIT
REL5: SETZM %IODR(A4) ; OVRLAY'S CHAN - JUST CLEAR DIR. ENTRY
AOS (SP) ; SKIP RETURN
POPJ SP,
SUBTTL OPFILE - OPEN FILE ROUTINE
; ON ENTRY:
; A1 = CHANNEL NUMBER
; A2 = FILE NAME
; A3 = FILE EXTENSION (LEFT HALF)
; A4 = PROTECTION (TOP 9 BITS)
; A5 = PROJECT-PROGRAMMER NUMBER
OPFILE: MOVEI A0,0
MOVEI A10,(A1)
ADDI A10,(DB) ; RELOCATE CHANNEL NUMBER
SKIPN A6,%IODR(A10) ; CHANNEL DEFINED?
IOERR 2,(A1) ; NO
TLNN A6,DIRDEV!SPLDEV
; YES - DIRECTORY DEVICE OR SPOOLED?
POPJ SP,0 ; NO - EXIT
MOVEM A2,FILNAM(A6) ; STORE FILE NAME,
MOVEM A3,FILEXT(A6) ; EXTENSION,
MOVEM A4,FILPRT(A6) ; PROTECTION,
MOVEM A5,FILPP(A6) ; AND PROJECT-PROGRAMMER NUMBER
TLNE A6,INFIL!OUTFIL ; FILE OPEN?
JRST OPFIL2 ; YES
HRLZI A7,<LOOKUP>B53
TLNE A6,OUTINT ; INPUT?
TLOA A6,OUTFIL ; NO
TLOA A6,INFIL ; YES
HRLZI A7,<ENTER>B53 ; NO
OPFIL1: HRRI A7,FILNAM(A6) ; AND GET ADDRESS
DPB A1,[
POINT 4,A7,12] ; FILL IN CHANNEL NUMBER
XCT A7 ; AND ATTEMPT TO OPEN FILE
JRST OPFIL3 ; FAILED
TLNN A6,INFIL ; WAS IT A LOOKUP ?
JRST .+3 ; NO
SKIPN FILPP(A6) ; IS IT NULL ?
EDIT(017); MAKE SURE EOF FLAG IS CORRECT
TLOA A6,INEOF ; [E017] YES - FLAG IT.
TLZ A6,INEOF ; [E017] OTHERWISE CLEAR EOF FLAG
MOVEM A6,%IODR(A10) ; AND UPDATE IO DIRECTORY ENTRY
POPJ SP,0
OPFIL2: HRLZI A7,<RENAME>B53 ; PREPARE FOR RENAME
TLZ A6,INFIL!OUTFIL!INOK!OUTOK
; NO - REALLY A DELETE
JRST OPFIL1
OPFIL3: HRRZ A0,FILEXT(A6) ; GET ERROR-CODE
ADDI A0,100 ; ADD 100 (0 IS A VALID ERROR-CODE !)
POPJ SP, ; & RETURN IT (CHAN # IN A1)
SUBTTL CLFILE - CLOSE FILE ROUTINE
; ON ENTRY A1 = CHANNEL NUMBER
; A0,A1,A2,A3 ARE NOT USED
CLFILE: MOVE A4,%TTYCH(DB) ;
CAIN A1,(A4) ; TTY O/P ON THIS CHANNEL ?
HLLOS %TTYCH(DB) ; [E132] YRS- CLEAR IT
MOVS A4,A4 ;
CAIN A1,(A4) ; SAME FOR
HRROS %TTYCH(DB) ; [E132] INPUT
MOVEI A4,(A1)
ADDI A4,(DB) ; RELOCATE CHANNEL NUMBER
SKIPN A6,%IODR(A4) ; CHANNEL DEFINED?
IOERR 2,(A1) ; NO - COMPLAIN
TLNE A6,DIRDEV!SPLDEV
; YES - DIRECTORY DEVICE OR SPOOLED?
TLZN A6,INFIL!OUTFIL ; FILE OPEN?
POPJ SP,0 ; NO - EXIT
SETZ A7, ; YES - CLEAR ALL OF IT
PUSHJ SP,CLFIL5 ;
TLZ A6,INEOF!OUTEOF!INOK!OUTOK
; CLEAR EOF AND OK FLAGS
MOVEM A6,%IODR(A4) ; RESTORE DIRECTORY ENTRY
POPJ SP,0 ; EXIT
CLFIL5: HRLI A7,<CLOSE>B53 ;
DPB A1,[POINT 4,A7,12] ; PREPARE CLOSE CH,0
XCT A7 ; AND CLOSE FILE
MOVE A7,[STATZ 740000]
DPB A1,[POINT 4,A7,12] ; PREPARE STATZ CH,740000
XCT A7 ; FILE CLOSED OK?
IOERR 12,(A1) ; NO - COMPLAIN
POPJ SP, ;
SUBTTL XFILE - TRANSFER FILE ROUTINE
; TRANSFERS FILE FROM CURRENT INPUT DEVICE
; TO CURRENT OUTPUT DEVICE.
XFILE: PUSHJ SP,INBYTE ; GET INPUT BYTE
POPJ SP,0 ; END OF FILE ON INPUT
PUSHJ SP,OUBYTE ; OUTPUT BYTE
POPJ SP,0 ; END OF FILE ON OUTPUT
JRST XFILE ; CONTINUE
SUBTTL MAGNETIC TAPE ROUTINES
; ON ENTRY, THE CHANNEL NUMBER IS IN A1
BSPACE: TDZA A2,A2 ; BACKSPACE
ENFILE: MOVEI A2,1 ; ENDFILE
JRST SO1
REWND.: MOVEI A2,2 ; REWIND
SO1: MOVEI A3,(A1)
ADDI A3,(DB) ; RELOCATE CHANNEL NUMBER
SKIPN A3,%IODR(A3) ; CHANNEL DEFINED?
IOERR 2,(A1) ; NO - COMPLAIN
TLNN A3,SPOPRN ; YES - SPECIAL OPERATIONS PERMITTED
IOERR 13,(A1) ; NO - COMPLAIN
JUMPN A2,SO4 ; BACKSPACE?
TLNN A3,ININT ; YES - OK ON INPUT?
IOERR 13,(A1) ; NO - COMPLAIN
MOVEI A4,17 ; SET UP FOR MTAPE
SO2: HRLI A4,<MTAPE>B53
SO3: DPB A1,[
POINT 4,A4,12] ; PREPARE RELEVANT MTAPE
XCT A4 ; AND EXECUTE IT
TRZE A4,-1 ; WAS THAT CLOSE?
XCT A4 ; NO - WAIT
POPJ SP,0
SO4: SOJN A2,SO5 ; ENDFILE?
MOVEI A4,16
TLNE A3,ININT ; INPUT?
JRST SO2 ; YES
HRLZI A4,<CLOSE>B53 ; NO
JRST SO3
SO5: MOVEI A4,1 ; REWIND
JRST SO2
SUBTTL ROUTINES FOR LINK'S OVERLAY-HANDLER
IFN FTOVRL,<
FUNCT: MOVEM A3,%ACCS+3(DB)
MOVEI A3,%ACCS(DB)
BLT A3,%ACCS+2(DB)
MOVE A2,@(AX) ; FUNCTION CODE
CAIG A2,FNCTLN ; LEGAL ?
JRST @FNCTB(A2) ; DISPATCH
FNCTIL: SETO A1, ; FUNCTION ILLEGAL
JRST FNCTER ; RETURN ERROR
FNCTB: FNCTIL ; 0 ILLEGAL
FNCGAD ; 1 GET CORE AT SPECIFIED ADDRESS
FNCCOR ; 2 GET CORE ANYWHERE
FNCRAD ; 3 RETURN CORE
FNCGCH ; 4 GET I/O CHANNEL
FNCRCH ; 5 RETURN I/O CHANNEL
FNCGOT ; 6 GET OTS-CORE ANYWHERE (HEAP)
FNCROT ; 7 RETURN OTS (HEAP) CORE
FNCRNT ; 10 GET RUN-TIME
FNCIFS ; 11 GET NAME ETC. OF LOAD-FILE
FNCCBC ; 12 CUT BACK CORE
FNCTLN==.-FNCTB
FNCGAD: SKIPE A1,%SYSOV(DB) ; FIRST ENTRY ?
JRST FNCG1 ; NO
MOVEI A0,OVLCHN ; YES...
PUSHJ SP,GETCLR ; ...GET CORE FOR TABLE
HRLI A1,1-OVLCHN ; -(LENGTH-1)
MOVEM A1,%SYSOV(DB) ; SET UP POINTER-WORD TO TABLE
FNCG1: SKIPG A3,@4(AX) ; UNDOCUMENTED -1 CALL
MOVEI A3,^D200 ; GIVE HIM 200 WORDS
MOVEM A3,@4(AX) ; AND TELL HIM SO
MOVE A2,@3(AX) ; ADDRESS WANTED
CAIG A2,(DB) ; BELOW STACK ?
JRST FNCG2 ; YES
ADDI A2,(A3) ; GET END OF AREA WANTED
SUBI A2,(DB) ; GET AMOUNT TO SHIFT STACK
MOVEI A1,1(DB) ; SAVE OLD DB
CCORE1 (A2) ; SHIFT STACK
MOVE A3,@3(AX) ; ADDRESS OF TARGET
SUBI A3,-1(A1)
JUMPE A3,FNCTEX ; SPOT ON - NO SPARE PIECE
HRLZM A3,-1(A1) ; MAKE LINK-WORD FOR SPARE PIECE BELOW
MOVEI A0,0 ; AND
MOVE A2,%SYSOV(DB)
PUSHJ SP,GETKNL ; DELETE IT
JRST FNCTEX ; RETURN OK
FNCG2: TLZ DB,TMPFL3 ; SET OVL HEAP SEARCH FLAG
FNCG21: SKIPE A3,(A1) ; GET ENTRY FROM TABLE
CAIGE A2,(A3) ; COULD ADDRESS WANTED BE IN IT?
JRST FNCG31 ; NO
FNCG23: SUBI A2,(A3) ; FREE LENGTH BELOW TARGET
HLRZ A0,A3 ; TOTAL FREE LENGTH
SUBI A0,(A2) ; A0 = FREE LENGTH ABOVE TARGET
JUMPL A0,FNCG3 ; INCLUDES TARGET ADDRESS ? N0
SUB A0,@4(AX) ; IS IT LONG ENOUGH ?
JUMPL A0,FNCG25 ; NO
HRLM A2,(A1) ; NEW SHORT LENGTH TO TABLE
HRLM A2,(A3) ; AND LINK WORD
JUMPG A2,.+2 ; SAFETY
SETZM (A1) ; ZERO REDUNDANT LINK WORD
JUMPE A0,FNCTEX ; NO FREE SPACE ABOVE - DONE
MOVE A1,@3(AX) ; RESTORE TARGET
ADD A1,@4(AX) ; PLUS LENGTH
HRLZM A0,(A1) ; MAKE A NEW LINK WORD
TLNE DB,TMPFL3 ; WHOSE HEAP ?
SKIPA A2,%SYS2(DB) ; REAL ONE.
MOVE A2,%SYSOV(DB) ; PRIVATE ONE
AOS A1 ; FRIG FOR GETKNL
PUSHJ SP,GETKNL ; RETURN SPARE BIT
JRST FNCTEX
FNCG25: HLRZ A0,A3 ; HERE FOR GOOD BASE, BUT TOO SHORT
ADDI A0,(A3) ; TOP OF FREE AREA
CAIE A0,(DB) ; IS IT JUST BELOW DB ?
JRST FNCEX2 ; NO - FATAL FLAW
SKIPN A2 ; ANY SPARE SPACE BELOW ?
SETZM (A1) ; NO - ZAP TABLE-SLOT
;
; THIS IS IN FACT THE NORMAL CASE, BECAUSE OF THE WAY
; THAT OVRLAY WORKS. NON-ZERO LINK WORD WON'T MATTER.
;
HRLM A2,(A1) ; FIRST PLUG LOWER FREE TABLE
HRLM A2,(A3) ; AND LINK WORD
MOVE A1,@4(AX) ; REQUIRED LENGTH
ADD A1,@3(AX) ; AND BASE
SUBI A1,(DB) ; LESS DB = AMOUNT TO SHIFT
CCORE1 (A1)
JRST FNCTEX ; ALL DONE
FNCG3: MOVE A2,@3(AX) ; RESTORE ADDRESS WANTED
FNCG31: AOBJN A1,FNCG21 ; NOT THIS ENTRY - TRY NEXT
SKIPE A1,(A1) ; NO MORE TABLE-ENTRIES - ANOTHER PIECE ?
JRST FNCG21 ; YES - USE IT
MOVE A1,%SYS2(DB) ; SET UP TO SEARCH REGULAR HEAP
TLON DB,TMPFL3 ; UNLESS WE ALREADY HAVE
JRST FNCG21 ; TRY
JRST FNCEX2 ; NO GOOD
FNCEX2: MOVEI A1,2 ; SAY FAIL 2
JRST FNCTER
FNCCOR: ; GET CORE ANYWHERE
SKIPE A2,%SYSOV(DB) ; FIRST ENTRY ?
JRST FNCCR1 ; NO
MOVEI A0,OVLCHN ; YES...
PUSHJ SP,GETCLR ; ...GET CORE FOR TABLE
MOVEI A2,(A1)
HRLI A2,1-OVLCHN
MOVEM A2,%SYSOV(DB) ; SET UP POINTER
FNCCR1: MOVE A0,@4(AX) ; AMOUNT WANTED
PUSHJ SP,GETKNL ; GET PIECE
JRST FNCTST ; DONE
FNCRAD: ; RETURN CORE
MOVE A1,@3(AX) ; ADDR OF PIECE TO RETURN
MOVEI A0,0
MOVE A2,@4(AX) ; GET SIZE OF RETURN PIECE
HRLZM A2,(A1) ; AND MAKE A LINK WORD
AOS A1 ; INCREMENT POINTER
MOVE A2,%SYSOV(DB)
PUSHJ SP,GETKNL ; RELEASE CORE
JRST FNCTEX ; DONE
; CUT BACK CORE - RETURN OVERLAY HEAP TO MAIN HEAP
; PIECE BY PIECE FOR INTEGRITY
FNCCBC: SKIPN A3,%SYSOV(DB) ; GET OVERLAY HEAP TABLE POINTER
JRST FNCTEX ; NO TABLE - SILLY, BUT POSSIBLE
FNCBC1: SETZB A0,A1 ; FOR GETOWN RETURN & ENTRY KILL
EXCH A1,(A3) ; LOAD ENTRY & KILL IT
JUMPE A1,FNCBC2 ; NOTHING TO DECLARE
HLLZM A1,(A1) ; SET UP LENGTH WORD
MOVEI A1,1(A1) ; SET UP POINTER
PUSHJ SP,GETOWN ; AND FREE IT
FNCBC2: AOBJN A3,FNCBC1 ; HERE ONLY FOR NULL ENTRIES
SKIPN A3,(A3) ; GET ADDR OF NEXT BIT, IF ANY
JRST FNCTEX ; NONE (LEAVE LAST PIECE ALONE)
EXCH A3,%SYSOV(DB) ; DELETING THE BIT OF TABLE WE'VE DONE
MOVEI A1,(A3) ; GET ADDR OF LAST BIT OF TABLE
PUSHJ SP,GETOWN ; FREE IT
MOVE A3,%SYSOV(DB) ; ADDR OF NEXT BIT
JRST FNCBC1 ; CARRY ON
FNCGOT: ; GET OTS (HEAP) CORE
MOVE A0,@4(AX) ; LENGTH
PUSHJ SP,GETOWN ; GET IT
;
; NOTE THAT, DESPITE THE DESCRIPTION IN SOME VERSIONS OF THE
; DOCUMENTATION, THIS FUNCTION IS A "GET-CORE-ANYWHERE" TYPE
;
MOVEM A1,@3(AX) ; ADDRESS OF PIECE
JRST FNCTEX ; DONE
FNCROT: ; RETURN OTS CORE
MOVE A1,@3(AX) ; ADDRESS
MOVEI A0,0 ; (HE'D BETTER NOT CHANGE THE LENGTH!)
PUSHJ SP,GETOWN
JRST FNCTEX
FNCGCH: ; GET CHANNEL
MOVEI A1,17(DB) ; TRY 17 FIRST
SKIPN %IODR(A1) ; IS IT FREE ?
JRST FNCGC1 ; YES
CAILE A1,(DB) ; NO - ANY MORE ?
SOJA A1,FNCGCH+1 ; YES - KEEP TRYING
MOVEI A1,1 ; NO CHANNELS - ERROR CODE 1
JRST FNCTER
FNCGC1: SETOM %IODR(A1) ; MARK THE IODR AS IN USE
SUBI A1,(DB) ; RETRIEVE CHANNEL NUMBER
JRST FNCTST ; & RETURN IT
FNCRCH: ; RETURN CHANNEL
MOVE A1,@3(AX) ; NUMBER
ADDI A1,(DB)
SETZM %IODR(A1) ; CLEAR IODR ENTRY
JRST FNCTEX
FNCRNT: ; GET START RUN-TIME
MOVE A1,%SYS5(DB)
JRST FNCTST ; EASY
FNCIFS: ; GET LOAD-FILE NAME, ETC
MOVE A1,%IFDAT+2(DB) ; DEVICE
MOVEM A1,@3(AX)
MOVE A1,%IFDAT+1(DB) ; FILE-NAME
MOVEM A1,@4(AX)
MOVE A1,%IFDAT(DB) ; PPN
MOVEM A1,@5(AX)
JRST FNCTEX
FNCTST: MOVEM A1,@3(AX) ; SET ANSWER INTO ARG3
FNCTEX: SETZM @2(AX) ; STATUS CODE = 0
SKIPA
FNCTER: MOVEM A1,@2(AX) ; RETURN ERROR-STATUS
MOVSI A3,%ACCS(DB)
BLT A3,A3 ; RETORE ACCS
POPJ SP,
> ; END OF IFN FTOVRL
IFE FTOVRL,<
FUNCT: SYSER2 10, ; SAY NOT IMPLEMENTED.
>
SUBTTL TRACE HANDLING ROUTINES
TRLAB: TLNN DB,TRLVEL!INDDT ; FORCED OFF ?
PUSHJ SP,TRLENT ; NO - ENTER IT
AOJA AX,CNC.AX
TRSTD: TLNE DB,TRLVEL!INDDT ; TRACING ?
JRST TRSTD1 ; NO - EXIT
PUSH SP,A0 ; STANDARD FUNCTION TRACE.
PUSH SP,A1 ; MUST SAVE THEIR ARGUMENTS !
PUSH SP,AX ; SAVE LINK !
EDIT(061); SAVE CONTENTS OF AC3
PUSH SP,A3 ; [E061]
EDIT(015); DON'T CLOBBER ACS 10-13
PUSH SP,A10 ; [E015]
PUSH SP,A11 ; [E015]
PUSH SP,A12 ; [E015]
PUSH SP,A13 ; [E015]
AOS %TRLV(DB) ; INCR BLOCKLEVEL - HAVE NOT BEEN THRU PARAM
MOVE AX,-10(SP) ; [E061] GET POINTER TO PMB
PUSHJ SP,TRLENT ; DO IT
SOS %TRLV(DB) ; PUT DYNAMIC BLOCK-LEVEL BACK
POP SP,A13 ; [E015]
POP SP,A12 ; [E015]
POP SP,A11 ; [E015]
POP SP,A10 ; [E015]
POP SP,A3 ; [E061]
POP SP,AX ; RESTORE LINK
POP SP,A1 ; RESTORE ARGS
POP SP,A0
TRSTD1: AOS (SP) ; SKIP PMB POINTER
POPJ SP, ; RETURN
TRLMAN: MOVEI AX,PMBPTR(DL) ; GET PROCEDURE'S PMB POINTER
TLNE DB,TRLVEL!INDDT ; FORCED OFF ?
POPJ SP,
TRLENT: SKIPE A3,%TRPTR(DB) ; BUFFER SET UP ?
JRST TRLMN1 ; YES
HRRZ A0,%TRLNTH(DB) ; GET LENGTH OF TRACE BUFFER
PUSHJ SP,GETCLR
HRLZ A3,%TRLNTH(DB) ; GET - BUFFER LENGTH
MOVN A3,A3 ; IN LEFT HALF
HRR A3,A1
TRLMN1: SKIPN A2,(AX) ; GET POINTER
JRST TRLMN3
CAIG A2,(DB) ; MUST BE A HI-SEG PROG
AOS (A2) ; ELSE UPDATE PROFILE
AOBJN A3,TRLMN2 ; NOW UPDATE RING POINTER
SUB A3,%TRLNTH(DB) ; ADJUST TO TOP IF REQ'D
TRLMN2: HRL A2,%TRLV(DB) ; DYNAMIC BLOCK LEVEL
MOVEM A2,(A3) ; PLANT IT
TRLMN3: MOVEM A3,%TRPTR(DB) ; ANY TRACE LISTED ?
JUMPE A2,.+2
TLNN DB,STMTST ; DYNAMIC OR PM ?
POPJ SP,
TRDPRT: MOVNI A2,1 ; FORCE CHANNEL -1
EXCH A2,%CHAN(DB)
PUSHJ SP,PMTPR3 ; PRINT 1 ENTRY
TRDPEX: PUSHJ SP,BRKBYT ; FORCE IT OUT
JFCL .+1
MOVEM A2,%CHAN(DB) ; RESTORE CHANNEL
POPJ SP,
TRLPRT: TLZ DB,STMTST ; CLEAR DYNAMIC TRACE FLAG
SKIPE A3,%TRPTR(DB) ; ANY TRACE LISTED ?
JRST PMTPR1 ; YES - PRINT IT
NOTRACE: MOVEI A1,TRACE1 ; ELSE MESSAGE
JRST MONIT0 ; AND EXIT VIA MONIT
PMTPR1: MOVEI A1,TRACE2 ; HEADER MESSAGE
PUSHJ SP,MONIT
HRLZ A2,%TRLNTH(DB) ; GET LENGTH OF BUFFER.
ADD A3,A2
ADD A3,[1,,0]
MOVNI A2,1 ; FAKE CHANNEL -1
EXCH A2,%CHAN(DB)
PMTPR2: PUSHJ SP,PMTPR3
SUB A3,[1,,1] ; GET PREVIOUS ENTRY.
TLNN A3,-1 ; TOP OF BUFFER ?
ADD A3,%TRLNTH(DB) ; YES - GO TO BOTTOM.
HRRZ A1,%TRPTR(DB) ; GET ADDR OF LATEST ENTRY.
CAIN A1,(A3) ; GONE ALL THE WAY ROUND ?
JRST TRDPEX ; YES - GO HOME
JRST PMTPR2
PMTPR3: SKIPN A1,(A3) ; GET POINTER
POPJ SP, ; NO ENTRY
PUSHJ SP,PMCRLF ; TYPE CR-LF
HLRZ A0,A1 ; GET DYNAMIC BLOCK LEVEL
LSH A0,1 ; DOUBLE IT
IDIVI A0,^D60 ; TOO LONG ?
JUMPE A0,PMTPR7 ; NO
PUSH SP,A2
PUSH SP,A1 ; SAVE REM
PUSH SP,A3
EDIT (176); SAVE AX BEFORE CALL TO IPRINT IN PMTPR3
PUSH SP,AX ;[176] SAVE AX, IPRINT MAY CLOBBER IT!
PUSHJ SP,IPRINT ; PRINTS NUMBER
POP SP,AX ;[176] RESTORE AX
POP SP,A3
POP SP,A1
POP SP,A2
PMTPR7: TLNE DB,STMTST ; SPECIAL FOR DYNAMIC
SKIPA A13,["*"]
MOVEI A13," " ; SPACE CHAR
PUSHJ SP,OUBYTE
JFCL .+1 ; IGNORE ERRORS
SOJG A1,PMTPR7
HRRZ A1,(A3) ; NOW GET NAME
ADD A1,[
XWD 440600,2] ; MAKE IT A POINTER
PMTPR4: ILDB A13,A1 ; GET CHARACTER
JUMPE A13,PMTPR8 ; NULL MEANS END
ADDI A13,40 ; ASCIFII IT
PUSHJ SP,OUBYTE
JFCL .+1 ; IGNORE ERRORS
JRST PMTPR4
PMTPR8: MOVEI A13," " ; ONE EXTRA SPACE
PUSHJ SP,OUBYTE
JFCL .+1
POPJ SP,
PMCRLF: MOVEI A13,15 ; CR-LF
PUSHJ SP,OUBYTE
JFCL .+1
MOVEI A13,12
PUSHJ SP,OUBYTE
JFCL .+1
POPJ SP,
PRFPR%:
PRFPRT: SKIPN %TRPTR(DB) ; TRACING DONE ?
JRST NOTRACE ; NO - COMPLAIN. CAN'T DO PROFILES
MOVEI A1,PRFMES ; HEADING
PUSHJ SP,MONIT
MOVEI A7,.JBDA ; START OF PROGRAM
MOVNI A6,1
EXCH A6,%CHAN(DB) ; SET O/P = TTY:
PUSH SP,A6
PRFPR1: CAMN A7,%SYS21(DB) ; END OF PROGRAM ? (HEAP ORIGIN)
JRST PRFPR3 ; YES - DONE
HLRZ A0,(A7) ; NO - GET WORD
CAIE A0,(<JSP AX,0>) ; [310] OTS CALL ?
CAIN A0,(<PUSHJ SP,0>) ; [310]
JRST .+2
AOJA A7,PRFPR1 ; NO
HRRZ A0,(A7) ; YES - GET ADDRESS
CAIE A0,%ALGDR+53 ; TRSTD ?
CAIN A0,%ALGDR+52 ; OR TRLAB ?
JRST PRFPR2 ; YES
CAIE A0,%ALGDR+1 ; PARAM ?
CAIN A0,%ALGDR+2 ; OR PAR0 ?
JRST PRFPR2 ; YES
AOJA A7,PRFPR1 ; NO - LOOP
PRFPR2: SKIPN A6,1(A7) ; GET P.M.B. POINTER
AOJA A7,PRFPR1 ; ZERO
; HERE ADD MORE TESTS THAT A6 IS A REAL P.M.B. POINTER
MOVE A0,(A6) ; PROFILE COUNT
PUSHJ SP,IPRINT ; PRINT IT
MOVEI A13," " ; TAB
PUSHJ SP,OUBYTE
JFCL
MOVEI A1,2(A6) ; NAME
HRLI A1,440600 ; BYTE POINTER
PUSHJ SP,PMTPR4 ; PRINT NAME
PUSHJ SP,PMCRLF ; CR-LF
AOJA A7,PRFPR1 ; LOOP
PRFPR3: PUSHJ SP,BRKBYT ; DONE
JFCL
POP SP,%CHAN(DB) ; RESTORE O/P CHANNEL
POPJ SP,
SUBTTL UUO HANDLER
UUO: PORTAL .+1 ; [234] ALLOW FOR EXECUTE-ONLY ENTRY
TLNE DB,INDDT ; IN DEBUGGER ?
JRST UUO9 ; YES - HE TAKES CARE OF HIS OWN AC'S.
DMOVEM A0,%SYS16(DB) ; SAVE A0,A1 IN TEMPORARY DUMP
UUO9: LDB A1,[POINT 9,.JBUUO,8] ; AND GET FUNCTION CODE
CAIL A1,UUONUM ; IN ALGOL UUO RANGE?
JRST ERRUUO ; NO
UUOTAB: JRST @UUOTAB(A1) ; YES - USE TABLE
IFN DUMP, <
XWD 0,DUMP0>
IFE DUMP, <
XWD 0,ERRUUO> ; DUMP
XWD 0,UUO2 ; SYSER1
XWD 0,UUO3 ; SYSER2
XWD 0,UUO4 ; IOERR
XWD 0,UUO5 ; LIBERR
XWD 0,CORE0 ; CCORE
XWD 0,CORE2 ; CCORE1
XWD 0,BREAK% ; DDT BREAKPOINT UUO.
XWD 0,DDTER% ; DDT ERROR UUO.
UUONUM=.-UUOTAB
UUO2:
UUO3:
UUO4:
UUO5: MOVE A1,MUUO(A1) ; LOOK UP MASTER UUO TABLE
LDB A0,[POINT 4,.JBUUO,12] ; GET ACCUMULATOR NUMBER
HRL A0,A0
ADD A1,A0 ; OFFSET BY ERROR NUMBER
JUMPG A1,ERRUUO ; AND CHECK IN RANGE
SKIPA A1,(A1) ; GET FLAGS AND MESSAGE ADDRESS
ERRUUO: MOVE A1,M2+0 ; ILLEGAL UUO'S
ERRMON:
TLNE DB,INDDT ; IN DEBUGGER ?
JRST DDERM% ; YES - LET HIM LOOK AFTER IT.
ERRMNX: EXCH A1,%UUOTM(DB) ; [277] SAVE FLAGS AND ERROR
MOVE A0,%SYS16(DB) ; RESTORE A0,A1
MOVEM A0,%ACCS+A0(DB)
HRLZI A0,A1
HRRI A0,%ACCS+A1(DB)
BLT A0,%ACCS+SP(DB) ; SAVE ACCUMULATORS
PUSHJ SP,BRKBYT ; [274]
JFCL ; [274] IGNORE ERROR RETURN FROM BRKBYT
MOVE A1,%UUOTM(DB) ; [277] RESTORE FLAGS AND ERROR
HLRZ A2,A1
ANDI A2,TRAPNO ; GET TRAP NUMBER
CAIE A2,2 ; FATAL PDL OVERFLOW ?
JRST .+4 ; NO
MOVE SP,%ESP(DB) ; YES - USE EMERGENCY STACK.
SKIPN %DDTST(DB) ; AND TURN OFF DEBUGGER,
HLLOS %DDTST(DB) ; IF NOT ALREADY DONE
ADDI A2,(DB)
SKIPN A1,%TRAPS(A2) ; [206] TRAP SET UP?
JRST .+3 ; [206] NO
SKIPL %UUOTM(DB) ; [277][206] YES -- IS IT FATAL?
JRST ERRM4 ; [206] NO - PROCEED TO TRAP
PUSHJ SP,DCRLF
MOVEI A1,[ASCIZ /?/]
PUSHJ SP,MONIT ; INSERT "?" BEFORE MESSAGE
SKIPL %UUOTM(DB) ; [277] FATAL ERROR?
JRST ERRM1 ; NO
MOVEI A1,M000 ; YES
PUSHJ SP,MONIT ; "FATAL "
ERRM1: MOVEI A1,M001
PUSHJ SP,MONIT ; "RUN-TIME ERROR AT ADDRESS "
HRRZ A1,.JBUUO ; GET ADDRESS IN UUO
HLRZ A0,.JBUUO ; GET UUO
TRZ A0,777 ; GET OPCODE
CAIE A0,(IOERR) ; IOERR OR
SOJG A1,ERRM3 ; [242] JUMP AHEAD IF ADDRESS SUPPLIED
EDIT (242) ; [242] FIX WRONG LINE # PROBLEM WITH ALGDDT
ERRM2: HRRZ A1,-1(SP) ; [242] GET MODIFIED RETURN ADDRESS
SUB A1,%SYS16(DB) ; [242] FIX IT SO IT'S CORRECT AGAIN
SUBI A1,1 ; [242] NOW MOVE BACK TO THE "PUSHJ" INSTR.
ERRM3: HRRZ A0,A1 ; [242] GET CONTEXT ADDRESS
PUSH SP,A0 ; REMEMBER IT
PUSHJ SP,SPROCT ; PRINT ADDRESS OF ERROR
PUSHJ SP,CRLF
HRRZ A1,%UUOTM(DB) ; [277]
PUSHJ SP,MONIT ; PRINT ERROR MESSAGE
HLRZ A0,.JBUUO ; GET UUO
TRZ A0,777 ; GET OPCODE
CAIE A0,(IOERR) ; IOERR ?
JRST ERRM7 ; NO
HRRZ A1,.JBUUO ; YES - EFFECTIVE ADDR IS CHAN #
ADDI A1,(DB) ; RELOCATE
MOVE A4,%UUOTM(DB) ; [277] GET ERROR-MESSAGE FLAGS
SKIPN A3,%IODR(A1) ; GET DIRECTORY ENTRY
JRST ERRM8 ; NOT ALLOCATED
SETZ A6,
TLNN A4,ERRDEV ; TYPE DEVICE-NAME ?
JRST ERRM9 ; NO
TLNN A3,TTYDEV ; YES - TTY ?
SKIPA A5,3(A3) ; NO - GET DEVNAME
MOVE A5,6(A3) ; YES - GET DEVNAME (ALLOW FOR I & O HDRS)
TLNE A3,TTYTTC ; TTY ON TTCALL (CHAN -1) ?
HRLZI A5,(SIXBIT/TTY/) ; YES - SAY SO
JRST ERRM12
ERRM8: LDB A5,[
POINT 4,.JBUUO,12] ; NO DIRECTORY-ENTRY - GET ERROR #
SOJG A5,ERRM10 ; IF IT'S 0 OR 1, IT WAS ERROR IN OPEN
MOVE A5,%SYS10(DB) ; AND OTS LEAVES DEV-NAME HERE
ERRM12: MOVEI A1,A5
PUSHJ SP,MONSIX ; O/P DEVICE NAME
MOVEI A1,[
ASCIZ/:/]
PUSHJ SP,MONIT
ERRM9: TLNE A3,DIRDEV ; DIRECTORY DEVICE ?
TLNN A4,ERRFIL ; YES - TYPE FILE.EXT ?
JRST ERRM10 ; NO
MOVE A5,4(A3) ; GET FILENAME
MOVEI A1,A5
PUSHJ SP,MONSIX ; & TYPE IT
MOVEI A1,[
ASCIZ/./]
PUSHJ SP,MONIT
HLLZ A5,5(A3) ; GET EXTENSION
MOVEI A1,A5 ; *** N.B. A6 = 0 TO STOP MONSIX !! ***
PUSHJ SP,MONSIX ; TYPE EXT
ERRM10: TLNN A4,ERR2PT ; MORE MESSAGE ?
JRST ERRM11 ; NO
HLRZ A1,A4
TRZ A1,FATAL!ERRDEV!ERRFIL!ERR2PT!TRAPNO
; YES - GET OFFSET OF REST OF MSG
LSH A1,-6
ADDI A1,(A4) ; ADD IT TO 1ST PART ADDR
PUSHJ SP,MONIT ; & TYPE
ERRM11: MOVEI A1,[
ASCIZ/ channel # /]
PUSHJ SP,MONIT ; TYPE
HRRE A0,.JBUUO ; GET CHANNEL # - EXTEND SIGN FOR -1 CASE
MOVNI A1,1
EXCH A1,%CHAN(DB) ; SET O/P = TTCALL TTY
PUSHJ SP,IPRINT ; TYPE CHAN #
EXCH A1,%CHAN(DB) ; RESET O/P CHAN #
ERRM7: POP SP,A4 ; RESTORE CONTEXT ADDRESS
PUSHJ SP,DCRLF
PUSH SP,.JBUUO ; DEBUGGER DOES UUO'S!
HRRZ A1,%UUO(DB) ; GET CALLERS PC
MOVEM A1,.JBOPC ; SAVE FOR 'CONTINUE' COMMAND
TLO DB,TMPFL3 ; TELL HSTPRT NOT TO TYPE IF EXPERT.
PUSHJ SP,PR.HST## ; DO HISTORY PRINT.
SETZM .JBINT ; TURN OFF CONTROL-C INTERCEPT
MOVE A1,[-1,,.GTLIM] ; [243] SET UP GETTAB TABLE # FOR OUR JOB
GETTAB A1, ; [243] GET TABLE INFORMATION
LIBERR 5, ; [243] COMPLAIN IF GETTAB FAILS
TLNN A1,JB.LBT ; [243] IS THIS A BATCH JOB?
JRST ERRM7A ; [243] NO, JUMP AHEAD
PUSHJ SP,TRLPRT ; [243] YES
IFN FTADMP,<
SETOM %CHAN(DB) ; SET O/P = TTY:
MOVEI A7,-1 ; SAY "ALL"
TLO DB,INDDT ;
PUSHJ SP,DUMP% ; GIVE ALGOL DUMP.
TLZ DB,INDDT ;
>
JRST INIT5 ;
ERRM7A: POP SP,.JBUUO ; RESTORE UUO OPCODE
JRST %ALGDD ; GO TO DEBUGGER.
STKEXT=10 ;Maximum stack extension
; TRAP RESTART ;[206]
ERRM4: HRRZ AX,(A1) ;[206] GET RESTART LABEL
HLRZ A2,(A1) ;[206] AND ITS PROCEDURE LEVEL + 1
MOVEI A3,(A2) ;[206]
ADDI A3,(A1) ;[206]
MOVEI A3,@(A3) ;[206] GET DL FOR LABEL
MOVEI A13,(A3) ;[206] SAVE COPY FOR GOLAB
EDIT (212);
CAMLE A3,DL ;[212]
JRST ERRM6 ;[212] IF IT IS ABOVE US, IT IS NOT IN SCOPE!
ERRM5: MOVE A4,(A3) ;[206] GET DISPLAY ELEMENT
ADDI A3,1 ;[206]
ADDI A1,1 ;[206]
CAMN A4,(A1) ;[206] OK?
SOJN A2,ERRM5 ;[206] YES - CONTINUE
JUMPN A2,ERRM6 ;[206] MISMATCH
MOVE SP,BLKPTR(DL) ;[206] RESTORE STACK-POINTER
ADDI SP,(DB) ;[206] AND RELOCATE IT
AOJA AX,GOLAB0 ;[206] AND SIMULATE GOTO LABEL
ERRM6: MOVEI A1,MONIT4 ;[206] CRLF
PUSHJ SP,DDTOU% ;[206]
MOVEI A1,[ASCIZ /?/] ;[206]
PUSHJ SP,MONIT ;[206]
MOVE A1,M3+7 ;[206]
PUSHJ SP,MONIT ;[206] "TRAP LABEL OUT OF SCOPE"
PUSHJ SP,DCRLF ;[206]
JRST ERRM1 ;[206]
EDIT(076); FAIL PROPERLY IF CANT GET ENOUGH CORE
CORE0: HRRZ A0,.JBUUO ; EXTEND PROGRAM CORE
CORE A0, ; AND TRY TO GET IT
SYSER1 2,0 ; [E076] FAILED
DMOVE A0,%SYS16(DB) ; OK - RESTORE A0,A1
JRST @%UUO(DB)
CORE2: HRRZ A0,.JBUUO ; SHIFT THE STACK
ADDI A0,STKEXT+1(SP) ; FIND CORE REQUIRED
CAMG A0,.JBREL ; GOT IT?
JRST CORE3 ; YES, JUMP AHEAD
CORE A0, ; NO, OK - TRY TO EXPAND CORE
SYSER1 2,0 ; [E076] YES, ERROR - CAN'T HAVE CORE
CORE3: HLLM DB,%ACCS+DB(DB) ; SAVE DB FLAGS
TLZ DB,777777 ; & CLEAR LEFT HALF
DMOVEM A2,%SYS14(DB)
AOS %SYS20(DB) ; COUNT STACK-SHIFTS
MOVEI A0,STKEXT(SP) ; REMEMBER OLD STACK TOP
HRRZ A1,.JBUUO ; RESTORE SIZE OF SHIFT
HRLI A1,(A1) ; GET IN BOTH HALVES
ADD SP,A1 ; MOVE UP STACK POINTER
MOVEI A2,(SP)
SUB A2,.JBREL
HRLI SP,(A2) ; SET UP LHS
HRLZI A2,(DB) ; REMEMBER OLD DB
ADDI DB,(A1) ; MOVE UP DB
HRRI A2,(DB) ; FORM BLT POINTER
CAIL A0,(DB) ; ONE BLT OK?
JRST CORE5 ; ALAS, NO
BLT A2,STKEXT(SP) ; YES - MOVE IT ALL
CORE4: HRRZ A0,.JBUUO ; RESTORE SHIFT
ADD DL,A0 ; MOVE UP DL
ADDM A0,%TTY+BDDOFF+BYTPTR(DB)
ADDM A0,%IODR-1(DB) ; SHIFT UP CHANNEL -1 TTY
ADDM A0,.JB41 ; SHIFT UP UUO TRAP
ADDM A0,.JBINT ; SHIFT UP CONTROL-C TRAP
ADDM A0,.JBOPS ; SHIFT UP JOBOPS
HRRI A0,%ES-1(DB) ; UPDATE EMERGENCY
HRRM A0,%ESP(DB) ; STACK POINTER
DMOVE A0,%SYS16(DB) ; RESTORE
DMOVE A2,%SYS14(DB) ; ACCS.
HLL DB,%ACCS+DB(DB) ; RESTORE DB FLAG-BITS
JRST @%UUO(DB) ; RETURN
CORE5: MOVEI A2,STKEXT+1(SP)
HRLI A2,(A2)
SUBI A2,(A1)
MOVS A2,A2
SUB A2,A1 ; LOWEST SAFE BLT
MOVEI A3,STKEXT(SP) ; LAST DESTINATION WORD
CORE6: MOVE A0,A2 ; COPY BLT POINTER
BLT A0,(A3) ; AND MOVE A BLOCK
SUB A2,A1 ; MOVE DOWN POINTER
SUBI A3,(A1) ; AND LAST ADDRESS
CAIGE DB,(A2) ; TOO LOW OR HOME?
JRST CORE6 ; NO - KEEP GOING
MOVEI A1,(DB)
SUBI A1,(A2) ; GET DIFFERENCE
HRLI A1,(A1)
ADD A2,A1 ; NO - CORRECT BLT POINTER
BLT A2,(A3) ; LAST BLT
JRST CORE4
SUBTTL ERROR UUO MESSAGES
MUUO=.-2
XWD M2-M3,M2
XWD M3-M4,M3
XWD M4-M5,M4
XWD M5-M6,M5
M2: XWD FATAL+0,M200 ; SYSER1
XWD FATAL+1,M201
XWD FATAL+2,M202
XWD FATAL+3,M203
XWD FATAL+4,M204
XWD FATAL+5,M205
XWD FATAL+6,M206
XWD FATAL+7,M207
XWD FATAL+10,M210
XWD FATAL+11,M211
XWD FATAL+12,M212
XWD FATAL+13,M213
XWD FATAL+14,M214
XWD FATAL+15,M215
XWD FATAL+16,M216
XWD FATAL+17,M217
M3: XWD FATAL+20,M300 ; SYSER2
XWD FATAL+21,M301
XWD 22,M302
XWD 23,M303
XWD FATAL+24,M304
XWD FATAL+25,M305
XWD FATAL+26,M306
XWD FATAL+27,M307
XWD FATAL+30,M310
M4: XWD ERR2PT+ERRDEV+40+<M400A-M400>_6,M400
XWD ERR2PT+ERRDEV+41+<M401A-M401>_6,M401
XWD 42,M402
XWD ERR2PT+ERRDEV+43+<M403A-M403>_6,M403
XWD 44,M404
XWD ERR2PT+ERRDEV+ERRFIL+45+<M405A-M405>_6,M405
XWD ERRDEV+ERRFIL+46,M406
XWD ERRDEV+ERRFIL+47,M407
XWD ERRDEV+ERRFIL+50,M410
XWD ERRDEV+ERRFIL+51,M411
XWD ERRDEV+ERRFIL+52,M412
XWD ERRDEV+ERRFIL+53,M413
XWD 54,M414
IFN FTOVRL,<
XWD 55,M415>
M5: XWD 60,M500 ; LIBERR
XWD 61,M501
XWD 62,M502
XWD 63,M503
XWD 64,M504
XWD 65,M505
XWD FATAL+66,M506
XWD FATAL+67,M507
M6:
M000: ASCIZ /FATAL /
M001: ASCIZ /Run-time error at address /
IFN DUMP,<
M100: ASCIZ /%DUMP COMPLETED/
>
IFE DUMP,<
M100: ASCIZ/?DUMP ROUTINE NOT LOADED
/ >
M200: ASCIZ /ILLEGAL UUO/
M201: ASCIZ /MORE CORE REQUIRED TO START PROGRAM/
M202: ASCIZ /MORE CORE REQUIRED TO CONTINUE PROGRAM/
M203: ASCIZ /LOWER BOUND > UPPER BOUND IN ARRAY DECLARATION/
M204: ASCIZ /ARRAY TOO LARGE FOR A PDP-10/
M205: ASCIZ /WRONG NUMBER OF ARRAY SUBSCRIPTS/
M206: ASCIZ /ARRAY SUBSCRIPT OUT OF RANGE/
M207: ASCIZ /INVALID ACTUAL PARAMETER IN PROCEDURE CALL/
M210: ASCIZ /WRONG NUMBER OF ACTUAL PARAMETERS IN PROCEDURE CALL/
M211: ASCIZ /EXPRESSION-TYPE ACTUAL PARAMETER USED ON LHS OF ASSIGNMENT/
M212: ASCIZ /ATTEMPT TO DELETE NON-EXISTENT BYTE STRING/
M213: ASCIZ //
M214: ASCIZ /BYTESIZE CONFLICTION IN STRING COMPARE/
M215: ASCIZ /ILLEGAL BYTE SIZE/
M216: ASCIZ /BYTE SUBSCRIPT OUT OF RANGE/
M217: ASCIZ /ATTEMPT TO MODIFY STRING CONSTANT/
M300: ASCIZ /SOURCE LEVEL ERROR/
M301: ASCIZ /JUMP TO NON-EXISTENT LABEL/
M302: ASCIZ /FLOATING POINT OVERFLOW/
M303: ASCIZ /FIXED POINT OVERFLOW/
M304: ASCIZ /ILLEGAL INSTRUCTION/
M305: ASCIZ /?ALGIMR ILLEGAL MEMORY REFERENCE/
M306: ASCIZ /UNTRAPPED CLOCK INTERRUPT/
M307: ASCIZ /System Error TRAP - Please submit an SPR/
M310: ASCIZ /OVERLAYS NOT IMPLEMENTED/
M400: ASCIZ /Input or output device /
M400A: ASCIZ / unavailable on/
M401: ASCIZ /Illegal mode for input or output device /
M401A: ASCIZ / on/
M402: ASCIZ /Input or output on undefined/
M403: ASCIZ /Attempt to read or write on directory device /
M403A: ASCIZ / without file open, on/
M404: ASCIZ //
M405: ASCIZ /File /
M405A: ASCIZ / not available or rename failure on/
M406: ASCIZ /Attempt to read or write over end-of-file on /
M407: ASCIZ /Error condition on input or output on /
M410: ASCIZ /Illegal character in numeric data on /
M411: ASCIZ /Overflow in numeric input data on /
M412: ASCIZ /Error condition on closing file /
M413: ASCIZ /Illegal input-output operation on /
M414: ASCIZ /Out of range I-O/
IFN FTOVRL,<
M415: ASCIZ /Attempt to use overlay handler's />
M500: ASCIZ /Undefine operation (SQRT argument negative)/
M501: ASCIZ /Undefined operation (LN argument zero or negative, or 0^0)/
M502: ASCIZ /EXP argument too large/
M503: ASCIZ /Undefined operation (inverse maths function argument out of range)/
M504: ASCIZ /TAN argument too large/
M505: ASCIZ /Monitor call (GETTAB) to get batch job status failed/
M506: ASCIZ /FORTRAN subprogram moved the ALGOL stack/
M507: ASCIZ /Run-time error detected by FORTRAN subprogram/
SUBTTL APR ERROR HANDLER
APRERR: PORTAL .+1 ;[303] HANDLE EXECUTE-ONLY
SKIPN .JBDDT ;[211] COULD THIS BE DDT?
JRST APR16 ;[211] NO, CONTINUE ON
MOVEM A2,%SYS15(DB) ;[211] YES, SAVE A2
HRRZ A2,.JBDDT ;[211] SET UP LOWER BOUND OF DDT
CAILE A2,@.JBTPC ;[211] OVERFLOW INSIDE OF DDT?
JRST [MOVE A2,%SYS15(DB) ;[211] NO, RESTORE A2
JRST APR16] ;[211] AND JOIN MAIN CODE
MOVE A2,.JBTPC ;[211] IT'S DDT, GET RETURN ADDRESS
TLZ A2,440177 ;[211] CLEAR BAD FLAGS
MOVEM A2,.JBBLT ;[211] STORE FOR RETURN
MOVE A2,%SYS15(DB) ;[211] RESTORE A2
JRSTF @.JBBLT ;[211] RETURN TO DDT
APR16: MOVEM A1,%SYS17(DB) ;[211] SAVE A1
JOV .+1 ; [E1013] Clear arithmetic
JFOV .+1 ; [E1013] .. and floating overflow flags.
MOVE A1,.JBTPC ; AND GET PC DUMP
TLZN A1,PCFPU ; FLOATING POINT UNDERFLOW?
JRST APR6 ; NO
TLZ A1,PCOVL ; YES - CLEAR OVERFLOW FLAGS
MOVEM A1,.JBTPC
DMOVEM A2,%SYS15(DB) ; SAVE A2 AND A3
MOVE A2,-1(A1) ; GET MALICIOUS ORDER
APR1: HLRZ A3,A2
LSH A3,-11 ; AND EXTRACT ORDER NO.
CAIE A3,<XCT>B62 ; XCT?
JRST APR2 ; NO
MOVE A1,%SYS17(DB) ; YES
MOVE A3,%SYS16(DB) ; RESTORE A1 AND A3
MOVEM A2,%SYS14(DB) ; SAVE ORDER
MOVE A2,%SYS15(DB) ; RESTORE A2
MOVE A2,@%SYS14(DB) ; AND EXTRACT ORDER XCT'D
JRST APR1
APR2: HLRZ A1,@.JBTPC
LSH A1,-5 ; PICK UP NEXT ORDER
CAIE A1,<JFOVO>B58 ; JFOVO?
JRST APR3 ; NO
AOS .JBTPC ; YES - SKIP IT
HLRZ A1,A2
LSH A1,-5
ANDI A1,000017 ; GET ACCUMULATOR NUMBER
DMOVE A2,%SYS15(DB) ; RESTORE A2 AND A3
CAIN A1,A1 ; A1 INVOLVED?
MOVEI A1,%SYS17(DB) ; YES - REPLACE BY ITS DUMP
MOVEM A1,%SYS14(DB) ; AND SAVE ADDRESS OF ACCUMULATOR
MOVE A1,(A1) ; GET ITS VALUE
HLRE A2,A1 ; GET EXPONENT, EXTENDING SIGN
ASH A2,-11
TSCE A2,A2 ; IF NEGATIVE, COMPLEMENT EXPONENT
TLOA A1,777000 ; NEGATIVE - SET EXPONENT ALL ONES
TLZ A1,777000 ; POSITIVE - SET EXPONENT ALL ZEROS
CAMGE A2,[
XWD 000346,000346] ; WILL ALL OF MANTISSA DISAPPEAR?
TDZA A1,A1 ; YES - SAVE VERY LONG AND SLOW SHIFT!
ASH A1,400000(A2) ; DENORMALIZE FRACTION TO SUIT OLD EXPONENT!!!!!
MOVE A2,%SYS15(DB) ; RESTORE A2 AGAIN
MOVEM A1,@%SYS14(DB) ; AND RESET RELEVANT ACCUMULATOR
MOVE A1,%SYS17(DB) ; RESTORE A1
JRSTF @.JBTPC ; AND RETURN
APR3: HLRZ A1,A2
LSH A1,-5
ANDI A1,000017 ; GET ACCUMULATOR NUMBER
CAIG A3,<DFDV>B62 ; DFAD, DFSB, DFMP OR DFDV?
MOVEI A3,1 ; YES - TREAT AS FADL ETC.
CAIN A3,<FSC>B62 ; FSC?
TDZA A3,A3 ; YES - RECODE
ANDI A3,000007 ; SELECT BOTTOM 3 BITS
HLL A1,APR5(A3) ; CONSTRUCT 1ST ORDER
HRRE A3,APR5(A3)
JUMPGE A3,APR4
MOVE A2,A1 ; LONG ORDER
ADDI A2,1 ; FORM ACC+1
TRZA A2,000020 ; WITH WRAP-AROUND
APR4: DPB A3,[
POINT 9,A2,8] ; CONSTRUCT 2ND ORDER
EXCH A1,%SYS17(DB) ; PLANT ORDERS
EXCH A2,%SYS15(DB) ; RELOAD A1,A2
MOVE A3,%SYS16(DB) ; AND A3
XCT %SYS17(DB)
XCT %SYS15(DB) ; EXECUTE ORDERS
JRSTF @.JBTPC ; AND RETURN
APR5: XWD <SETZM>B53,<CAI>B62
XWD <SETZM>B53,400000
XWD <CAI>B53,<SETZM>B62
XWD <SETZM>B53,<SETZM>B62
XWD <SETZM>B53,<CAI>B62
XWD <SETZM>B53,<CAI>B62
XWD <CAI>B53,<SETZM>B62
XWD <SETZM>B53,<SETZM>B62
APR6: TLNN A1,PCFPO ; FLOATING POINT OVERFLOW?
JRST APR8 ; NO
MOVE A1,(A1) ; PICK UP NEXT ORDER
MOVEM A1,%SYS16(DB) ; AND SAVE IT
LSH A1,-27
ANDI A1,017767
CAIE A1,<JFOV>B58 ; IS IT JFOV OR JFOVO?
JRST APR7 ; NO
MOVE A1,%SYS17(DB) ; YES - RESTORE A1
JRST @%SYS16(DB) ; AND OBEY JFOV
APR7: MOVE A1,%SYS17(DB)
SYSER2 2,@.JBTPC ; YES
JRSTF @.JBTPC ; IN CASE OF CONTINUE.
APR8: TLNN A1,PCO ; FIXED POINT OVERFLOW?
JRST APR10 ; NO
MOVE A1,(A1) ; PICK UP NEXT ORDER
MOVEM A1,%SYS16(DB) ; AND SAVE IT
LSH A1,-27
CAIE A1,<JOV>B58 ; IS IT JOV?
JRST APR9 ; NO
MOVE A1,%SYS17(DB) ; YES - RESTORE A1
JRST @%SYS16(DB) ; AND OBEY JOV
APR9: MOVE A1,%SYS17(DB)
SYSER2 3,@.JBTPC ; YES
JRSTF @.JBTPC ; IN CASE OF CONTINUE.
APR10: MOVE A1,.JBCNI ; GET APR FLAGS
TRNN A1,APRNXM!APRMPV; MEMORY PROTECT VIOLATION?
JRST APR12 ; NO
MOVE A1,%SYS17(DB) ; YES
SYSER2 5,@.JBTPC
APR12: TRNE A1,APRPLO ; PDL OVERFLOW?
JRST APR13 ; YES
MOVE A1,%SYS17(DB)
SYSER2 6,@.JBTPC ; NO - MUST BE CLOCK FLAG
APR13: MOVE A1,.JBREL ; PDL OVERFLOW OR BAD MOVEM ON STACK
CAILE A1,(SP) ; OUT OF CORE?
JRST APR14 ; NO
APR15: ADDI A1,2000
EXCH A1,%SYS17(DB) ; RESTORE SAVED A1
MOVEM DB,%SYS15(DB) ; SAVE DB
TLZ DB,INDDT ; AND TURN OFF "IN DDT" BIT
CCORE @%SYS17(DB) ; TRY TO EXPAND
MOVE DB,%SYS15(DB) ; PICK UP DB AGAIN
APR14: MOVEI A1,(SP)
SUB A1,.JBREL
HRLI SP,(A1) ; RESET LH NEGATIVE COUNT
MOVE A1,%SYS17(DB) ; RESTORE A1
JRSTF @.JBTPC ; AND RE-ENTER PROGRAM
SUBTTL Debugging system - object code dump routine.
; Old DUMPR UUO: give error message.
DUMP0: MOVEI A1,M100
PUSHJ SP,MONIT0 ; TELL HIM NO DUMPS ALLOWED
JRST @%UUO(DB) ; & RETURN
SUBTTL TYPE CONVERSION ROUTINES
; IR INTEGER TO REAL
; ILR INTEGER TO LONG REAL
; RI REAL TO INTEGER
; LRI LONG REAL TO INTEGER
; LRR LONG REAL TO REAL
; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1
; ON EXIT, THE RESULT IS IN A0 OR A0,A1
IR: FLTR A0,A0
JRST CNC.AX
ILR: ASHC A0,-^D35 ; SHIFT VALUE INTO A1
TLC A0,276000 ; SET EXPONENT
DFAD A0,[EXP 0,0] ; ADD 0.0&&0 TO NORMALIZE
JRST CNC.AX
RI: FIXR A0,A0
JRST CNC.AX
EDIT(072); Don't destroy A2 in LRI
LRI: PUSH SP,A2 ; [E072] SAVE A2
DFAD A0,[
EXP 0.5,0.0] ; LRI - ADD 0.5
HLRZ A2,A0
LSH A2,-11
ANDI A2,000377 ; EXTRACT HIGH ORDER EXPONENT
TLZ A0,377000 ; AND CLEAR IT OUT
JUMPGE A0,.+3 ; NUMBER POSITIVE?
TRC A2,000377 ; NO - COMPLEMENT EXTRACTED EXPONENT
TLO A0,377000 ; AND SET ALL ONES
ASHC A0,-233(A2) ; SHIFT MANTISSA TO INTEGER
JOV CNVERR ; [E060] TRAP OVERFLOW
POP SP,A2 ; [E072] RESTORE A2
JRST CNC.AX
EDIT(060); Allow LRI to be followed by a JOV error trap
CNVERR: HLRZ A2,(AX) ; [E060] GET NEXT INSTRUCTION
TRZ A2,37 ; [E060] CLEAR INDEX & INDIRECT
CAIE A2,(JOV) ; [E060] OVERFLOW TRAP ?
SYSER2 3,(AX) ; [E060] NO - CAUSE ERROR
POP SP,A2 ; [E072] YES - RESTORE A2
JRST @(AX) ; [E060] AND TAKE THE TRAP
LRR: JUMPGE A0,LRR2 ; ARGUMENT POSITIVE?
DMOVN A0,A0 ; NO - NEGATE IT
TLZA A1,400000 ; AND CLEAR BIT 0 FLAG
LRR2: TLO A1,400000 ; YES - SET BIT ZERO FLAG
TLNN A1,200000 ; ROUNDING REQUIRED?
JRST LRR3 ; NO
CAMN A0,[
XWD 377777,777777] ; YES - HIGH WORD TOO LARGE?
SYSER2 2,(AX) ; YES - REPORT OVERFLOW
ADDI A0,1 ; NO
TLO A0,400 ; CARRY
LRR3: JUMPL A1,CNC.AX ; EXIT IF POSITIVE
MOVN A0,A0 ; OTHERWISE NEGATE
JRST CNC.AX
SUBTTL SPECIAL TYPE CONVERSION ROUTINES
; SILR INTEGER TO LONG REAL
; SLRI LONG REAL TO INTEGER
; SLRR LONG REAL TO REAL
; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1
; ON EXIT, THE RESULT IS IN A3 OR A3,A4
SILR: MOVE A3,A0 ; COPY ARGUMENT TO A3
ASHC A3,-^D35 ; SHIFT INTO A4
TLC A3,276000 ; SET EXPONENT
DFAD A3,[EXP 0,0] ; ADD ZERO TO NORMALIZE
JRST (AX) ; AND RETURN
SLRI: DMOVE A3,A0 ; COPY ARGUMENT TO A3,A4
DFAD A3,[
EXP 0.5,0.0] ; LRI - ADD 0.5
SLRI2: HLRZ A5,A3
LSH A5,-11
ANDI A5,000377 ; EXTRACT HIGH ORDER EXPONENT
TLZ A3,377000 ; AND CLEAR IT OUT
JUMPGE A3,.+3 ; NUMBER POSITIVE?
TRC A5,000377 ; NO - COMPLEMENT EXTRACTED EXPONENT
TLO A3,377000 ; AND SET ALL ONES
ASHC A3,-233(A5) ; SHIFT MANTISSA TO INTEGER
JRST (AX)
SLRR: DMOVE A3,A0 ; COPY ARGUMENT INTO A0
JUMPGE A3,SLRR2 ; ARGUMENT POSITIVE?
DMOVN A3,A3 ; NO - NEGATE IT
TLZA A4,400000 ; AND CLEAR BIT ZERO FLAG
SLRR2: TLO A4,400000 ; YES - SET BIT ZERO FLAG
TLNN A4,200000 ; ROUNDING REQUIRED?
JRST SLRR3 ; NO
CAMN A3,[
XWD 377777,777777] ; YES - HIGH WORD TOO LARGE?
SYSER2 2,0 ; YES - REPORT OVERFLOW
ADDI A3,1 ; NO
TLO A3,400 ; CARRY
SLRR3: JUMPL A4,(AX) ; EXIT IF POSITIVE
MOVN A3,A3 ; OTHERWISE NEGATE
JRST (AX)
SUBTTL SINGLE PRECISION POWERS OF TEN
STENM1: XWD 175631,463146 ; 1.0&-1
STEN: XWD 201400,000000 ; 1.0
STEN1: XWD 204500,000000 ; 1.0&1
XWD 207620,000000 ; 1.0&2
XWD 212764,000000 ; 1.0&3
XWD 216470,400000 ; 1.0&4
XWD 221606,500000 ; 1.0&5
XWD 224750,220000 ; 1.0&6
XWD 230461,132000 ; 1.0&7
XWD 233575,360400 ; 1.0&8
XWD 236734,654500 ; 1.0&9
XWD 242452,013710 ; 1.0&10
XWD 245564,416672 ; 1.0&11
XWD 250721,522451 ; 1.0&12
XWD 254443,023471 ; 1.0&13
XWD 257553,630410 ; 1.0&14
XWD 262706,576512 ; 1.0&15
XWD 266434,157116 ; 1.0&16
XWD 271543,212741 ; 1.0&17
XWD 274674,055532 ; 1.0&18
XWD 300425,434430 ; 1.0&19
XWD 303532,743536 ; 1.0&20
XWD 306661,534466 ; 1.0&21
XWD 312417,031702 ; 1.0&22
XWD 315522,640262 ; 1.0&23
XWD 320647,410336 ; 1.0&24
XWD 324410,545213 ; 1.0&25
XWD 327512,676456 ; 1.0&26
XWD 332635,456171 ; 1.0&27
XWD 336402,374714 ; 1.0&28
XWD 341503,074077 ; 1.0&29
XWD 344623,713116 ; 1.0&30
XWD 347770,675742 ; 1.0&31
XWD 353473,426555 ; 1.0&32
XWD 356612,334311 ; 1.0&33
XWD 361755,023373 ; 1.0&34
XWD 365464,114135 ; 1.0&35
XWD 370601,137164 ; 1.0&36
XWD 373741,367021 ; 1.0&37
STEN38: XWD 377454,732313 ; 1.0&38
SUBTTL DOUBLE PRECISION POWERS OF TEN
; HIGH ORDER WORDS
HTENM1: XWD 175631,463146 ; 1.0&&-1
HTEN: XWD 201400,000000 ; 1.0
HTEN1: XWD 204500,000000 ; 1.0&&1
XWD 207620,000000 ; 1.0&&2
XWD 212764,000000 ; 1.0&&3
XWD 216470,400000 ; 1.0&&4
XWD 221606,500000 ; 1.0&&5
XWD 224750,220000 ; 1.0&&6
XWD 230461,132000 ; 1.0&&7
XWD 233575,360400 ; 1.0&&8
XWD 236734,654500 ; 1.0&&9
XWD 242452,013710 ; 1.0&&10
XWD 245564,416672 ; 1.0&&11
XWD 250721,522450 ; 1.0&&12
XWD 254443,023471 ; 1.0&&13
XWD 257553,630407 ; 1.0&&14
XWD 262706,576511 ; 1.0&&15
XWD 266434,157115 ; 1.0&&16
XWD 271543,212741 ; 1.0&&17
XWD 274674,055531 ; 1.0&&18
XWD 300425,434430 ; 1.0&&19
XWD 303532,743536 ; 1.0&&20
XWD 306661,534465 ; 1.0&&21
XWD 312417,031701 ; 1.0&&22
XWD 315522,640261 ; 1.0&&23
XWD 320647,410336 ; 1.0&&24
XWD 324410,545213 ; 1.0&&25
XWD 327512,676455 ; 1.0&&26
XWD 332635,456171 ; 1.0&&27
XWD 336402,374713 ; 1.0&&28
XWD 341503,074076 ; 1.0&&29
XWD 344623,713116 ; 1.0&&30
XWD 347770,675742 ; 1.0&&31
XWD 353473,426555 ; 1.0&&32
XWD 356612,334310 ; 1.0&&33
XWD 361755,023372 ; 1.0&&34
XWD 365464,114134 ; 1.0&&35
XWD 370601,137163 ; 1.0&&36
XWD 373741,367020 ; 1.0&&37
HTEN38: XWD 377454,732312 ; 1.0&&38
; KI10 LOW ORDER WORDS
XWD 146314,631464 ; 1.0&&-1
LTEN: XWD 000000,000000 ; 1.0
XWD 000000,000000 ; 1.0&&1
XWD 000000,000000 ; 1.0&&2
XWD 000000,000000 ; 1.0&&3
XWD 000000,000000 ; 1.0&&4
XWD 000000,000000 ; 1.0&&5
XWD 000000,000000 ; 1.0&&6
XWD 000000,000000 ; 1.0&&7
XWD 000000,000000 ; 1.0&&8
XWD 000000,000000 ; 1.0&&9
XWD 000000,000000 ; 1.0&&10
XWD 000000,000000 ; 1.0&&11
XWD 200000,000000 ; 1.0&&12
XWD 120000,000000 ; 1.0&&13
XWD 244000,000000 ; 1.0&&14
XWD 215000,000000 ; 1.0&&15
XWD 370100,000000 ; 1.0&&16
XWD 166120,000000 ; 1.0&&17
XWD 323544,000000 ; 1.0&&18
XWD 044236,400000 ; 1.0&&19
XWD 055306,100000 ; 1.0&&20
XWD 270567,520000 ; 1.0&&21
XWD 223352,622000 ; 1.0&&22
XWD 370245,366400 ; 1.0&&23
XWD 166316,664100 ; 1.0&&24
XWD 012001,220450 ; 1.0&&25
XWD 314401,464562 ; 1.0&&26
XWD 077502,001717 ; 1.0&&27
XWD 307611,201141 ; 1.0&&28
XWD 271553,441371 ; 1.0&&29
XWD 150106,351670 ; 1.0&&30
XWD 002130,044246 ; 1.0&&31
XWD 101267,026547 ; 1.0&&32
XWD 221544,634301 ; 1.0&&33
XWD 266076,003362 ; 1.0&&34
XWD 261646,602127 ; 1.0&&35
XWD 336220,342555 ; 1.0&&36
XWD 325664,433310 ; 1.0&&37
XWD 205520,661075 ; 1.0&&38
END