TITLE	PASSRT - PASCAL INTERFACE TO STAND-ALONE SORT

;To use this, simply include the following declaration in your
;Pascal program:
;  procedure sort(s:string);extern;
;then call it, passing the same argument that you would pass to
;sort if you were using it standalone.  SORT plays with the
;interrupt system.  If you are doing interrupt handling, you
;should disable user interrupts during SORT.  While SORT is
;running, you do not have a valid Pascal context.
;SORT is now native-mode, so using this routine does not
;invoke the emulator.

;Although this code is modelled after the Fortran/SORT interface,
;it is independent of that interface, and does not invoke Fortran.

;FEATURE TEST SWITCHES
;FTOPS20		;TOPS-20 VERSION

;NOTE - Tops10 version is not yet supported.  (It will be if someone
;  will give me access to a Tops-10 system with SORT on it.)

IFNDEF FTOPS20,<FTOPS20==1>

IFN FTOPS20,<SEARCH	MACSYM,MONSYM,PASUNV>
IFE FTOPS20,<SEARCH	MACTEN,UUOSYM,PASUNV>

;ACCUMULATOR DEFINITIONS (SAME AS SRTPRM)

T1=1
T2=2
T3=3
T4=4
P1=5
L=16
P=17

ENTRY	SORT
SUBTTL	DEFINITIONS -- Typeout Macros


DEFINE TYPE(MESSAGE)<
  IFE FTOPS20,<
    OUTSTR [ASCIZ \MESSAGE\]
  >
  IFN FTOPS20,<
    HRROI T1,[ASCIZ \MESSAGE\]
;;*;[2] Replace in TYPE macro	DZN	9-Nov-78
    PSOUT%				;;[2]
  >
>

DEFINE TYPEC(ACC)<
  IFE FTOPS20,<
    OUTCHR ACC
  >
  IFN FTOPS20,<
    IFN <ACC>-T1,<
      HRRZ T1,ACC
    >
    PBOUT
  >
>

DEFINE $ERROR(Q,CODE,TEXT,MORE)<
E$$'CODE:
  IFB <MORE>,<
    TYPE <Q'SRT'CODE TEXT
>
  >
  IFNB <MORE>,<
    TYPE <Q'SRT'CODE TEXT>
  >
  IFIDN <Q'MORE><?>,<
    JRST DIE
  >
>
SUBTTL	TOPS-20 VERSION -- Data


IFN FTOPS20,<
ACS15:	BLOCK	1			;PLACE TO SAVE GLOBAL PASCAL AC
ACS16:	BLOCK	1
PASFF:	BLOCK	1			;place to save jbff
INTSAV:	BLOCK	1			;place to save interrupt status
ONCE:	BLOCK	1			;flag so we do DIC once only

SRTEXE:	ASCIZ	/SYS:SORT.EXE/		;[2] NAME TO DO A GET% JSYS ON

SAVEVC:	BLOCK	1			;SAVE USER'S ENTRY VECTOR

RFSBLK:	EXP	.RFSFL+1		;[4] ARG BLOCK FOR LONG FORM RFSTS% JSYS
	BLOCK	.RFSFL			;[4] SPACE FOR RETURNED ARGS

;arg to SORT
	XWD -1,0			;number of args
SRTARG:	EXP 17B12			;ASCIZ

ARGBLK:	EXP	SRTARG			;addr of arg to SORT
	JRST	FUNCT.			;PASS THESE PASCAL ROUTINES
	JRST	QUIT##			;  TO SORT
SUBTTL	TOPS-20 VERSION -- SORT/MERGE Entry Point

	'SORT  '			;SIXBIT NAME FOR TRACE.
SORT:	MOVEM	15,ACS15		;save Pascal global AC's
	MOVEM	16,ACS16
	MOVE	T1,.JBFF		;SAVE ORIGINAL .JBFF
	MOVEM	T1,PASFF
	HRRM	T1,SRTARG		;AND USE AS ARG TO SORT
	HRLI	T2,440700		;T2 - BYTE PTR TO STRING ARG
	MOVE	T4,.JBFF
	HRLI	T4,440700		;T4 - BYTE PTR TO COPY AT .JBFF
ARGCP1:	SOJL	T3,ARGCP2		;DONE IF COUNT EXHAUSTED
	ILDB	T1,T2			;COPY CHAR
	JUMPE	T1,ARGCP1		;IGNORE NULLS
	IDPB	T1,T4
	JRST	ARGCP1
