Trailing-Edge
-
PDP-10 Archives
-
ALGOL-20_1-29-82
-
algol-sources/algots.mac
Click algol-sources/algots.mac to
see without markup as text/plain
There are 5 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 A