Trailing-Edge
-
PDP-10 Archives
-
BB-D480F-SB_FORTRAN10_V10
-
forsrt.mac
There are 33 other files named forsrt.mac in the archive. Click here to see a list.
SEARCH MTHPRM,FORPRM
TV SORT - FORTRAN interface to stand-alone SORT, 10(4172)
SUBTTL D.M.NIXON/DMN/DZN/BRF/EGM/BL/RJD/CDM/JLC/AHM 5-Dec-82
;COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1978, 1985
;ALL RIGHTS RESERVED.
;
;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.
CUSTVR==0
DECVER==4
DECMVR==3
DECEVR==10
V%FSRT==:<CUSTVR>B2+<DECVER>B11+<DECMVR>B17+DECEVR
COMMENT \
***** Begin Revision History *****
Creation.
FORSRT released with SORT %4(302).
1 Data pages should contain zero before calling SORT.
2 Use new JSYS name format, NAME%, to avoid symbol name conflicts.
3 Delete edit 1, put code in SORT itself. Improve error message.
4 Add test for execute-only in Release 4.
5 Clean up code to allow SORT-20 to run in a non-zero memory SECTION.
6 More non-zero section code.
Start of incorporation into version 6 of FORTRAN
1367 EGM 26-Mar-81 --------
Add search of FORPRM, and replace old feature test switches
with those from FORPRM.
1555 BL 22-Jul-81
Install DMN version into V6:.
1612 BL 18-Aug-81 Q20-01642
Have SORT put itself into SECTION 0 for now.
2121 RJD 28-Oct-82 20-18131
(Not usable for V7, bugs fixed by edit 3205).
***** Begin Version 7 *****
7 DMN 14-Jan-82
Make non-zero section code work with TOPS-20 Rel. 5.
3076 CDM 1-Apr-82
Do a fixup for character constants as arguements to SORT.
3123 JLC 29-May-82
Mathlib integration.
3124 AHM 1-Jun-82
Add SEGMENT macros so that things go into .CODE. and .DATA.
under FTXLIB.
10 DMN 13-Oct-82
More non-zero section code.
3205 AHM 27-Oct-82
Delete private AC definitions for Tx, Px, etc and use
FORPRM's. Define names for SORT linkage ACs, page boundaries.
Fix PDVOP% jsys call. Make execute-only code paranoid about
RFSTS% failures. Replace $ERROR macro with $FCALL. Add TMA,
CGP, CRP, NSS, CFS, CGS errors. Change module name to FORSRT.
Move %SRTAD to FORINI so that we can toss SORT's section upon
restart. Add FTDEBUG (default off) to turn off of all of the
controversial symbol table swapping code until it is cleaned
up. Don't map up into section 1 unless debugging. Make sure
we have a null lowseg. Redo character arg fixup edit 3076 to
support variable numbers of arguments, one word global byte
pointers and multiple sections of code. Requires edit 476 to
SORT. Call MPG FUNCT. function before getsegging SORT on
both systems and call UPG function after discarding it on
Tops-10 to avoid problem of overlapping the FOROTS heap (same
intent as edit 6(2121)).
3225 JLC 24-Nov-82
Remove local definition of $JCALL, as there is now
one in FORPRM ($FJCAL), and change the calls appropriately.
3232 AHM 5-Dec-82
Fix test for extra args to copy before ARGLOP in Tops-20 code
and NOTCHR in Tops-10 code - MOVNI doesn't sign extend the EA.
3252 JLC 12-Jan-82
Moved KSORT. here.
3253 JLC 13-Jan-83
Set up null version of KSORT. for -10.
***** End V7 Development *****
3362 TGS 28-Oct-83 SPR:20-19293
If the user has called SRTINI (FORMSC subroutine), then SORT's
pages 600:677 have already been preallocated and %PASRT is non-
zero. In this case, for TOPS20 do not try to allocate those pages
again; for TOPS10, don't preallocate pages and don't deallocate
them either after SORT has been called.
3455 ADDITIONAL ARGUMENTS NOT PASSED TO SORT
The extra arguments for SORT calls (like /FATAL) are not
being passed correctly for TOPS-10 calls to SORT.
3463 MRB 14-FEB-84 (RAW PCO)
Fix edit 3455.
***** Begin Version 10 *****
4023 JLC 29-Jun-83
Search MTHPRM also.
4066 JLC 11-Jan-84
Remove FT20UUOS code, as it is done another way.
4106 JLC 2-Mar-84
Change the name of this module, so TRACE can see it.
4012 MRB 14-Jun-84
Have the flagger know about sort and output an error message
when it is called.
4172 MRB 4-Dec-84
Fix-up some flagger stuff for the TOPS-10 version of
SORT.
***** End V10 Development *****
***** End Revision History *****
\
SUBTTL DEFINITIONS -- Assembly Parameters, ACs, etc.
.DIRECTIVE FLBLST
.DIRECTIVE SFCOND
;ACCUMULATOR DEFINITIONS (SORT linkage ACs only)
SF==1 ;[3205] SORT's FUNCT. parameter
SR==4 ;[3205] SORT's return address parameter
;SL==16 ;[3205] SORT's argument list
;EXTENDED ADDRESSING OPCODE DEFINITIONS
ENTRY SORT
EXTERN ABORT.,FUNCT.,%SRTAD
EXTERN %PASRT ;[3362]
SRT1ST==600 ;[3205] First page of SORT
SRTLST==677 ;[3205] Last page of SORT
SRTSIZ==SRTLST-SRT1ST+1 ;[3205] Number of pages in SORT
MAXARG==^D10 ;[3205] Allow a maximum of 10 arguments
IF20,<
IFNDEF FTDEBUG,<FTDEBUG==0> ;[3205] Turn on to insert debug code
> ; End of IF20
SUBTTL TOPS-20 VERSION -- General description
COMMENT \
This routine is built into FORLIB.REL.
When this routine is called for the first time it first looks for
SORT.EXE on SYS: and gives an error if not found.
If it is running in section 0 it then MAPs section 0 and section 1 together.
It then loops through the section table looking for the next free
section above 1.
It then checks if DDT is loaded, if so it MAPs DDT in the current
section into the SORT section.
It then jumps to itself in section 1 and does a GET of SORT into the
SORT section for all pages that exist.
It then uses the SORT entry vector to get the address of the SORT
entry point so that the user call will go directly to SORT.
It looks at .JBSYM in the SORT section to get the symbol table.
If DDT is loaded it then swaps the symbol table pointers and jumps to
the SORT section.
On returning it swaps the symbol table pointers back to point to the
user's code.
If you wish to debug SORT in a non-zero section then there are several
aspects (i.e. deficiencies) of DDT that must be taken into account.
You can not $X an XJRSTF in section 0 and get to a non-zero section.
You remain in section 0. The solution is to put a break point at the
target of the XJRSTF and $P there.
In general you can not $X through or put a break point in the code
that swaps the symbol table pointers. DDT range checks the symbol
table for the section it is in and will zero the pointer if it looks
illegal, which it might well do.
The solution is to put a break point at the target of the XJRSTF (or
somewhere else in the target section) and do a $P from before the code
that swaps the symbol table pointers.
Use of FTDEBUG
Since it is not necessary or nice for FORSRT to always swap symbol
table pointers (consider trying to debug your Fortran program when you
have ^Ced it while running SORT and SORT's symbol table is selected),
FORSRT only contains code to swap pointers when it has been assembled
with the feature test FTDEBUG set to a non-zero value.
Use of %SRTAD
%SRTAD is a two word global PC word.
On the very first call to SORT %SRTAD+1 must be zero.
On subsequent calls %SRTAD+1 contains the PC of SORT.
%SRTAD is zero if SORT is in a non-zero section and -1 if it is in
section 0.
\
SUBTTL TOPS-20 VERSION -- Data
IF20,<
SEGMENT DATA ;[3124] Put into lowseg
SRTDAT:! ;[10] START OF DATA TO CLEAR ON FIRST CALL
SAVEVC: BLOCK 2 ;[10] SAVE USER'S ENTRY VECTOR
RFSBLK: BLOCK .RFSFL+1 ;[3205] ARG BLOCK FOR LONG FORM RFSTS%
;[3205] JSYS - SPACE FOR RETURNED ARGS
STATUS: BLOCK 1 ;[3205] Status word for FUNCT. calls
;[7] CROCK TO SET SYMBOL TABLE FOR SORT IF DDT LOADED SO WE CAN DEBUG IT
IFN FTDEBUG,< ;[3205] Start of debugging variables
DDTPG.==764 ;[10] START OF DDT
CODSYM: BLOCK 1 ;[7] ADDRESS OF CURRENT SYMBOL TABLE
SRTSYM: BLOCK 1 ;[7] ADDRESS OF SORT'S SYMBOL TABLE
> ; End of IFN FTDEBUG
.GFLAG==0 ;[3205] Flag word
.GBASE==3 ;[3205] Offset in GET% arg block which
;[3205] gives the section offset
GETARG: BLOCK .GBASE+1 ;[3205] FLAGS,
;[3205] LOW ADDR,
;[3205] HIGH ADDR,
;[3205] SECTION # OFFSET
;[10] PROGRAM DATA VECTOR
.POLOC==5 ;[10] LOCATE THE SPECIFIED PDV
.POCT1==0 ;[10] NO. OF WORDS IN ARG BLOCK
.POPHD==1 ;[10] PROCESS HANDLE
.POCT2==2 ;[10] NO. OF WORDS IN DATA BLOCK
.PODAT==3 ;[10] ADDRESS OF DATA BLOCK
.PVSTR==2 ;[10] PROGRAM START ADDRESS
.PVSYM==6 ;[10] PROGRAM SYMBOL TABLE
PDVARG: BLOCK .PODAT+1 ;[10] ARG BLOCK FOR PDVOP% JSYS
PDVA: BLOCK 1 ;[3205] LENGTH OF PDV WE WANT
;[10] SYMBOLS NOT IN MONSYM
SM%RWX==:SM%RD!SM%WR!SM%EX ;[10] CONVENIENCE
SRTLEN==.-SRTDAT ;[10] LENGTH OF DATA TO CLEAR
BLOCK 1 ;[3205] Holds argument count
NEWARG: BLOCK 2*MAXARG ;[3205] Holds arguments for SORT call
SUBTTL TOPS-20 VERSION -- SORT/MERGE Entry Point
SEGMENT CODE ;[3124] Put into hiseg
'SORT ' ;SIXBIT NAME FOR TRACE.
SORT:
;
; [4012] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4100]Is any compatbility flagging on?
$FCALL CFX ;[4100]Yes; display the compatibility message
; [3076] If we have a character constant, we must do a fixup to
; [3076] make it into a hollerith constant.
LDB T0,[POINTR (0(L),ARGTYP)] ;[3076] Get argument's type
CAIE T0,TP%CHR ;[3076] Is it character?
JRST NOTCHR ;[3076] No
MOVE T0,@(16) ;[3076] Get byte pointer
LDB T1,[POINT 6,T0,5] ;[3076] Get position of character
CAIE T1,44 ;[3076] At beginning of word?
CAIN T1,61 ;[3205] Or aligned OWGBP?
SKIPA ;[3205] Yes, something worth fixing up
$FCALL AQS,ABORT. ;[3076] Not at beginning, give error
; $FERR (?,AQS,21,112,<First argument to SORT must be a quoted string>) ;[3205]
CAIE T1,44 ;[3205] Local byte pointer ?
TLZA T0,(77B5) ;[3205] No, clear the P&S field
TLZ T0,(<37B5>!<77B11>!<@>) ;[3205] Yes, clear P, S and I fields
;[3205] while leaving the IFIW bit on
XMOVEI T0,@T0 ;[3205] Get the address of the pointer
MOVEM T0,NEWARG+MAXARG ;[3205] Save it in the indirect word
MOVE T0,[IFIW TP%LIT,@NEWARG+MAXARG] ;[3205] Get arg block entry for
MOVEM T0,NEWARG ;[3205] the string arg and store it
MOVE T3,-1(L) ;[3205] Get whole count word
MOVEM T3,NEWARG-1 ;[3205] Save it away in new block
HLRE T3,T3 ;[3205] Get negative of arg count
CAMGE T3,[-MAXARG] ;[3205] More than we have room for?
$FCALL TMA,ABORT. ;[3205] No, complain
; $FERR (?,TMA,21,115,<Too many arguments in call to SORT>) ;[3205]
XMOVEI T1,1(L) ;[3205] Get pointer to rest of old args
XMOVEI T2,NEWARG+1 ;[3205] Point to rest of new block
XMOVEI L,NEWARG ;[3205] Point to new arg block
MOVN T3,T3 ;[3232] Get positive number of args
SOJLE T3,NOTCHR ;[3232] Don't fool around if no extras
XMOVEI T0,0 ;[3205] There are args - where are we?
JUMPE T0,COP0 ;[3205] Section 0 - just use BLT
ARGLOP: XMOVEI T0,@0(T1) ;[3205] Eval this arg's address
MOVEM T0,MAXARG(T2) ;[3205] Store it in an indirect word
LDB T0,[POINTR (0(T1),ARGTYP)] ;[3205] Get the arg's type
LSH T0,^D<18+9> ;[3205] Put it in the AC field
TXO T0,<IFIW @> ;[3205] Make a local indirect word
HRRI T0,MAXARG(T2) ;[3205] Point it to the arg's real addr
MOVEM T0,0(T2) ;[3205] Store the arg word away
ADDI T1,1 ;[3205] Move the source pointer along
ADDI T2,1 ;[3205] Move destination pointer along
SOJG T3,ARGLOP ;[3205] Loop back for more
JRST NOTCHR ;[3205] Finished, join main line
COP0: HRLZ T1,T1 ;[3205] Put BLT source address in LH
HRR T1,T2 ;[3205] Put BLT destination in RH
ADD T2,T3 ;[3205] Compute number of words to move
BLT T1,-1(T2) ;[3205] Move user's other args over
NOTCHR: SKIPE %SRTAD+1 ;[5] CALLED BEFORE?
JRST SORT3 ;[5] YES
MOVE T1,[SRTDAT,,SRTDAT+1] ;[10] BLT PTR
SETZM T1,SRTDAT ;[10] CLEAR FIRST WORD
BLT T1,SRTDAT+SRTLEN-1 ;[10] AND REST
MOVX T1,.FHSLF ;[5] NO, SAVE OUR ENTRY VECTOR
;[2] SINCE GET% JSYS DESTROYS IT
XGVEC% ;[10] INCASE IN NON-ZERO SECTION
ERJMP [MOVX T1,.FHSLF ;[10] NOT REL 5
GEVEC% ;[10] USE OLD SECTION 0 JSYS
ERJMP [SETZB T2,T3 ;[10] ERROR, SET EV TO ZERO
JRST .+1] ;[10]
JRST .+1] ;[10]
DMOVEM T2,SAVEVC ;[10] SAVE BOTH WORDS
MOVEI T1,.RFSFL+1 ;[10] LENGTH OF ARG BLOCK
MOVEM T1,RFSBLK+.RFCNT ;[10] ...
MOVE T1,[RF%LNG!.FHSLF] ;[10] LONG FORM
XMOVEI T2,RFSBLK ;[4] ARG BLOCK
RFSTS% ;[4] GET STATUS
ERJMP SORT1 ;[3205] ASSUME EXECUTE-ONLY
IFGE RF%EXO,<PRINTX ?ERROR - RF%EXO is not the sign bit> ;[4] INCASE IT CHANGES
SKIPGE RFSBLK+.RFSFL ;[4] RF%EXO IS SIGN BIT
SORT1: SKIPA T1,[GJ%OLD!GJ%SHT!GJ%PHY] ;[4] PHYSICAL ONLY IF EXECUTE-ONLY
MOVX T1,GJ%OLD!GJ%SHT ;[4] GET A JFN FOR SORT.EXE
HRROI T2,SRTEXE ; ..
GTJFN% ;[2] ..
$FCALL CFS,ABORT. ;[3205] Complain if we can't find SORT
; $FERR (?,CFS,21,119,<Can't find SYS:SORT.EXE - $J>) ;[3205]
HRRZ P4,T1 ;[5] PUT JFN IN A SAFE PLACE
XMOVEI T1,0 ;[3205] SEE IF WE ARE IN SECTION 0
JUMPN T1,SORT5A ;[3205] NO, DON'T BOTHER WITH SECTION 0
MOVE T1,[.FHSLF,,1] ;[7] SEE IF SECTION 0 AND 1
RSMAP% ;[7] ALREADY MAPPED TOGETHER
ERJMP SORTV4 ;[7] NOT RELEASE 5
;[7] WE ARE RUNNING UNDER RELEASE 5
IFN FTDEBUG,< ;[3205] Get into a non-zero section to
;[3205] hack symbol table pointers
AOJN T1,SORT5A ;[7] ALREADY DONE (T1 NOT = -1)
MOVSI T1,.FHSLF ;[7] THIS FORK IN SECT 0
MOVE T2,[.FHSLF,,1] ;[7] ... IN SECT 1
MOVX T3,SM%RWX+1 ;[10]
SMAP% ;[7] MAP SECTIONS 0 & 1 TOGETHER
$FJCAL IJE,ABORT. ;[3205] Should never fail
> ; End of IFN FTDEBUG
SUBTTL TOPS-20 VERSION -- Release 5
;[10] LOOP THROUGH THE SECTIONS STARTING AT SECTION 1 LOOKING FOR A FREE ONE FOR SORT
SORT5A: SETZ P3, ;[10] NOW FIND A FREE SECTION FOR SORT
SORT5B: AOS T1,P3 ;[7] TRY NEXT ONE
CAILE T1,37 ;[7] MAKE SURE SOME STILL LEFT
$FCALL NSS,ABORT. ;[3205]
; $FERR (?,NSS,21,118,<No free section available for SORT>) ;[3205]
HRLI T1,.FHSLF ;[7]
RSMAP% ;[7]
$FJCAL IJE,ABORT. ;[3205] Should never fail
AOJN T1,SORT5B ;[7] THIS ONE NOT FREE
MOVEM P3,GETARG+.GBASE ;[3205] SAVE SECTION # FOR GET
IFN FTDEBUG,<
MOVE T1,[.FHSLF,,770] ;[7] IS PAGE ACCESSIBLE?
RPACS% ;[7]
$FJCAL IJE,ABORT. ;[3205] Should never fail
AND T2,[PA%RD!PA%EX!PA%PEX] ;[7]
CAME T2,[PA%RD!PA%EX!PA%PEX] ;[7]
JRST SORT5C ;[7] NO DDT
MOVE T1,770000 ;[7] DOES IT CONTAIN DDT?
CAME T1,[JRST 770002] ;[7]
JRST SORT5C ;[7] NO
MOVE T1,[.FHSLF,,DDTPG.] ;[10] SOURCE
MOVE T2,P3 ;[7] GET DESTINATION SECTION #
LSH T2,9 ;[7]
ADD T2,[.FHSLF,,DDTPG.] ;[10] DESTINATION
MOVX T3,PM%CNT!PM%RWX+<777-DDTPG.+1> ;[10] ACCESS INFO
PMAP% ;[7] MAP THE PAGES TOGETHER
$FJCAL IJE,ABORT. ;[3205] Should never fail
MOVE T1,@770001 ;[7] GET CURRENT SYMBOL TABLE POINTER
ERJMP .+2 ;[7] JUST IN CASE NO SYMBOL TABLE
MOVEM T1,CODSYM ;[7] STORE IT AS FLAG THAT DDT LOADED
> ; End of IFN FTDEBUG
;[7] NOW GET SORT INTO THE NON-ZERO SECTION
SORT5C:
IFN FTDEBUG,< ;[3205] Get into a non-zero section to
;[3205] hack symbol table pointers
XMOVEI T1,. ;[10] SEE WHAT SECTION WE ARE IN
TLNN T1,-1 ;[10] IF ALREADY IN NON-ZERO SECTION
;[10] STAY THERE,
;[10] ELSE JUMP TO SECTION 1
XJRSTF [0 ;[7] NOTE THAT YOU CANNOT $X THIS
1,,.+1] ;[7] INSTRUCTION. PUT A BREAKPOINT
SORT5D: ;[7] AT SORT5D AND $P INSTEAD
> ; End of IFN FTDEBUG
HRLZ P3,P3 ;[7] PUT SECTION # IN GLOBAL SIDE
HRRZ T1,P4 ;[3205] GET JFN
TXO T1,<<.FHSLF_^D18>!GT%PRL!GT%ARG> ;[3205] PRE-LOAD ALL OF FILE
MOVX T2,GT%BAS ;[3205] SORT's "/USE-SECTION" offset
MOVEM T2,GETARG+.GFLAG ;[10] ...
XMOVEI T2,GETARG ;[7] POINT TO ARG BLOCK
GET% ;[7]
$FJCAL CGS,ABORT. ;[3205]
; $FERR (?,CGS,21,120,<Can't get SYS:SORT.EXE - $J>) ;[3205]
;[10] GET SORT'S PROGRAM DATA VECTOR
MOVE T1,[PDVDAT,,PDVARG] ;[10] SET UP ARG BLOCK
BLT T1,PDVARG+.PODAT ;[10] ...
MOVEI T1,.POLOC ;[10] LOCATE
XMOVEI T2,PDVARG ;[3205] ARG BLOCK
HRROI T3,[ASCIZ /SORT/] ;[10] PDV NAME
PDVOP% ;[10]
ERJMP SORT5E ;[10] FAILED, USE ENTRY VECTOR
SKIPE T1,PDVARG+.POCT2 ;[3205] At least one PDV
TLNE T1,^-<1> ;[3205] But no more than one?
JRST SORT5E ;[3205] No - old version of SORT or
;[3205] confused user - ignore it
MOVE P1,PDVA ;[3205] Point to the PDV
MOVE T1,[.PVSTR(P1)] ;[3205] Start address word
PUSHJ P,S1MOVE ;[3205] Fetch it
HLL T1,P3 ;[3205] ADD IN SORT SECTION
MOVEM T1,%SRTAD+1 ;[10]
IFN FTDEBUG,<
MOVE T1,.PVSYM(P1) ;[3205] GET SYMBOL TABLE POINTER
>
JRST SORT5F ;[10] JOIN COMMON CODE
;[10] HERE WHEN PDV CANNOT BE FOUND
SORT5E: MOVEI T1,.FHSLF ;[10] GET SORT'S ENTRY VECTOR
XGVEC% ;[10] ..
$FJCAL IJE,ABORT. ;[3205] Should never fail
HRR P3,T3 ;[10] POINT TO SORT ENTRY VECTOR
MOVE T1,[3(P3)] ;[3205] Point into entry vector
PUSHJ P,S1MOVE ;[3205] Get the word into T1
HRR P3,T1 ;[3205] Get addr of start address
MOVEM P3,%SRTAD+1 ;[3205] Save SORT's entry point
;[7] HERE WHEN SORT IS READ IN
IFN FTDEBUG,<
MOVEI T1,.JBSYM## ;[7] POINT TO SYMBOL TABLE
HLL T1,P3 ;[3205] IN SORT SECTION
SORT5F: MOVE T1,(T1) ;[3205] GET POINTER
SKIPN CODSYM ;[7] IS DDT LOADED?
SETZ T1, ;[7] NO, DON'T SAVE SYMBOL POINTER
MOVEM T1,SRTSYM ;[7] SAVE ADDRESS OF SORT'S SYMBOL TABLE
SKIPE CODSYM ;[7] IS DDT LOADED?
MOVEM T1,@770001 ;[7] YES STORE NEW SYMBOL TABLE
> ; End of IFN FTDEBUG
IFE FTDEBUG,<
SORT5F:
>
MOVEI T1,.FHSLF
DMOVE T2,SAVEVC ;[10] RESTORE USER'S ENTRY VECTOR
XSVEC% ;[10] ..
$FJCAL IJE,ABORT. ;[3205] Should never fail
SETZ SF, ;[3205] FUNCT. not required
XMOVEI SR,SORT4 ;[3205] Set return address
XJRSTF %SRTAD ;[7] CALL SORT TO DO THE REAL WORK
;Enter here if not first call to SORT
SORT3:
IFN FTDEBUG,<
SKIPN CODSYM ;[10] DO WE HAVE TO WORRY ABOUT SYMBOL TABLES?
JRST SORT3A ;[10] NO
MOVE T1,@770001 ;[10] YES, GET CURRENT SYMBOL TABLE POINTER
MOVEM T1,CODSYM ;[10] IN CASE USER HAS DEFINED SOME NEW SYMBOLS
SORT3A: SKIPE T1,SRTSYM ;[7] DO WE NEED TO SET UP SYMBOL TABLE POINTER?
MOVEM T1,@770001 ;[7] YES, SO WE CAN DEBUG SORT
> ; End of IFN FTDEBUG
IFE FTDEBUG,<
SORT3A:
>
XMOVEI SF,FUNCT. ;[3205] TELL SORT WHERE FUNCT. IS
;[3205] (Assume it needs it)
XMOVEI SR,SORT4 ;[3205] Give return address
SKIPE %SRTAD ;[5] CALL SORT TO DO THE REAL WORK
JRST @%SRTAD+1 ;[5] ..
SETZ SF, ;[3205] SORT in own section, no FUNCT.
XJRSTF %SRTAD ;[5] ..
;[7] Return from SORT to original section
SORT4: JRST SORT4E ;[7] ERROR RETURN
IFN FTDEBUG,<
SKIPE T1,CODSYM ;[7] DO WE NEED TO RESTORE POINTER
MOVEM T1,@770001 ;[7] YES
> ; End of IFN FTDEBUG
POPJ P, ;[7] RETURN TO CALLER
SORT4E:
IFN FTDEBUG,<
SKIPE T1,CODSYM ;[7] DO WE NEED TO RESTORE POINTER
MOVEM T1,@770001 ;[7] YES
> ; End of IFN FTDEBUG
XMOVEI L,1+[XWD 0,0] ;[10] FAILED, CALL EXIT.
PUSHJ P,EXIT.## ;[5]
POPJ P, ;[5] CONTINUED?????
;[3205] Routine to fetch words from a non-zero section
; Calling sequence:
; T1/ I, X and Y field of IFIW to fetch with
; PUSHJ P,S1MOVE
; Return, always, T1/ contents of word addressed by the indirect pointer arg
; Destroys T1-T4
S1MOVE:
IFE FTDEBUG,<
TXO T1,<MOVE T1,0> ;[3205] Instruction to fetch data
MOVE T2,[XJRSTF T3] ;[3205] Return to section 0
SETZ T3, ;[3205] Who needs flags, anyway
XMOVEI T4,S1RET ;[3205] Our return PC
XJRSTF [0 ;[3205] Jump into the section 1 ACs
1,,T1] ;[3205] to fetch data
S1RET: POPJ P, ;[3205] Return to caller
> ; End of IFE FTDEBUG
IFN FTDEBUG,<
TXO T1,<IFIW> ;[3205] Make address into a true IFIW
MOVE T1,@T1 ;[3205] Fetch the data
POPJ P, ;[3205] Return to caller
> ; End of IFN FTDEBUG
SUBTTL TOPS-20 VERSION -- Release 4
SORTV4: SETOM %SRTAD ;[10] REMEMBER FAILURE TO GET
;[10] NON-ZERO SECTION
;[3205] Reclaim as many pages from the heap manager as possible
FUNCT (FUNCT.,<[FN%CBC],[ASCIZ |SRT|],STATUS>)
;[3205] Try and steal pages 600:677
SKIPE %PASRT ;[3362]Already prealloc by FOROP. call?
JRST SRTGET ;[3362] Yes, don't try again!
FUNCT (FUNCT.,<[FN%MPG],[ASCIZ |SRT|],STATUS,[SRT1ST],[SRTSIZ]>)
SKIPE STATUS ;[3205] Can we have them ?
$FCALL CGP,ABORT. ;[3205] No, complain
; $FERR (?,CGP,21,116,<Can't get pages 600:677 for SORT>) ;[3205]
SRTGET: HRLI T1,.FHSLF ;[3362][5] DO A GET% ON SORT.EXE
HRR T1,P4 ;[5] GET JFN
TXO T1,GT%ADR!GT%PRL ;[3205] Obey page limits, preload pages
MOVE T2,[SRT1ST,,SRTLST] ;[10] ALL OF SORT'S HIGH SEGMENT
GET% ;[5]
$FJCAL CGS,ABORT. ;[3205]
; $FERR (?,CGS,21,120,<Can't get SYS:SORT.EXE - $J>) ;[3205]
MOVEI T1,.FHSLF ;[5] GET SORT'S ENTRY VECTOR
GEVEC% ;[5] ..
$FJCAL IJE,ABORT. ;[3205] Should never fail
HRRZ P3,T2 ;[5] CALCULATE SORT ENTRY POINT
HRR P3,3(P3) ;[5] ..
MOVEM P3,%SRTAD+1 ;[5] SAVE SORTS ADDRESS
DMOVE T2,SAVEVC ;[3205] RESTORE USER'S ENTRY VECTOR
SEVEC% ;[2] ..
$FJCAL IJE,ABORT. ;[3205] Should never fail
JRST SORT3A ;[10] JOIN MAIN LINE CODE
SRTEXE: ASCIZ /SYS:SORT.EXE/ ;[2] NAME TO DO A GET% JSYS ON
PDVDAT: EXP .PODAT+1 ;[10] DON'T SUPPLY MEMORY RANGES
EXP .FHSLF ;[10] THIS FORK
EXP .PVSYM+1 ;[10] NO. OF WORDS WE WANT RETURNED
EXP PDVA ;[10] WHERE TO RETURN THE DATA
>;END IF20
SUBTTL TOPS-10 VERSION - Data
IF10,<
SEGMENT DATA ;[3124] Put in lowseg
SRTBLK: BLOCK 6 ;[3205] Leave room for MERGE. arg block
SAVEL: BLOCK 1 ;[5] SAVE AC L DURING MERGE. UUO
SAVEP: BLOCK 1 ;[5] SAVE AC P DURING MERGE. UUO
BLOCK 1 ;[3205] Holds argument count
NEWARG: BLOCK MAXARG ;[3205] Holds arguments for SORT call
STATUS: BLOCK 1 ;[3205] Status word for FUNCT. calls
SUBTTL TOPS-10 VERSION -- SORT/MERGE Entry Point
SEGMENT CODE ;[3124] Put in hiseg
'SORT ' ;NAME FOR TRACE.
SORT:
;
; [4172] Check for compatibility flagging.
;
SKIPE [FLGON.##] ;[4172]Is any compatbility flagging on?
$FCALL CFX ;[4172]Yes; display the compatibility message
; [3076] If we have a character constant, we must do a fixup to
; [3076] make it into a hollerith constant.
LDB T0,[POINTR (0(L),ARGTYP)] ;[3076] Get argument's type
CAIE T0,TP%CHR ;[3076] Is it character?
JRST NOTCHR ;[3076] No
MOVE T0,@(16) ;[3076] Get byte pointer
LDB T1,[POINT 6,T0,5] ;[3076] Get position of character
CAIE T1,44 ;[3076] At begining of word?
$FCALL AQS,ABORT. ;[3076] Not at beginning, give error
; $FERR (?,AQS,21,112,<First argument to SORT must be a quoted string>) ;[3205]
TLZ T0,(<37B5>!<77B11>!<@>) ;[3205] Clear P, S and I fields
;[3205] while leaving the IFIW bit on
XMOVEI T0,@T0 ;[3205] Get the address of the pointer
HRLI T0,(IFIW TP%LIT,0) ;[3205] Get arg block entry for
MOVEM T0,NEWARG ;[3205] the string arg and store it
MOVE T3,-1(L) ;[3205] Get whole count word
MOVEM T3,NEWARG-1 ;[3205] Save it away in new block
HLRE T3,T3 ;[3455] Get negative of arg count
CAMGE T3,[-MAXARG] ;[3205] More than we have room for?
$FCALL TMA,ABORT. ;[3205] No, complain
; $FERR (?,TMA,21,115,<Too many arguments in call to SORT>) ;[3205]
MOVN T3,T3 ;[3232] Get number of extra args
SOJLE T3,ONEARG ;[3463] Don't fool around if no extras
MOVSI T1,1(L) ;[3205] Put BLT source address in LH
HRRI T1,NEWARG+1 ;[3205] Put BLT destination in RH
BLT T1,NEWARG(T3) ;[3205] Move user's other args over
ONEARG: XMOVEI L,NEWARG ;[3463] Point to new arg block
NOTCHR: DMOVEM L,SAVEL ;[5] SAVE AC L AND P
;[3205] Reclaim as many pages from the heap manager as possible so
;[3205] that there is a greater chance of marking all of the pages
;[3205] SORT will need, and so that there is more lowseg space for
;[3205] SORT to use for buffers.
FUNCT (FUNCT.,<[FN%CBC],[ASCIZ |SRT|],STATUS>)
;[3205] Try and steal pages 600:677
SKIPE %PASRT ;[3362] Already alloc by FOROP. call?
JRST SRTMRG ;[3362] Yes, don't try again.
FUNCT (FUNCT.,<[FN%MPG],[ASCIZ |SRT|],STATUS,[SRT1ST],[SRTSIZ]>)
SKIPE STATUS ;[3205] Can we have them ?
$FCALL CGP,ABORT. ;[3205] No, complain
; $FERR (?,CGP,21,116,<Can't get pages 600:677 for SORT>) ;[3205]
SRTMRG: MOVE T1,[SRTEXE,,SRTBLK] ;[3362][3205]Point from hiseg to lowseg
BLT T1,SRTBLK+SRTEXL-1 ;[3205] Move the block downstairs
MOVEI T1,SRTBLK ;[5] MERGE IN SORT
MERGE. T1, ;[5] ..
HALT ABORT. ;[3205] Failed, complain
DMOVE L,SAVEL ;[5] RETORE AC L AND P
MOVEI SF,FUNCT. ;[5] TELL SORT WHERE FUNCT. IS
MOVEI SR,SORT1 ;[3205] CALL SORT TO DO THE REAL WORK
HRRZ P2,600000+.JBHSA## ;[5] ..
JRST 2(P2) ;[3205] ..
SORT1: JRST [MOVEI L,1+[XWD 0,0] ;[5] FAILED, CALL EXIT.
PUSHJ P,EXIT.## ;[5]
JRST .+1] ;[5] CONTINUED?????
MOVEI T1,SRTSIZ ;[5] OK, GET PAGE COUNT
MOVEI T2,1 ;[5] SETUP PAGE. UUO
MOVE T3,[PA.GAF+SRT1ST] ;[5] ..
SORT2: MOVE T4,[.PAGCD,,T2] ;[5] DESTROY A PAGE
PAGE. T4, ;[5] ..
JFCL ;[5] FAILED
ADDI T3,1 ;[5] LOOP
SOJG T1,SORT2 ;[5] ..
;[3205] Try and return pages 600:677
SKIPE %PASRT ;[3362] FOROP. preallocated?
POPJ P, ;[3362] Yes, don't deallocate either
FUNCT (FUNCT.,<[FN%UPG],[ASCIZ |SRT|],STATUS,[SRT1ST],[SRTSIZ]>)
SKIPE STATUS ;[3205] Can we return them ?
$FCALL CRP,ABORT. ;[3205] No, can't return pages
; $FERR (?,CRP,21,117,<Can't return pages 600:677 after call to SORT>)
;[3205] Get rid of extra pages from the core image
FUNCT (FUNCT.,<[FN%CBC],[ASCIZ |SRT|],STATUS>)
POPJ P, ;[3205] AND RETURN TO CALLER
SUBTTL TOPS-10 VERSION -- Error Messages
SRTEXE: SIXBIT /SYS/ ;[5] MERGE. UUO ARGUMENT BLOCK
SIXBIT /FSORT/ ;[5] ..
0 ;[5] ..
0 ;[5] ..
0 ;[5] ..
XWD SRT1ST,SRTLST ;[3205] Undocumented "range" arg ?!?
SRTEXL==.-SRTEXE ;[3205] Length of block to move
>;END IF10
XLIST
LIT
LIST
PRGEND
SEARCH MTHPRM
TV KSORT KILL VESTIGES OF SORT
ENTRY KSORT.
INTERN %SRTAD
INTERN %PASRT ;[3362]
; Here we have a hook into FORSRT and SORT. %SRTAD is a flag/PC
; doubleword which points to SORT's start address, if present. If
; %SRTAD+1 is non-zero, it is the start address of SORT. If %SRTAD is
; zero, then %SRTAD%+1 is a 30 bit PC, and SORT is in some non-zero
; section. If %SRTAD is non-zero, then %SRTAD+1 is an 18 bit PC and
; SORT is in section 0.
; To insure that programs that use SORT restart properly, we reset the
; state of FORSRT and SORT. This means that if SORT is in its own
; section (first word 0, second word non-zero), we destroy the section
; SORT is in (section number is in left half of second word). And, in
; order to make sure that a fresh copy of SORT is GET%ed upon
; restarting Fortran programs, we zero out the address in the second
; word so that FORSRT thinks it does not exist at all.
; Added by edit 3205
SEGMENT CODE
IF20,<
KSORT.: SKIPN %SRTAD+1 ;[3205] Is there a SORT anywhere?
POPJ P, ;[3205] No, return
SKIPE %SRTAD ;[3205] Is SORT in another section?
JRST SRTZER ;[3205] No, go zero out the pointer
MOVNI T1,1 ;[3205] -1 means destroy mapping
MOVSI T2,.FHSLF ;[3205] The mapping is in our fork
HLR T2,%SRTAD+1 ;[3205] Get section # from SORT's start address
MOVEI T3,1 ;[3205] Unmap exactly one section
SMAP% ;[3205] Ask Tops-20, it knows how
SETZM %SRTAD ;[3205] Erase all traces of
SRTZER: SETZM %SRTAD+1 ;[3205] SORT's existance
POPJ P, ;[3205] Go initialize some more
> ; End of IF20
IF10,<
KSORT.: SETZM %SRTAD ;ERASE SORT FROM MEMORY
SETZM %SRTAD+1
POPJ P,
> ;END IF10
SEGMENT DATA
%SRTAD: BLOCK 2 ;[3205] Flag/PC doubleword for SORT (if FORSRT
;[3205] is loaded, and SORT.EXE is GET%ed)
%PASRT: BLOCK 1 ;[3362] Nonzero'd by FOROP. call if FO$SRT has
;[3362] already preallocated SORT pages.
XLIST
LIT
LIST
END