ARGCP2:	SETZ	T1,
	IDPB	T1,T4			;MAKE ASCIZ
	MOVEI	T4,1(T4)		;NEXT WORD IN DEST AREA
	MOVEM	T4,.JBFF		;NEW .JBFF
	MOVX	T1,.FHSLF		;SAVE OUR ENTRY VECTOR
	GEVEC%				;[2]   SINCE GET% JSYS DESTROYS IT
	MOVEM	T2,SAVEVC		;  ..
	MOVX	T1,.FHSLF		;GET OUR INTERRUPT STATUS
	RCM
	MOVEM	T1,INTSAV		;SAVE IT
	SETZM	ONCE			;SET FLAG SO WE CAN TELL FIRST TIME
	MOVX	T1,RF%LNG!.FHSLF	;[4] LONG FORM FOR THIS PROCESS
	MOVEI	T2,RFSBLK		;[4] ARG BLOCK
	SETZM	RFSBLK+.RFSFL		;[4] MAKE SURE ITS CLEAR INCASE REL 3
	RFSTS%				;[4] GET STATUS
	  ERJMP	SORT1			;[4] ASSUME NOT 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
	SKIPA	T1,[GJ%OLD!GJ%SHT!GJ%PHY]	;[4] PHYSICAL ONLY IF EXECUTE-ONLY
SORT1:	MOVX	T1,GJ%OLD!GJ%SHT	;[4] GET A JFN FOR SORT.EXE
	HRROI	T2,SRTEXE		;  ..
	GTJFN%				;[2]   ..
	  ERJMP	E$$CFS			;COMPLAIN IF WE CAN'T FIND SORT
	HRLI	T1,.FHSLF		;[2] DO A GET% ON SORT.EXE
	TXO	T1,GT%ADR		;CHECK ADDRESS LIMITS
	MOVE	T2,[600,,677]		;ALL OF HIGH SEGMENT
	GET%				;[2]
	MOVX	T1,.FHSLF		;GET SORT'S ENTRY VECTOR
	GEVEC%				;[2]   TO MAKE SURE IT'S THE NEW SORT
	MOVE	P1,T2			;PUT ENTRY VECTOR IN SAFE PLACE
	MOVE	T2,SAVEVC		;RESTORE USER'S ENTRY VECTOR
	SEVEC%				;[2]   ..
	HLRZ	T1,P1			;GET 'LENGTH' OF SORT'S ENTRY VECTOR
	CAIN	T1,<JRST>_<-^D18>	;LOOK LIKE A JRST (I.E., TOPS-10 STYLE)?
	JRST	E$$SV4			;[3] YES--MUST BE OLDER THAN RELEASE 4
	MOVE	P1,3(P1)		;GET USER ENTRY LIST IN SAFE PLACE
	MOVEI	L,ARGBLK		;POINT TO IT
	PUSHJ	P,0(P1)			;CALL SORT TO DO THE REAL WORK
	MOVE	T1,PASFF		;RESTORE .JBFF
	MOVEM	T1,.JBFF
	MOVX	T1,.FHSLF		;PAGE EVERYTHING OUT SO
	RWSET%				;[2]   SORT GETS REMOVED FROM WORKING SET
	MOVX	T1,.FHSLF		;RESET INTERRUPTS
	MOVE	T2,INTSAV
	AIC
	MOVE	15,ACS15		;RESTORE GLOBAL AC
	MOVE	16,ACS16
	POPJ	P,			;RETURN TO CALLER
SUBTTL	TOPS-20 VERSION -- Error Messages

E$$SV4:	$ERROR	(?,SV4,<SORT version 4 or later required.>)

E$$CFS:	SKIPL	RFSBLK+.RFSFL		;[4] EXECUTE-ONLY?
	JRST	E$CFS1			;[4] NO, USE OLD MESSAGE
	$ERROR	(?,XGF,<Execute-only GTJFN% failed for  >,+)	;[4]
	JRST	E$CFS2			;[4] REST OF MESSAGE

E$CFS1:	$ERROR	(?,GFS,<GTJFN% failed for  >,+)	;[4]
E$CFS2:	HRROI	T1,SRTEXE		;[4] TYPE WHAT WE COULDN'T FIND
	PSOUT%				;[2]   ..
	TYPE	<, >			;  FOLLOWED BY WHY (LAST PROCESS ERROR)
PRCERR:	MOVX	T1,.PRIOU		;TYPE LAST PROCESS ERROR
	MOVX	T2,<.FHSLF,,-1>		;  ..
	SETZ	T3,			;  ..
	ERSTR%				;[2]   ..
	  ERJMP	.+2			;IGNORE ERRORS AT THIS POINT
	  ERJMP	.+1			;  ..
	TYPE	<.
>
DIE:	HALTF%				;[2] STOP THE JOB
	JRST	SORT			;IN CASE USER FIXED THINGS

funct.:	move t1,@(l)		;function code
	cail t1,0
	caile t1,maxfun
	jrst unimp
	jrst @fundsp(t1)	;go to routine

fundsp:	unimp			;ill
	unimp			;gad
	getcor			;cor
	retcor			;rad
	unimp			;gch
	unimp			;rch
	getcor			;got
	retcor			;rot
	unimp			;rnt
	unimp			;ifs
	retok			;cbc
	unimp			;rrs
	unimp			;wrs
maxfun=.-fundsp-1

unimp:	setom @2(l)		;status
	setzm @1(l)		;error code
	popj p,

getcor:	skipn once		;first time only
	pushj p,dodis
	move t1,@4(l)		;arg 2 = size
	move t2,.jbff##		;start at .jbff
	addb t1,.jbff		;update .jbff
	caml t1,lstnew##	;overlap heap?
	jrst errnec		;not enough core
	movem t2,@3(l)		;return address of block
retok:	setzm @2(l)		;ok status
	setzm @1(l)		;no error code
	popj p,

dodis:	setom once		;do this only once
	movei t1,.fhslf		;clear nxm interrupts
	movei t2,1B22
	dic
	popj p,

retcor:	move t1,@3(l)		;arg 1 = addr
	move t2,@4(l)		;arg 2 = size
	add t2,t1		;t2 - end of block
	camge t2,.jbff		;if anything after it
	jrst retok		;can't do anything - say we did it
	movem t1,.jbff		;return it - move .jbff 
	jrst retok		;that's all we have to do

;can't return core, error 1
errcrc:

;not enough core, error 1
errnec:	movei t1,1
	movem t1,@2(l)		;error 1
	setzm @1(l)		;no error codes for now
	popj p,
		


>;END IFN FTOPS20
SUBTTL	TOPS-10 VERSION - NOT SUPPORTED

IFE FTOPS20,<

;FORTRAN DATA TYPES

TP%UDF==0			;UNDEFINED TYPE
TP%LOG==1			;LOGICAL
TP%INT==2			;INTEGER
TP%REA==4			;REAL
TP%OCT==6			;OCTAL
TP%LBL==7			;LABEL OR ADDRESS
TP%DOR==10
TP%DOT==12
TP%COM==14
TP%LIT==17			;ASCIZ TEXT (LITERAL STRING)

;FUNCT. ARGUMENTS

F.GCH==4			;GET CHANNEL ARGUMENT
F.RCH==5			;RETURN CHANNEL NUMBER

;LOCAL DEFINITIONS

DIRLEN==5				;ALL WE SHOULD NEED OF .EXE DIRECTORY
PAGLEN==^D32				;MAX. PAGES NEEDED FOR HIGH SEG CODE
	'SORT  '			;NAME FOR TRACE.
SORT:	MOVEM	L,SAVEL
	MOVEI	L,1+[-4,,0
		     Z TP%INT,[F.GCH]
		     Z TP%LIT,[ASCIZ /SRT/]
		     Z TP%INT,CHSTAT
		     Z TP%INT,SRTCHN]
	PUSHJ	P,FUNCT.##		;ASK FOROTS FOR A CHANNEL
	SKIPE	CHSTAT			;DID WE GET IT?
	JRST	E$$CAS			;NO
	MOVE	T1,SRTCHN
	DPB	T1,[POINT 4,SRTCHN,12]	;PUT IN ACC FIELD
	HLLZ	T1,SRTCHN
	IOR	T1,[OPEN OBLK]
	XCT	T1			;OPEN SYS
	 JRST	E$$OPN			;FAILED?
	HLLZ	T1,SRTCHN
	IOR	T1,[LOOKUP LBLK]
	XCT	T1			;LOOKUP SYS:SRTFOR.EXE
	  JRST	E$$LKP			;FAILED
	HLLZ	T1,SRTCHN
	IOR	T1,[IN	DIRIOW]
	XCT	T1
	  SKIPA	T1,SRTDIR		;OK, GET DIRECTORY HEADER
	JRST	E$$INP			;ERROR
	CAME	T1,[1776,,5]		;WHAT WE EXPECT
	JRST	E$$DUF			;NO
	HRRZ	T1,SRTDIR+3		;GET FILE PAGE
	LSH	T1,2			;4 BLOCKS PER PAGE
	ADDI	T1,1			;START AT 1
	HLL	T1,SRTCHN
	TLO	T1,(USETI)
	XCT	T1			;SET ON HIGH SEG PAGES
	LDB	T1,[POINT 9,SRTDIR+4,8]	;GET REPEAT COUNT
	CAILE	T1,PAGLEN		;TOO BIG
	JRST	E$$HTB			;YES
	MOVEM	T1,PAGARG		;LOAD UP ARG COUNT
	MOVN	T1,T1
	HRLZ	T1,T1			;AOBJN POINTER
	HRRZ	T2,SRTDIR+4		;CORE PAGE
	MOVEM	T2,PAGARG+1(T1)		;STORE PAGE #
	ADDI	T2,1
	AOBJN	T1,.-2			;FILL UP ARG BLOCK
	MOVE	T1,[.PAGCD,,PAGARG]
	PAGE.	T1,
	  JRST	E$$PCF			;FAILED
	HRRZ	T2,PAGARG+1		;GET FIRST PAGE
	LSH	T2,^D9			;INTO WORDS
	SUBI	T2,1
	MOVE	T3,PAGARG		;GET NUMBER OF PAGES
	LSH	T3,^D9
	MOVN	T3,T3
	HRL	T2,T3			;I/O WORD
	HLLZ	T1,SRTCHN
	IOR	T1,[IN T2]
	SETZ	T3,
	XCT	T1
	  SKIPA
	JRST	E$$INP
	PUSH	P,.JBHSA##+1(T2)	;GET START ADDRESS
	MOVEI	L,1+[-4,,0
		     Z TP%INT,[F.RCH]
		     Z TP%LIT,[ASCIZ /SRT/]
		     Z TP%INT,CHSTAT
		     Z TP%INT,SRTCHN]
	PUSHJ	P,FUNCT.		;RESTORE CHAN TO FOROTS
	POP	P,T1			;GET BACK START ADDRESS
	MOVE	L,SAVEL			;RESTORE STRING POINTER
	PUSHJ	P,(T1)			;START SORT

	MOVSI	T1,-PAGLEN
	MOVSI	T2,(1B0)
	IORM	T2,PAGARG+1(T1)		;SET DESTROY BIT
	AOBJN	T1,.-1			;FOR ALL OF SORT PAGES
	MOVE	T1,[.PAGCD,,PAGARG]
	PAGE.	T1,
	  JFCL				;TOO BAD
	POPJ	P,			;RETURN TO CALLER

OBLK:	EXP	.IODMP
	SIXBIT	/SYS/
		0

LBLK:	EXP	.RBEXT			;.RBCNT
		0			;.RBPPN
	SIXBIT	/SRTFOR/		;.RBNAM
	SIXBIT	/EXE/			;.RBEXT

DIRIOW:	IOWD	DIRLEN,SRTDIR
	0
	

E$$CAS:	$ERROR	(?,CAS,<Channel not available for FORTRAN SORT/MERGE.>)
E$$OPN:	$ERROR	(?,OPN,<OPEN failed for SYS:SRTFOR.EXE.>)
E$$LKP:	$ERROR	(?,LKP,<LOOKUP failed for SYS:SRTFOR.EXE.>)
E$$DUF:	$ERROR	(?,DUF,<SYS:SRTFOR.EXE directory not in expected format.>)
E$$HTB:	$ERROR	(?,HTB,<SYS:SRTFOR.EXE high segment too big.>)
E$$PCF:	$ERROR	(?,PCF,<PAGE. UUO failed for FORTRAN SORT/MERGE.>)
E$$INP:	$ERROR	(?,INP,<Input error for SYS:SRTFOR.EXE.>)

DIE:	EXIT

SAVEL:	BLOCK	1		;SAVE L
CHSTAT:	BLOCK	1		;STATUS OF FUNCT. CALL
SRTCHN:	BLOCK	1		;CHAN USED FOR I/O
SRTDIR:	BLOCK	DIRLEN
PAGARG:	BLOCK	PAGLEN

>;END IFE FTOPS20

	END