.TITLE	SORT - General Purpose ASCII Sort
.Enabl	lc
.Nlist	bex

.Sbttl	V2A	25-Jul-83	DECUS Programme
; Change default /L to max key or deflen, whichever is lesser.

			.If eq 1
Written by D. S. Whimp, St Peter's College, Brisbane, 1977.

Modified for DECUS release by Chester Wilson, 71 Galatea St, Charleville 4470
Australia, who is willing to attempt to provide support for it.

Modifications:

1)	Allocate scratch files as needed if user did not specify sufficient.

2)	Use RT-compatible command decoding.  Scrub command file facility,
	but continue .CHAIN facility.
	Add defaults: /L:<deflen>, /K:1:<deflen>.

3)	Add Alphanumeric sorting.
	(The order of the sort can be modified by attacking the tables
	ALPTAB and CAPTAB.  Maybe one day I'll make these externally
	variable.)

4)	Ignore control characters bar <cr> (end of line) and <tab>, and
	^Z in Dibol files.
			.Endc


;Defaults which may be altered should the user wish so:

.iif ndf deflen, deflen=80.		;Default for /L.  /K defaults to
					; /K:A:1:<deflen>
.Sbttl	Definitions

tab=11
lf=12
ff=14
cr=15
spc=40

	.mcall	.delete,.releas,.purge,.rctrlo,.rename,.gtim,.sreset
	.mcall	.ttyin,.ttyout,.readw,.read,.wait,.lock,.unlock
	.mcall	.chain,.close,.lookup,.enter,.dstatus,.fetch,.qset
	.mcall	.print,.exit,.csispc,.settop,.writw
	.mcall	$dbio,$inbuf,$outbuf,$in,$out,$close,$reset,$purge
	.mcall	.gtlin
	
	$dbio
	.globl	jdiv,jmul

; SORT Limitation Parameters

	maxmrg	=30.		;Maximum order of merge
	maxkey	=10.		;Maximum # of keys
	leeway	=5.		;% overallocation for files
	overun	=8.		;Size of run-index file if opened during sort
	rbsize	=400		;Size of run-pointer-file buffers

; System Communication Area Definitions

	jsw	=44		;Job Status Word
	emterr	=52		;EMT Error Codes are returned to this byte.
	stackp	=42		;Initial Stack Pointer must be loaded here.
	rmon	=54		;Contains Monitor base addr
	config	=300		;Configuration Word Offset from Monitor base.

	userrb	=53		;User Error Byte
	error$	=4		;Bit to set on normal error.

; Bit Definitions

	Clockt	=40		;Config bit for 50 or 60 Hz clock
	chain$	=400		;JSW bit to determine whether chained to
	kw11l	=100000		;Tells whether or not kw11l clock is present.
	discdev	=100000		;Determines whether a device is a disc

; Offsets from the beginning of a SORT Input Buffer Header

;	sts	=0		;Never used - just so you know where it is
	wdpnt	=2		;Pointer to next data byte in buffer
	bytcnt	=4		;# of data bytes left in buffer
	size	=6		;Length of buffer in words
	bufadr	=10		;Addr of beginning of buffer
	blkinc	=12		;# of blocks of data in buffer
	blkpnt	=14		;# of first block of data in core
	rekcnt	=16		;# of records left in the run associated
				;	with this buffer
	bhsize	=11		;# of words in this type of buffer header

; Offsets in words from the beginning of a Node in a tree

	loser	=0		;Loser stored in this node
	rn	=2		;Run # of the record in this node
	fe	=4		;Address of internal node above
				;	this external node
	fi	=6		;Address of internal node above
				;	this internal node

; Offsets from beginning of .CSISPC block

	outfile	=0
	skr1	=10.
	skr2	=20.
	infile	=30.


.macro	$setup	src,reg		;Used by SETUP macro
	mov  src,r'reg
.endm

.macro	setup	arg		;Moves arguments into sequential 
	c.=0			;Registers starting with r0
.irp	src	<arg>
	$setup	src,\c.
	c.=c.+1
.endr
.endm


.macro	clear	count,stadr,?loop	;Clears arrays
	setup	<count,stadr>
loop:	clr  (r1)+
	dec  r0
	bgt  loop
.endm

	c.=0
.macro	.fixpt	arg1,arg2
.if	le,c.-70.
.iif	le,c.-maxmrg	.word	arg2,arg1
.iff
	.error	;maxmrg is too large.
.endc
	c.=c.+1
.endm
.Sbttl	General Storage

	.blkw	200
stack::
limit::	.limit
qarea::	.blkw	7*10.
pra::	.blkw	10		;Programmed request argument area
kcnt::	.blkw	1		;For decoding /K switches - count
kpnt::	.blkw	1		; ibid, pointer
kblk::	.blkw	40.		; ibid, block
renblk::.blkw	4		;Rename block for use after last pass
filblk::.blkw	39.		;.CSISPC pokes its file specifications here
defxts::.rad50	"sav         "	;Default extension for .chain programs
defxtp::.rad50	"datdatssfssf"	; Ditto for the works.
gccsts::.blkw	1		;Specifies where the commands come from.
gccbc::	.blkw	1		;# of bytes left in command file buffer.
gccbp::	.blkw	1		;Current character position in cmd file buffer
gccbkp::.blkw	1		;Block # of next block to be read from
				;	command file.
keymax::.blkw	1		;Maximum column involved in /K spec (plus 1)
kstpos::.blkw	maxkey		;Starting positions of keys.
				;	-ve if descending key.
keylen::.blkw	maxkey		;Key lengths in bytes.
keylnb::.blkw	1		;Total length of keys in words rounded up.
extra::	.blkw	1		;Length in bytes of tag
olen::	.blkw	1		;Max record length on output
reclen::.blkw	1		;Record length.
	.blkw	1		;Even # of bytes required for internal
	.word	0		;	storage of one record 
keycnt::.blkw	1		;# of keys.
obuf::	.blkw	bhsize		;Output buffer header
ibufs::	.blkw	maxmrg*bhsize	;Input buffer headers (only one in use
				;	during first pass)
rob::	.blkw	rbsize		;Output buffer for run-index file
rib::	.blkw	rbsize		;Input buffer for same
	.irp  bh,<rob,rib>
bh'buf::.blkw	1		;Buffer pointer for run-index file
bh'siz::.blkw	1		;Buffer size for run-index file
bh'wpt::.blkw	1		;Data pointer for run-index buffer
bh'wct::.blkw	1		;# of words left in buffer
bh'blk::.blkw	1		;Block pointer for buffer
bh'inc::.blkw	1		;Block increment for buffer
	.endr
t::	.blkw	1		;Pointer which climbs the tree during
				;	determination of a new winner
base::	.blkw	1		;Base of sort tree
rq::	.blkw	1		;Run # of current winner
q::	.blkw	1		;Address of node containing current winner
loc.x1::.blkw	1		;Address of node(1).
basem::	.blkw	1		;Base address of tree used during merging
rqm::	.blkw	1		;RQ for merge tree
qm::	.blkw	1		;Q for merge tree
irtn::	.blkw	1		;Input routine to be used to fetch a record
				;	by TREEO
ortn::	.blkw	1		;Ditto but for output
bufhed::.blkw	1		;Address of buffer header associated with
				;	record wanted by TREEO
trunc::	.blkw	1		;# of records truncated on input
compare::.blkw	1		;Addr of key comparison routine
getrec::.blkw	1		;Addr of record fetch routine.
putrec::.blkw	1		;Addr of record store routine.
trnsli::.blkw	1		;Addr of translate on input array
trnslo::.blkw	1		;Addr of translate on output array.
brncho::.blkw	1		;Branch offset for compare code generation
pcc::	.blkw	1		;"pc" of generated comparison code
worklo::.blkw	1		;Lowest address of work area
workhi::.blkw	1		;Highest addr of work area
instr::	.blkw	1		;Current comparison instruction.
cmpr01::cmp	(r0)+,(r1)+	;Instruction for ascending comparison
cmpr10::cmp	(r1)+,(r0)+	;Instruction for descending comparison
in::	.blkw	1		;Input channel during any phase
out::	.blkw	1		;Output channel during any phase
scr1::	.blkw	1		;First scratch file channel
scr2::	.blkw	1		;Second
cblk::	.blkw	4		;Used to check if devices are discs
filsiz::.blkw	2		;Calculated output file size
fn1::	.rad50	" s1"		;Name of first scratch file
fn2::	.rad50	" s2"		;Name of second scratch file
runfil::.rad50	"dk  s3   ssf"	;Name of run-index file
rnfsiz::.blkw	1		;Size of run-index file
	.word	0
bsiz1::	.blkw	1
	.word	0
tsiz::	.blkw	1		;# of bytes available for binary tree
	.word	0
p::	.blkw	2		;# of external nodes in binary tree

chnptr::.blkw	1		;Pointer to chain command for return from
				; chain.

;Miscellaneous arithmetic argument blocks

ab1:	.word	3,tsiz,reclen+2,p
ab2:	.word	3,filsiz,tsiz,xpectr
ab3:	.word	4,xpectr,p,xpectr,rem
ab4:	.word	3,tsiz-2,tmpsto,tmpsto
ab5:	.word	3,tsiz,tmpsto,tmpsto
ab6:	.word	4,ftime,ticsec,ftime,rem
ab7:	.word	4,tmpsto,ten,tmpsto,rem
ab8:	.word	3,xpectr,reclen+2,skrsiz
ab9:	.word	3,xpectr,reclen+2,osize
ab10:	.word	3,leaway,skrsiz,tmpsto
ab11:	.word	3,tmpsto,hundred,tmpsto
ab12:	.word	3,leaway,osize,tmpsto
ab13:	.word	3,leaway,rnfsiz,tmpsto

	.radix 10.
;This table is used to convert double
;precision binary to ASCII decimal

Tentbl::
	.word	1220, 46080, 8
	.word	610,  23040, 4
	.word	305,  11520, 2
	.word	152,  38528, 1
	.word	12,   13568, 8
	.word	6,    6784,  4
	.word	3,    3392,  2
	.word	1,    34464, 1
	.word	1,    14464, 8
	.word	0,    40000, 4
	.word	0,    20000, 2
	.word	0,    10000, 1
	.word	0,    8000,  8
	.word	0,    4000,  4
	.word	0,    2000,  2
	.word	0,    1000,  1
	.word	0,    800,   8
	.word	0,    400,   4
	.word	0,    200,   2
	.word	0,    100,   1
	.word	0,    80,    8
	.word	0,    40,    4
	.word	0,    20,    2
	.word	0,    10,    1
	.word	0,    8,     8
	.word	0,    4,     4
	.word	0,    2,     2
	.word	0,    1,     1
	.radix 8

leaway::.word	leeway,0
hundred::.word	100.,0
ten::	.word	10.,0
stime::	.blkw	2		;Time at which sort starts
ftime::	.blkw	2		;Time at which sort finishes
ticsec::.blkw	1		;# of ticks/sec (or secs/min or mins/hr)
	.word	0
secs::	.blkw	1		;# of secs it took for sort modulo 60.
mins::	.blkw	1		;# of mins modulo 60.
xpectr::.blkw	2
rem::	.blkw	2
osize::	.blkw	2
skrsiz::.blkw	2
avail::	.blkw	1
maxmo::	.blkw	1
tmpsto::.blkw	2
runs::	.blkw	1
runso::	.blkw	1		;# of runs output from the merge phase
				;	after one pass
bottom::.blkw	1		;Bottom of unused portion of work area
rmax::	.blkw	1		;Tot # of runs produced by distribution phase
rc::	.blkw	1		;Used to determine end of run during
				;	distribution phase
lastkey::.blkw	1		;Addr of external node containing last
				;	record output
totcnt::.blkw	2		;Tot count of records processed during
				;	merge phase
chkcnt::.blkw	2
reccnt::.blkw	2		;Used to count # of records in a run in pass1

flags::

dibol::	.blkw	2
dibl$c::.blkb	1
ordr$k::.blkb	maxkey		;Indicates if keys ascending or descending
deli$c::.blkb	1		;Delete input file flag.
ordr$c::.blkb	1		;Ascending/descending key flag.
ordr$d::.blkb	1		;If /A, set default compare = alphanumeric
sqno$c::.blkb	1		;Output seq. #'s for tagsort
xspc$c::.blkb	1		;Keep vari-length records that way.
keys$c::.blkb	1		;Output keys for tag sort.
prmt$c::.blkb	1		;Prompting flag.
fstp$c::.blkb	1		;Indicates whether in run generation,
				;	or  merge phase
tsrt$c::.blkb	1
nomg$c::.blkb	1
pixn$c::.blkb	1		;Indicates format of tag-sort seq nos
eof$c::	.blkb	1
rnfe$c::.blkb	1		;Indicates whether run-index file is .ENTER'ed

debug$::.blkb	1		;Set for debugging purposes (/?).


eoflags::
	.even
.Sbttl	Optimization Tables

Ibfrac::
	.radix	10.
        .fixpt  1,  27145     ; 1.41421 
        .fixpt  2,  0         ; 2 
        .fixpt  2,  29457     ; 2.44949 
        .fixpt  2,  54291     ; 2.82843 
        .fixpt  3,  10635     ; 3.16228 
        .fixpt  3,  30415     ; 3.4641 
        .fixpt  3,  48605     ; 3.74166 
        .fixpt  4,  0         ; 4 
        .fixpt  4,  15901     ; 4.24264 
        .fixpt  4,  30941     ; 4.47214 
        .fixpt  4,  45247     ; 4.69042 
        .fixpt  4,  58915     ; 4.89898 
        .fixpt  5,  6489      ; 5.09902 
        .fixpt  5,  19103     ; 5.2915 
        .fixpt  5,  31275     ; 5.47723 
        .fixpt  5,  43047     ; 5.65685 
        .fixpt  5,  54457     ; 5.83095 
        .fixpt  6,  0         ; 6 
        .fixpt  6,  10775     ; 6.16441 
        .fixpt  6,  21270     ; 6.32456 
        .fixpt  6,  31505     ; 6.48074 
        .fixpt  6,  41500     ; 6.63325 
        .fixpt  6,  51270     ; 6.78233 
        .fixpt  6,  60830     ; 6.9282 
        .fixpt  7,  4657      ; 7.07107 
        .fixpt  7,  13834     ; 7.2111 
        .fixpt  7,  22837     ; 7.34847 
        .fixpt  7,  31674     ; 7.48332 
        .fixpt  7,  40355     ; 7.61577 
        .fixpt  7,  48887     ; 7.74597 
        .fixpt  7,  57278     ; 7.87401 
        .fixpt  8,  0         ; 8 
        .fixpt  8,  8129      ; 8.12404 
        .fixpt  8,  16135     ; 8.24621 
        .fixpt  8,  24025     ; 8.3666 
        .fixpt  8,  31803     ; 8.48528 
        .fixpt  8,  39474     ; 8.60233 
        .fixpt  8,  47041     ; 8.7178 
        .fixpt  8,  54510     ; 8.83176 
        .fixpt  8,  61883     ; 8.94427 
        .fixpt  9,  3629      ; 9.05539 
        .fixpt  9,  10823     ; 9.16515 
        .fixpt  9,  17931     ; 9.27362 
        .fixpt  9,  24958     ; 9.38083 
        .fixpt  9,  31905     ; 9.48683 
        .fixpt  9,  38775     ; 9.59166 
        .fixpt  9,  45571     ; 9.69536 
        .fixpt  9,  52295     ; 9.79796 
        .fixpt  9,  58949     ; 9.8995 
        .fixpt  10, 0         ; 10 
        .fixpt  10, 6521      ; 10.0995 
        .fixpt  10, 12978     ; 10.198 
        .fixpt  10, 19374     ; 10.2956 
        .fixpt  10, 25710     ; 10.3923 
        .fixpt  10, 31987     ; 10.4881 
        .fixpt  10, 38207     ; 10.583 
        .fixpt  10, 44373     ; 10.6771 
        .fixpt  10, 50484     ; 10.7703 
        .fixpt  10, 56543     ; 10.8628 
        .fixpt  10, 62550     ; 10.9545 
        .fixpt  11, 2972      ; 11.0454 
        .fixpt  11, 8882      ; 11.1355 
        .fixpt  11, 14743     ; 11.225 
        .fixpt  11, 20559     ; 11.3137 
        .fixpt  11, 26329     ; 11.4018 
        .fixpt  11, 32055     ; 11.4891 
        .fixpt  11, 37738     ; 11.5758 
        .fixpt  11, 43378     ; 11.6619 
        .fixpt  11, 48977     ; 11.7473 
        .fixpt  11, 54536     ; 11.8322 
	.radix	8

Optmer::		;Table of x,x*x,x*x*x,x*x*x*x   for 0 < x < maxmrg
	x=1
	.rept	maxmrg
.if	lt,x-16.
	.word	x,  x*x,  x*x*x,  x*x*x*x
.endc
.if	ge,x-16.
.if	lt,x-40.
	.word	x,  x*x,  x*x*x,  -1
.iff
	.word	x,  x*x,  -1,  -1
.endc
.endc
	x=x+1
.endr
.Sbttl	Error Messages

vermes::.asciz	"Sort V2A"

hdrerr::.ascii	"?SORT-F-"<200>

illsw::	.asciz	"Illegal switch or value - Type /H for help."
cnotf::	.ascii	"Chain " ; (continues with next message)
notfnd::.asciz	"File not found"
cmdsyn::.asciz	"Command Syntax Error"
illdev::.asciz	"Illegal Device"
tmnyks::.asciz	"Too Many Keys"
ovrlap::.asciz	"Keys Overlap"
hdwie::	.asciz	"Input Error"
hdwoe::	.asciz	"Output Error"
rnfie::	.asciz	"Run-index file Input Error"
keyerr::.asciz	"Key Error"
inscor::.asciz	"Insufficient memory"
fetche::.asciz	"Fetch Error"
noxspc::.asciz	"Insufficient Disc Space"
insalc::.asciz	"Insufficient Disc Space Allocated"
rusure::.ascii	"/R will destroy your Input File.  Are you sure? "<200>
buferr::.asciz	"Buffering Error"
lost::	.asciz	"Records lost in Merge"
errdel::.asciz	"Error deleting Input File"
erenme::.asciz	"Error renaming Scratch File"
tmnyrn::.asciz	"Too Many Runs"
rsrtd::	.ascii	" Records Sorted"<200>
inn::	.ascii	" in "<200>
hrs::	.ascii	" hr, "<200>
minuts::.ascii	" min, "<200>
secnds::.ascii	" sec"<200>
crlf::	.byte	cr,lf,0
star::	.ascii	"*"<200>
noifil::.asciz	"No Input File"
noofil::.asciz	"No Output File"
sfilnd::.asciz	"Scratch Files must be on Discs"
null::	.byte	0
	.even
.Sbttl	Error Message Printing

Fatal::
	bit	#chain$,@#jsw	;If chained to, return the error.
	beq	20$
	mov	chnptr,r5	;Provided he expected a return!
	beq	20$

	mov	#510,r1		;Area to chain back to.
	clr	(r1)+		;Tell him there's an error
	mov	@(sp)+,r0	;Error message itself
10$:	movb	(r0)+,(r1)+
	bne	10$
	br	chain
20$:
	bis	#error$,@#userrb
	.rctrlo
	.print	#hdrerr
Nfatal::
	.rctrlo
	.print	@(sp)+
	br	sort
.Sbttl	Initialization Code

Start::
	mov	#510,gccbp	;CHAIN buffer area.
	clr	chnptr		;Pointer to return-from-chain command
	bit	#chain$,@#jsw	;Chained to?
	beq	sort		;No.

	mov	#510,r0		;Yes.  Convert "\"'s in command string to
10$:				; nulls, to allow him easier use from Fortran.
	cmpb	(r0),#'\
	bne	20$
	clrb	(r0)
	cmpb	1(r0),#'\	;Check for terminating "\\"
	bne	20$
	clrb	1(r0)
20$:
	cmpb	(r0),#'!	;Return-from-chain?
	bne	30$
	mov	r0,chnptr	;Yes - remember it.
30$:
	tstb	(r0)+		;Null between commands?
	bne	10$
	tstb	(r0)		;Null after last command?
	bne	10$

Sort::
	mov	limit+2,r0	;Contract core so usr can fit in
	mov	#stack,sp
	call	coreae
	.sreset
	.qset	#qarea,#7	;Extend length of i/o queue

Stcmdd::
	clear	#1+eoflags-flags/2,#flags
	clear	#maxkey*2,#kstpos
	clr	keylnb
	clr	keycnt
	clr	reclen
	mov	#kblk,kpnt
	clr	kcnt
10$:
	bit	#chain$,@#jsw	;If chaining, see what next command is.
	bne	20$

	mov	#510,r5		;Command pointer
	.rctrlo
	.gtlin	r5,#star	;Read command line from terminal
	br	30$
20$:
	mov	gccbp,r5	;Use command from chain area.
	tstb	(r5)
	bne	30$
	.exit			;Exit if no more commands after chaining.
30$:
	cmpb	(r5),#'!	;Want to chain back to something else?
	bne	sortcm
Chain::
	inc	r5
	.csispc	#filblk,#defxts,r5
	bcc	10$
	  call	fatal
	  .word	cnotf
10$:	setup	<#500,#filblk+infile>
	mov	(r1)+,(r0)+	;Move input
	mov	(r1)+,(r0)+	; file block
	mov	(r1)+,(r0)+	;  to chain area.
	mov	(r1),(r0)
	.chain


Sortcm::
	tstb	(r5)		;If null, just want version number
	bne	5$
	.print	#vermes
	br	sort
5$:
	.csispc	#filblk,#defxtp,r5
	bcc	6$
	  call	fatal
	  .word	cmdsyn
6$:
	bit	#chain$,@#jsw	;If chaining, skip to next command.
	beq	20$
	mov	r5,r0
10$:	tstb	(r0)+		;Null at end of command (2 at end of the lot)
	bne	10$
	mov	r0,gccbp
20$:
	mov	(sp)+,r5	;# of switches
	bne	nexswt
	jmp	endswt		;None specified


; Decode the next switch:

Nexswt::
	clr	r2		;In case no value.
	mov	(sp)+,r1	;b15 set if value specified, b14-8 file on
				; which switch specified, b7-0 ascii value
	bpl	5$		; of switch.
	mov	(sp)+,r2	;Value
5$:	bic	#40,r1		;In case lower case

	mov	#swtab,r4	;Table of <switch><routine>
6$:
	tst	(r4)		;Null = end of table.
	beq	illswt
	cmpb	r1,(r4)		;See if it's this switch
	beq	9$		;It is.
	cmp	(r4)+,(r4)+	;It isn't.  Try the next one.
	br	6$
9$:
	call	@2(r4)		;Call relevant routine
	dec	r5		;Any more switches?
	bne	nexswt		;Yes.
	jmp	endswt		;No.

Illswt::
	call	fatal
	.word	illsw
.Sbttl	Switch Table & Help Message

;Entries in this table are:

;	.word	<upper case value of switch>
;	.word	<address of routine to handle that switch>
; The table is terminated by a null.

	.psect	mesage	con
Swtab::
	.word	'A,asalph
	.word	'D,dibolf
	.word	'H,help
	.word	'K,keys
	.word	'L,length
	.word	'P,pad
	.word	'R,usein
	.word	'T,tags
	.word	0

Help:
	call	nfatal
	.word	hmes
hmes:
.ascii	#SORT switches available are:#<cr><lf><lf>
.ascii	#/L:m	Length of record#<cr><lf>
.ascii	#/K:A:n:m	ascending key, from column n, m columns wide#<cr><lf>
.ascii	#/K:D:n:m 	descending key, ibid#<cr><lf>
.ascii	#/K:ALP:n:m	alphanumeric key (ascending), ibid#<cr><lf>
.ascii	#/A	If no /K specified, default to alphanumeric search#<cr><lf>
.ascii	#/P	Pad records with spaces#<cr><lf>
.ascii	#/R	Reuse input file as a scratch file - DANGEROUS!#<cr><lf>
.ascii	#/T:S	Tag sort, with record sequence numbers sent to the output#
.ascii		# file as tags#<cr><lf>
.ascii	#/T:P	ibid, using 9 digit record position numbers (6 for block,#
.ascii		# 3 for byte)#<cr><lf>
.ascii	#/T:K	Tag sort, with keys sent to the output file#<cr><lf>
.ascii	#/D[:m]	Dibol input & output files, sorting m records#<cr><lf>
.ascii	#/H	type this message#<cr><lf>
.byte	0
	.psect
.Sbttl	Switch decoding routines

;Each switch decoding routine is called with the following information:

; R1/	b15 set if value specified; b14-8 file on which switch specified;
;	low order byte (b 7-0) ascii value of switch with lower-case bit clear


Length::			;	/L:m - set length of record
	tst	r1
	bpl	illswt
	mov	r2,reclen
	beq	illswt
	return

Asalph::			;	/A - assume alphanumeric if no /K
	movb	#1,ordr$d
	return

Keys::				;	/K:A - ascending keys :D - descending
	tst	r1
	bpl	illswt
	mov	r2,@kpnt
	add	#2,kpnt
	inc	kcnt
	return

Tags::				;	/T - Tagsort: /T:S:P:K
	tst	r1
	bpl	tag.s		;Default is /T:S
	cmp	r2,#^rS
	beq	tag.s
	cmp	r2,#^rP
	beq	tag.p
	cmp	r2,#^rK
	beq	tag.k
	br	illswt
tag.p:
	movb	#-1,pixn$c	;/T:P - tag sort, positions to output file
tag.s:				; (:P implies :S for internals of programme)
	movb	#-1,sqno$c	;/T:S - tag sort, seq #'s to output file
	br	tag.x
tag.k:
	movb	#-1,keys$c	;/T:K - tag sort, keys to output file
tag.x:
	movb	#-1,tsrt$c
	return


Pad::				;	/P - pad with spaces
	tst	r1
	bmi	illswt
	movb	#-1,xspc$c
	return


Usein::				;	/R - use input file for scratch
	movb	#-1,deli$c
	return


Dibolf::
	movb	#-1,dibl$c	;	/D - bloody DIBOL file
	tst	r1
	bpl	10$		;No : value
	add	r1,dibol	;Add, to allow BIG values
	adc	dibol+2
10$:	return



.Enabl	lsb

Endswt::
	clr	keymax		;Max column involved in /K spec (plus 1)
	mov	kcnt,r2		;Number of /K's
	beq	30$
	mov	kpnt,r1		;Pointer to next free /K word
10$:
	cmp	-(r1),#^rA	;Ascending?
	beq	ascend
	cmp	(r1),#^rD	;Descending?
	beq	descend
	cmp	(r1),#^rALP	;Alphanumeric?
	beq	alphi

	mov	keycnt,r0
	movb	ordr$c,ordr$k(r0) ;Order for this /K
	asl	r0
	mov	(r1),r3		;Starting position
	mov	r3,kstpos(r0)
	add	-(r1),r3	;Length -> final column position
	mov	(r1),keylen(r0)
	add	(r1),keylnb	;Length of keys
	inc	keycnt
	cmp	r3,keymax	;Is this the biggest so far?
	ble	15$
	mov	r3,keymax	;Yes - remember it.
15$:	cmpb	(r1),#^rA	;Make sure 2 values together
	beq	illswt
	cmpb	(r1),#^rD
	beq	illswt		;If there are single values,
	sub	#2,r2		; or an odd number,
	bmi	illswt		; prang him.
	bne	10$
	br	30$		;That's all, folks.

alphi:	movb	#1,ordr$c
	br	20$
ascend:	clrb	ordr$c
	br	20$
descend:movb	#-1,ordr$c
20$:	dec	r2
	br	10$

30$:

.dsabl	lsb

Defchk::
	tst	reclen		;Any length specified?
	bne	10$		;Yes.
	mov	keymax,r1	;Any keys?
	dec	r1		;(keymax has excess of 1)
	cmp	r1,#deflen	;See if over default value
	bge	5$		;Yes.
	mov	#deflen,r1	;No - use default
5$:	mov	r1,reclen

10$:	tst	keycnt		;Any keys specified?
	bne	20$		;Yes.

	movb	ordr$d,ordr$k	;No. Assume /K:A:1:<line length>
	mov	#1,kstpos	; unless /A, when /K:ALP:1:<line length>
	mov	reclen,r0
	mov	r0,keylen
	mov	r0,keylnb
	inc	keycnt
20$:
;The following code checks that all starting positions and
;ALL keylengths are non-zero.  If any are zero, then
;there is an error in the command string

Takeoff::
	setup	<#keylen,keycnt,#kstpos>
20$:	tst	(r0)+		;If no branch out of loop, all key lengths
	beq	30$		; non-zero.
	tst	(r2)
	beq	30$
	dec	(r2)+
	dec	r1
	bgt	20$
	br	chkovl
30$:
	call	fatal
	.word	keyerr		;Yep. have mixed up keys.


;The following code checks for overlap of keys, and that all keys stay within
; the record.

;for 0 < j <= keycnt
;	for 0 < i <= keycnt
;		if  i<>j  then  if  stpos(i)<=stpos(j)  and
;		   stpos(i)+len(i)>stpos(j)  then
;		     print "Keys overlap", goto stcmdd

Chkovl::
	mov	keycnt,r0
	asl	r0
10$:	mov	keycnt,r1
	asl	r1
20$:	mov	kstpos-2(r0),r2
	add	keylen-2(r0),r2
	cmp	reclen,r2
	blt	30$
	cmp	r0,r1
	beq	40$
	cmp	kstpos-2(r0),kstpos-2(r1)
	bgt	40$
	cmp	kstpos-2(r1),r2
	bge	40$
	  call	fatal
	  .word	ovrlap
30$:
	  call	fatal
	  .word	keyerr
40$:
	sub	#2,r1
	bgt	20$
	sub	#2,r0
	bgt	10$

	clr	extra		;Now calculate the number of extra bytes
	tstb	tsrt$c		; required for tags in record. six bytes for
	beq	.01		; record sequence numbers, nine for file
	mov	#7,extra	; indices.
	tstb	pixn$c
	beq	50$
	mov	#11,extra
50$:
.Sbttl	Setup Translation Arrays

;This code sets up two translation arrays which are used
; to rapidly translate keys to the beginning of a record, and
; swap bytes within words of a key so that word comparisons may be
; used where possible on keys.  If a straight record sort is being done
; the two arrays will be the same, if a tag sort
; the first array will be used to eliminate unwanted data.
;ARRAY(I) contains the character position in the record in
; memory of the i'th character position in the record in
; as it appears on the external I/O device.
;After the two arrays have been set up, straight line code
; is generated to produce a comparison routine, which does
; byte comparisons only where necessary.  Groups of ascending
; or descending keys which pack together at the beginning
; of each record in core are treated as one key.  Descending
; keys are implemented by swapping the comparison order.
;If a key starts or finishes at an odd byte address, a byte
; comparison is done.

; Get core needed for arrays

.01::	mov	limit+2,workhi
	mov	limit+2,worklo
	mov	reclen,r0	;As many words are need as bytes in a record
	add	extra,r0	;Allow for sequence #'s
	mov	r0,-(sp)	;Save for allocation of next array
	call	core		;Allocate space for first array
	mov	worklo,trnsli
	mov	(sp),r0
	call	core
	mov	worklo,trnslo	;Allocate space for second array
	mov	(sp)+,r0	;Now initialize arrays to ignore everything
	asl	r0		;Init both trnsli & trnslo
	mov	trnsli,r1
1$:	mov	#-1,(r1)+
	dec	r0
	bgt	1$

;	for 0 <= j < keycnt
;		for stpos(j) <= k <stpos(j)+len(j)
;			if tag-sort then trnslo(i)=i  else   trnslo(k)=i
;			trnsli(k)=i
;			i=i+1

	i=	%0		;So you don't lose track of the variables
	j=	%1
	k=	%2

.02::	clr	i
	clr	j
1$:	mov	j,r3
	asl	r3		;R3 used to calculate addresses, and offsets
	mov	kstpos(r3),k
	mov	k,r4		;Work out termination check value for K.
	add	keylen(r3),r4
2$:	mov	k,r3
	tstb	tsrt$c
	beq	3$
	mov	i,r3
3$:	asl	r3
	add	trnslo,r3
	mov	i,(r3)
	mov	k,r3
	asl	r3
	add	trnsli,r3
	mov	i,(r3)
	inc	i
	inc	k
	cmp	k,r4		;Loop on k
	blt	2$
	inc	j
	cmp	keycnt,j	;Loop on j
	bgt	1$

;	if not tag-sort then
;		for 0 <= j < reclen
;			if trnsli(j) < 0  then  trnsli(j)=trnslo(j)=i
;			i=i+1
;ie translate what's left over from keys to the end of the line

	tstb	tsrt$c
	bne	compil
	clr	j
4$:	mov	j,r3
	asl	r3
	mov	r3,r4
	add	trnsli,r3
	tst	(r3)
	bge	5$
	add	trnslo,r4
	mov	i,(r3)
	mov	i,(r4)
	inc	i
5$:	inc	j
	cmp	reclen,j
	bgt	4$

Compil::mov	keylnb,r0	;Allocate max possible needed space for code
	inc	r0		;Allow 2n+2 words for key comparison code
	asl	r0
	call	core
	mov	worklo,r0
	mov	(pc)+,(r0)+	;Put return instr at beginning of code
	return
	mov	r0,pcc
	mov	r0,compare	;Store entry addr of code
.Sbttl	Key Comparison Code Generation

;	branch  offset=375
;	m=0, i=0
;B:	j=0
;	k=order(i)
;a:	j=j+len(i)
;	i=i+1
;	if i >= keycnt then c
;	if k = order(i) then a
;c:	if instr alphanumeric, put in CALL @#ALPCOM, .WORD LENGTH, BNE
;	instr = (if k=> ascend then cmp (r0)+,(r1)+ else cmp (r1)+,(r0)+)
;	if m is odd then generate one byte comparison, j=j-1, m=m+1
;	for 0 < ????? <= int(j/2)
;		generate word comparison, set transl arrays to
;		swap bytes for this word
;	if rem(j/2)<>0 generate byte comparison
;	if i >= keycnt then d
;	m=m+j, go to b
;d:

	m=	%3		;Start of series of same-order keys

.Enabl	lsb

	mov	#375,brncho
	mov	trnslo,tmpsto
	clr	m
	clr	i
b::
	clr	j
	movb	ordr$k(i),k
	mov	i,-(sp)
a::
	mov	i,r4
	asl	r4
	add	keylen(r4),j	;Accumulate length of key series
	inc	i
	cmpb	k,#1		;Finish accumulation on any alphanum compare
	beq	alp
	cmp	keycnt,i	;Finish accumulation if no more keys
	ble	c
	cmpb	ordr$k(i),k	;New key same order as old one?
	beq	a		;A if yes
	br	c

alp:
	tst	(sp)+
	call	gencal		;Generate call for alphanumeric compare
	br	60$
c::
	mov	cmpr01,instr	;Setup ascending or descending comparison
	tst	k
	beq	10$
	mov	cmpr10,instr
10$:
	mov	(sp)+,r2
	asl	r2
	add	#kstpos,r2
	bit	#1,m
	beq	20$
	bis	#100000,instr	;Make it a byte comparison
	call	gencmp
	bic	#100000,instr	;Back to word comparisons
	dec	j
	inc	m
	inc	(r2)
	add	#2,tmpsto
	dec	maxkey*2(r2)
	bgt	20$
	tst	(r2)+
20$:
	mov	m,-(sp)
	mov	i,-(sp)
	mov	j,-(sp)
	clr	-(sp)		;J=int(j/2)    (sp)=rem(j/2)
	ror	j
	rol	(sp)
30$:
	dec	j
	blt	40$
	call	gencmp		;Generate comparison for this byte pair
	call	70$
	mov	r4,r0
	mov	r5,r3
	call	70$
	mov	(r0),-(sp)
	mov	(r4),(r0)
	mov	(sp)+,(r4)
	mov	(r3),-(sp)
	mov	(r5),(r3)
	mov	(sp)+,(r5)
	br	30$
40$:
	tst	(sp)+		;If rem(j/2) <> 0 generate byte instr
	beq	50$
	bis	#100000,instr
	call	gencmp
	add	#2,tmpsto
50$:
	mov	(sp)+,j
	mov	(sp)+,i
	mov	(sp)+,m
60$:	cmp	keycnt,i
	ble	d
	add	j,m
	br 	b

70$:
	mov	(r2),r4
	asl	r4
	mov	r4,r5
	add	trnsli,r4
	add	trnslo,r5
	inc	(r2)
	tstb	tsrt$c
	beq	80$
	mov	tmpsto,r5
	add	#2,tmpsto
80$:
	dec	maxkey*2(r2)
	bgt	90$
	tst	(r2)+
90$:
	return

.Dsabl	lsb


;Generate comparison routine GENCAL
;	Move CALL @#ALPCOM to (pcc)+
;	Synthesize BNE offset, etc as per GENCMP

Gencal::
	mov	r0,-(sp)
	mov	pcc,r0
	mov	#4737,(r0)+	;CALL @# instruction
	mov	#alpcom,(r0)+	;destination.
	mov	j,(r0)+		;.WORD length of string
	sub	#2,brncho	;Branch is one pair further back.
	cmp	#200,brncho
	ble	10$
	mov	#374,brncho	;Don't branch back to ALPCOM address!
10$:	br	gen0


;Generate comparison routine GENCMP
;	Move instr to (pcc)+
;	Synthesize BNE offset.  Move to (pcc)+
;	branch offset = branch offset -2
;	If branch offset +ve branch offset=375

Gencmp::
	mov	r0,-(sp)
	mov	pcc,r0
	mov	instr,(r0)+
gen0:	movb	brncho,(r0)+
	sub	#2,brncho
	cmp	#200,brncho
	ble	10$
	mov	#375,brncho
10$:	movb	1(pc),(r0)+
	bne	20$
20$:	mov	r0,pcc
	mov	(sp)+,r0
rtspc::	return


d::	mov	rtspc,@pcc
	add	#2,pcc
	mov	pcc,workhi

;This section sets up the translation arrays to make room
; for sequence nos if req'd

	tstb	sqno$c		;Are seq nos reqd?
	beq	30$
	mov	reclen,r0	;Move RECLEN words beginning at end
	mov	r0,r2		;Save for use as a counter
	asl	r0		;Convert to word offset
	add	trnslo,r0	;Operate on array whose address is in TRNSLO
	mov	r0,r1
	add	extra,r1	;Shift along EXTRA words
	add	extra,r1
10$:	mov	-(r0),-(r1)
	dec	r2		;Loop on no. of characters in record
	bgt	10$
	mov	trnslo,r0	;Put in mapping info on sequence nos
	clr	r1
20$:	mov	r1,(r0)
	add	keylnb,(r0)+	;Seq nos are mapped to the end of the record
	inc	r1		; in memory
	cmp	extra,r1
	bgt	20$
30$:
.Sbttl	Open Files, Fetch Handlers

;The /R switch is a rather drastic measure, check if
; the user really wants to use it.

	tstb	deli$c		;Was /R typed?
	beq	opnfil
	bit	#chain$,@#jsw	;If SORT has been chained to, print no warning
	bne	opnfil
	.rctrlo
	.print	gccbp
	.print	#rusure
	.ttyin			;Get rid of rest of the line
	mov	r0,r1
40$:	.ttyin
	cmp	#lf,r0
	bne	40$
	cmp	#'Y,r1
	beq	opnfil
	jmp	stcmdd

;This code selects which two file specifications will make up
; the two files needed for scratch space. any two will do, as long
; they are disc files, but if scratch files are specified, they must be
; disc files.

;	ofile,scr1:,scr2:=ifile

.enabl	lsb

opnfil::
	.gtim	#pra,#stime	;Get time at start of actual sort

	tst	filblk+outfile
	bne	10$
	  call	fatal
	  .word	noofil
10$:
	tst	filblk+infile
	bne	20$
	  call	fatal
	  .word	noifil
20$:
	tst	filblk+skr2	;Is scr2: present?
	beq	60$
	.dstatus #cblk,#filblk+skr2 ;Is it a disc?
	bit	#discdev,cblk	;CSISPC has checked for illegal
	bne	40$		; devices, so no need to do so now.
	  call	fatal
	  .word	sfilnd
40$:
	mov	#2,scr1		;This is the first scratch file, store
				; chan #
	tst	filblk+skr1	;scr1: must be present
	beq	adskr1		;Add it if it isn't
	.dstatus #cblk,#filblk+skr1
	bit	#discdev,cblk
	bne	50$
	  call	fatal
	  .word	sfilnd
50$:
	mov	#1,scr2		;Put its chan # away
	br	sfac
60$:	tst	filblk+skr1	;scr2: was not present, is scr1: there
	beq	90$
	.dstatus #cblk,#filblk+skr1
	bit	#discdev,cblk
	bne	70$
	  call	fatal
	  .word	sfilnd
70$:
	mov	#1,scr1
	.dstatus #cblk,#filblk+outfile ;ofile is present, but is it a disc?
	bit	#discdev,cblk
	beq	80$
	clr	scr2		;It is.
	tstb	tsrt$c
	beq	sfac
	tstb	keys$c
	beq	adskr2		;Add a scratch file
	br	sfac
80$:
	tstb	deli$c		;The only file left to scratch around
	beq	adskr0			; in is the input file which requires
	.dstatus #cblk,#filblk+infile	; that it be a disc and the /R switch
					; be in effect.
	bit	#discdev,cblk
	beq	adskr2		;Need another scratch file
	mov	#3,scr2
	br	sfac
90$:	.dstatus #cblk,#filblk+outfile	;scr1: was not present, check what's
	bit	#discdev,cblk		; left, namely ofile and ifile
	beq	adskr1
	clr	scr1
	br	80$

adskr0::
	tst	filblk+skr1	;If already have first, try for second.
	bne	adskr2
adskr1:
	mov	#^rDK,filblk+skr1
	br	20$
adskr2:
	mov	#^rDK,filblk+skr2
	br	20$

.dsabl	lsb

;This section loads the input file handler, looks up the input file,
; then loads the handlers, and enters the output files.

Sfac::
	mov	workhi,worklo		;Load handlers after the current work
	.fetch	worklo,#filblk+infile	; area.  Fetch input file handler
	bcc	5$
	  call	fatal
	  .word	fetche			;Shouldn't occur
5$:
	mov	r0,worklo		;Save addr after handler
	.lookup #pra,#3,#filblk+infile
	bcc	10$
	  call	fatal
	  .word	notfnd
10$:
	mov	r0,filsiz	;Save filesize for later use
	tstb	xspc$c		;If records are to be padded with
	beq	30$		; blanks then allocate 25% more
				; filespace to accomodate blanks.
	asr	r0		;Calc 25% of filsiz
	asr	r0
	bne	20$
	inc	r0		;If file<4 blocks long, add 1 block
20$:	add	r0,filsiz	;+25%
30$:	.dstatus #cblk,#filblk+infile
	bit	#discdev,cblk
	bne	40$
	clr	filsiz
40$:	mov	fn1,filblk+skr1+2 ;Put names of scratch files in their
				  ; respective blocks
	clr	filblk+skr1+4
	mov	fn2,filblk+skr2+2
	clr	filblk+skr2+4
	clr	r2
;This section attempts to calculate the file sizes for
; scratch files when tag sorting

.03::
	mov	filsiz,skrsiz
	mov	filsiz,osize
	mov	#9.,r0		;Now calc # of bytes in file
	clr	filsiz+2	;And divide by the record length
10$:	clc
	rol	filsiz		;To get # of records likely to be in
	rol	filsiz+2	; file
	dec	r0
	bgt	10$
	mov	reclen,tsiz	;Work out chars/rec incl. crlf
	add	#2,tsiz
	mov	#ab2,r5
	call	divide		;Educated guess at # records in file
	tstb	dibl$c
	beq	.04
	tst	dibol		;Use /D switch count to calc expected
	bne	.04		; number of records in file
	tst	dibol+2
	beq	.04
	mov	dibol,xpectr
	mov	dibol+2,xpectr+2
.04:	tstb	tsrt$c		;Calc file lengths required for
	beq	entscr		; scratch files and output file for a
	mov	keylnb,reclen+2	; tag sort
	tstb	sqno$c
	beq	10$
	add	extra,reclen+2	;Allow for tags
10$:	add	#2,reclen+2
	mov	#ab8,r5
	call	multiply
	add	#777,skrsiz
	adc	skrsiz+2
	tstb	keys$c
	bne	20$
	sub	keylnb,reclen+2	;No keys in output file
20$:	mov	#ab9,r5
	call	multiply
	add	#777,osize
	adc	osize+2
	mov	#ab10,r5
	call	multiply
	mov	#ab11,r5
	call	divide
	add	tmpsto,skrsiz
	adc	skrsiz+2
	add	tmpsto+2,skrsiz+2
	mov	#ab12,r5
	call	multiply
	mov	#ab11,r5
	call	divide
	add	tmpsto,osize
	adc	osize+2
	add	tmpsto+2,osize+2
	mov	#9.,r0
30$:	clc
	ror	skrsiz+2
	ror	skrsiz
	clc
	ror	osize+2
	ror	osize
	dec	r0
	bgt	30$

	mov	skrsiz,r0	;Don't know why, but fouls less often
	clc			; if add another eighth.
	ror	r0
	asr	r0
	asr	r0
	adc	r0		;Err on the high side.
	add	r0,skrsiz

Entscr::
	mov	#filblk,r1	;Init ptr to output file blocks
10$:	tst	(r1)
	beq	40$		;40$ if no file in this descriptor block
	.fetch	worklo,r1	;Something there fetch it
	bcc	20$
	  call	fatal
	  .word	fetche
20$:	mov	r0,worklo
	tst	10(r1)		;Did the user specify a filesize?
	bne	30$		;If not allocate files FILSIZ long.  If input
	mov	skrsiz,10(r1)	; file isn't a disc then a 0 length enter will
	cmp	#filblk+outfile,r1 ; be done.
	bne	30$
	mov	osize,10(r1)
30$:	.enter	#pra,r2,r1,10(r1)
	bcc	40$
	  call	fatal
	  .word	noxspc		;Enter can only fail due to lack of disc space
40$:	add	#10.,r1		;Advance file ptr to next file block
	inc	r2		;Move to next channel
	cmp	#2,r2		;Channel 2 is the final channel
	bge	10$
.Sbttl	Miscellaneous Calculations, etc.

;Now remove the USR to get maximum amount of core,
; and work out how much is obtained.

Setmem::
	.settop	#-2		;Absolute top
	mov	r0,workhi	;Save hi-addr that is obtained
	sub	worklo,r0	;Work out how many bytes obtained
	clc			;Convert to # of words
	ror	r0
	mov	r0,r1
	.rept	4		;Calculate buffersize for 4 buffers occupying
	asr	r0		;25% of memory. 2 for input, 2 for output
	.endr
	add	#200,r0		;Round up
	bic	#377,r0		;Truncate to an even multiple of 256 words
	cmp	#400,r0
	blt	5$
	mov	#400,r0
5$:	mov	r0,bsiz1	;Store size for later use
	asl	r0		;Total space req'd for buffers(in words)
	asl	r0
	sub	r0,r1
	asl	r1		;Space left over for Sort Tree in bytes
	sub	keylnb,r1	;Allow storage for one key plus one
	sub	#2,r1		;Word used by initial run algorithm
	mov	r1,tsiz
	mov	reclen,reclen+2	;Work out space req'd to store one record
	tstb	tsrt$c		;In memory. if key-sort then record length
	beq	10$		;Is total length of keys.
	mov	keylnb,reclen+2	;Store tot length of keys.
	tstb	sqno$c
	beq	10$
	add	extra,reclen+2
10$:	mov	reclen+2,olen	;Store max record output length
	add	#11,reclen+2	;4 extra words are required per record for
				; tree maintainence
	bic	#1,reclen+2	;And round off to an even # of bytes
	mov	#ab1,r5		;Calc # of records which will fit in memory,
	call	divide		; ie # of external nodes in tree
	asl	p
	mov	#ab3,r5
	call	divide
	asr	p
	tst	rem
	beq	20$
	inc	xpectr		;Last run might be a partial run.
20$:	mov	xpectr,r1	;Calculate expected size of run-index file
	add	#37,r1
	clc
	ror	r1
	.rept	4
	asr	r1
	.endr
	mov	r1,rnfsiz
	mov	#ab13,r5	;Over allocate LEEWAY percent
	call	multiply
	mov	#ab11,r5
	call	divide
	add	tmpsto,rnfsiz
	cmp	rnfsiz,#rbsize/200
	blos	mmo
	call	ernf
	bcc	mmo
	  call	fatal
	  .word	noxspc
;This next section calculates the maximum merge order given the amount
; of memory available.  As a direct formula would require the
; floating point evaluation of square roots, and is rather complex
; anyway, the algorithm calculates the minimum space req'd for an O
; order merge.  When the next order merge requires more memory than
; is available, the maximum merge order has been found.

;The minimum space req'd is given by

;	 M = 256 * (SQRT(2 * O + 2) + O + 1) + O * R

; where M is the amount of memory in WORDS, R the length of an external node
; in BYTES. A table of fixed point values for SQRT(2*O+2) is maintained in
; IBFRAC

Mmo::
	mov	#1,maxmo
	mov	workhi,avail
	sub	worklo,avail
	clc
	ror	avail		;AVAIL contains the # of avail words of memory
10$:	mov	maxmo,r0	;Calc offset to IBFRAC values
	dec	r0
	asl	r0
	asl	r0
	movb	ibfrac+2(r0),tmpsto+1 ;Get 256*(sqrt(2*O))
	movb	ibfrac+1(r0),tmpsto
	mov	maxmo,r3	;Work out O*R
	mov	reclen+2,r5
	call	mlr5r3
	swab	r3		;256*(O+1) in R3
	add	r3,r5
	add	tmpsto,r5
	cmp	avail,r5	;Can this order of merge be done with this
				; amount of memory?
	blt	20$
	inc	maxmo		;Yep, raise by one.
	cmp	maxmo,#maxmrg
	bgt	20$
	br	10$
20$:	dec	maxmo		;Couldn't do it, back off one order

;If the output file is being used as a scratch file, it is advantageous
; to jiggle it so that after the last merge the data is in the output file
; and thus avoid a wasteful copy operation.  If the educated guess
; is out by an awful lot a copy may still be on the cards.

	cmp	scr2,#3		;If input file is a scratch file, have no
	beq	30$		; option.
	mov	xpectr,runs	;Calc expected # of passes
	call	optimm
	ror	r0
	bcs	30$
	mov	scr1,-(sp)	;If an even # of passes initial runs go to
	mov	scr2,scr1	; outfil
	mov	(sp)+,scr2
30$:	jmp	pass1
.Sbttl	Alpcom - Alphanumeric (Dictionary) Order Compare

Alpcom::
	clr	-(sp)		;Word for TST (SP)+ to determine flags at end.
	mov	r5,-(sp)	;No stray registers at this point blow it.
	mov	r2,-(sp)
	mov	@6(sp),r5	;Byte count for this search
	add	#2,6(sp)	;Skip over byte count on return

	mov	r0,-(sp)	;Return with pointers advanced over these
	add	r5,(sp)		; bytes regardless of the comparison.
	mov	r1,-(sp)
	add	r5,(sp)

	mov	r0,-(sp)
	call	advaln		;Returns in R0 # chars to skip to next alpha
	mov	r0,-(sp)	; numeric character.  0 if would be >R5 value.
	mov	r1,r0
	call	advaln		;Same for R1 value
	add	r0,r1		;Reset R1 to skip non-alphanumerics
	cmp	r0,(sp)		;See which is larger
	bge	5$
	mov	(sp),r0
5$:	sub	r0,r5		;Reduce record scan by number non alphas.
	mov	(sp)+,r0	;Variation for R0
	add	(sp)+,r0	;Original R0
10$:
	movb	(r1)+,r2
	movb	alptab(r2),-(sp);Convert to upper case, sorting sequence
	movb	(r0)+,r2
	cmpb	alptab(r2),(sp)+
	bne	20$
	dec	r5
	bne	10$
	br	40$		;Equality.
20$:
	bge	30$
	dec	10(sp)		;Make final compare CMP #0,#1
	br	40$
30$:
	inc	10(sp)		;Make final compare CMP #1,#0
40$:
	mov	(sp)+,r1
	mov	(sp)+,r0
	mov	(sp)+,r2
	mov	(sp)+,r5
	tst	(sp)+
	return

Advaln::			;Starts with pointer in R0.  Searches for
	mov	r0,-(sp)	; next alphanumeric character in string,
	mov	r1,-(sp)	; returning the number of characters which
10$:				; were not alphanumeric.  If this number be
	movb	(r0)+,r1	; greater than R5, zero is returned (ie no
	tstb	captab(r1)	; alphanumerics in this string).
	beq	10$

	mov	(sp)+,r1
	sub	(sp)+,r0
	dec	r0
	cmp	r0,r5
	blo	30$
	clr	r0
30$:	return

;Sorting Sequence Table for Alphanumeric Sorting

Alptab::
	.byte	 0, 1, 2, 3, 4, 5, 6, 7		; 0  1  2  3  4  5  6  7
	.byte	10,11,12,13,14,15,16,17		;10 11 12 13 14 15 16 17
	.byte	20,21,22,23,24,25,26,27		;20 21 22 23 24 25 26 27
	.byte	30,31,32,33,34,35,36,37		;30 31 32 33 34 35 36 37
	.byte	40,'!,'@,'#,'$,'%,'&,''		;40  !  @  #  $  %  &  '
	.byte	'(,'),'*,'+,',,'-,'.,'/		; (  )  *  +  ,  -  .  /
	.byte	'0,'1,'2,'3,'4,'5,'6,'7		; 0  1  2  3  4  5  6  7
	.byte	'8,'9,':,';,'<,'=,'>,'?		; 8  9  :  ;  <  =  >  ?
	.byte	'@,'A,'B,'C,'D,'E,'F,'G		; @  A  B  C  D  E  F  G
	.byte	'H,'I,'J,'K,'L,'M,'N,'O		; H  I  J  K  L  M  N  O
	.byte	'P,'Q,'R,'S,'T,'U,'V,'W		; P  Q  R  S  T  U  V  W
	.byte	'X,'Y,'Z,'[,'\,'],'^,'_		; X  Y  Z  [  \  ]  ^  _
	.byte	'`,'A,'B,'C,'D,'E,'F,'G		; `  a  b  c  d  e  f  g
	.byte	'H,'I,'J,'K,'L,'M,'N,'O		; h  i  j  k  l  m  n  o
	.byte	'P,'Q,'R,'S,'T,'U,'V,'W		; p  q  r  s  t  u  v  w
	.byte	'X,'Y,'Z,'{,'|,'},'~,177	; x  y  z  {  |  }  ~  177

Captab::
	.byte	0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0 ;  0-17
	.byte	0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0 ; 20-37
	.byte	0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0 ; space - /
	.byte	1,1,1,1,1,1,1,1, 1,1,0,0,0,0,0,0 ; '0-'9, :-?
	.byte	0,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1 ; @, A-G, H-O
	.byte	1,1,1,1,1,1,1,1, 1,1,1,0,0,0,0,0 ; P-W, X-Z, [-_
	.byte	0,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1 ; `, a-g, h-o
	.byte	1,1,1,1,1,1,1,1, 1,1,1,0,0,0,0,0 ; p-w, x-z, {-rubout
.Sbttl	Calculate optimum merge order

;Routine calculates the optimum merge order given the # of runs
; and returns the optimum order in R1, and the # of passes
; required to complete the merge in R0.
; It searches the table OPTMER:
;	OPTMER(Passes,Order of Merge) = The maximum number of runs
; which can be sorted using a given order of merge in a certain
; number of passes.
; The table is searched with Order of Merge varying most rapidly,
; to find the minimum number of passes in which the merge can be done, and
; the order of merge reqd to complete the merges with the least amount
; of computation.

Optimm::
	clr	r0
10$:	clr	r1
20$:	mov	r1,r2
	asl	r2
	asl	r2
	asl	r2
	add	r0,r2
	add	r0,r2
	cmp	runs,optmer(r2)
	ble	40$
	inc	r1
	cmp	maxmo,r1
	ble	30$
	cmp	#maxmrg-1,r1
	bge	20$
30$:	inc	r0
	cmp	#4,r0
	bgt	10$
40$:	inc	r0
	inc	r1
	return
.Sbttl	Initial Distribution Pass

;The distribution pass uses a Replacement/Selection sort, which
; generates runs of about twice the length which will fit in memory.
; It also facilitates overlap of I/O and computation.
; The merge phase employs a simple N-way merging process which
; firstly minimizes I/O time by processing the runs generated
; in the distribution phase in the least number of passes, and
; secondly minimizes computation by using the least order of merge
; which can accomplish this.
; The ratio of sizes of input buffers to output buffers is also
; adjusted to minimize seeks.
; "The Art of Computing" Vol 3 "Sorting and Searching" by Donald Knuth
; is recommended reading for the distribution phase, and briefly describes
; some of the techniques used in the merge phase.


$bufer::call	fatal
	.word	buferr



Pass1::
	mov	#3,in		;Setup I/O channels
	mov	scr1,out
	movb	#-1,fstp$c	;Indicate first pass
	mov	worklo,bottom	;Setup I/O buffers
	$outbuf	#pra,out,#obuf,bsiz1,bottom
	bcs	$bufer
	mov	r0,bottom
	$inbuf	#pra,in,#ibufs,bsiz1,bottom
	bcs	$bufer
	mov	r0,lastkey
	add	#2,r0
	add	keylnb,r0
	inc	r0
	bic	#1,r0
	mov	r0,bottom
	mov	#ibufs,bufhed
$r1::
	call	rrf
	mov	#getr,getrec
	mov	#putr,putrec
	clrb	eof$c
	tstb	tsrt$c
	beq	10$
	tstb	sqno$c
	beq	10$
	mov	#getrs,getrec
10$:
	jsr	r5,initt	;Setup replacement selection tree
	.word	bottom,p,base
	clr	rmax
	clr	rc
	clr	@lastkey	;If LASTKEY=0 then KEY(LASTKEY)=infinity
	clrb	nomg$c		;Indicates no merging need be done.
	mov	base,loc.x1
	add	reclen+2,loc.x1
	clr	totcnt		;Keep a count of the total # of records
	clr	totcnt+2
$r2::
	cmp	rq,rc		;Does this record belong to the current run?
	beq	$r3
	tst	rc
	beq	10$
	mov	reccnt,r1	;Store record count for last run output
	call	ptwd
	mov	reccnt+2,r1
	call	ptwd
10$:	cmp	rq,rmax
	ble	20$
	jmp	passm
20$:	jsr	r5,posn
	.word	obuf,6
	call	ptwd		;Store file position index for new run
	mov	r2,r1
	call	ptwd
	clr	reccnt		;Init record count for new run
	clr	reccnt+2
	mov	rq,rc
$r3:
	tst	rq
	beq	$r4
	call	@putrec
	add	#1,reccnt
	adc	reccnt+2
	setup	<q,lastkey,keylnb>
	add	#10,r0
	add	#2,r1
10$:	movb	(r0)+,(r1)+
	dec	r2
	bgt	10$
	mov	#-1,@lastkey
$r4:
	tstb	eof$c
	bne	10$
	jsr	r5,@getrec
	.word	bufhed,q
	bcc	40$		;Has EOF been reached yet?
	movb	#-1,eof$c
10$:	mov	rmax,rq		;Yes, see if we can write the data out to
	inc	rq		; the output file without using scratch files
	tst	@lastkey	;Check if anything has been output yet.  If
	bne	$r5		; not everything fits in core, and the output
	com	@lastkey
	$purge	out		; can be directly rerouted to the output file
	clr	out
	asl	bsiz1
	$outbuf	#pra,out,#obuf,bsiz1,worklo
	bcc	20$
	  jmp	$bufer
20$:	tstb	tsrt$c
	beq	30$
	tstb	keys$c
	bne	30$
	mov	trnslo,r0
	add	extra,r0
	add	extra,r0
	mov	#-1,(r0)
30$:	movb	#-1,nomg$c	;Indicate that no merging is necessary
	br	$r5
40$:	add	#1,totcnt
	adc	totcnt+2
	tstb	dibl$c
	beq	50$
	cmp	totcnt,dibol
	bne	50$
	cmp	totcnt+2,dibol+2
	bne	50$
	movb	#-1,eof$c
50$:	tst	@lastkey	;If KEY(Q)<LASTKEY then if RQ>RMAX then
	beq	60$		; RQ=RQ+1, if RQ>RMAX then RMAX=RQ
	mov	q,r0
	mov	lastkey,r1
	add	#10,r0
	add	#2,r1
	call	@compare
	bge	$r5
60$:	inc	rq
	cmp	rq,rmax
	ble	$r5
	mov	rq,rmax
$r5:
	call	update		;Insert new record into tree, and find new
	jmp	$r2		; winner.


passm::
	mov	totcnt,reccnt
	mov	totcnt+2,reccnt+2
	call	crf
	$close	in
	call	close
10$:	tstb	nomg$c
	bne	tidyup
	tstb	tsrt$c
	beq	20$
	tstb	keys$c
	beq	mpass
20$:	cmp	#1,rmax
	bne	mpass
	jmp	mergef

tidyup::
	mov	limit+2,r0	;Contract core so USR can fit in without
	call	coreae		; swapping other junk out
	.lock
	.purge	#1		;Get rid of scratch files
	.purge	#2
	.purge	#4		;Get rid of run-index file if open
	.close	#3		;Close input file
	tstb	deli$c		;/R, ie /R switch?
	beq	20$
	cmp	filblk+infile,filblk+outfile	 ;Check if input and output
	bne	10$				 ; file have same name, to
	cmp	filblk+infile+2,filblk+outfile+2 ; prevent deleting the output
	bne	10$				 ; file.
	cmp	filblk+infile+4,filblk+outfile+4
	beq	20$
10$:	.delete	#pra,#3,#filblk+infile
20$:	.close	#0
	.releas	#filblk+infile
	.releas	#filblk
	.releas	#filblk+skr1
	.releas	#filblk+skr2
	.unlock
	jmp	stats

mpass::
	mov	rmax,runs
	$purge	in
.Sbttl	Merging Phase

;This section does the actual merging. it allocates buffers
; determines the merge order etc

	clrb	fstp$c
	mov	#getr,getrec	;Record fetch, and store routines to be
	mov	#putr,putrec	;Used by the merge phase
	setup	<trnsli,trnslo,reclen>;Records coming in are now
	add	extra,r2	;The same as records going out
10$:	mov	(r1)+,(r0)+	; - except if final pass, and keys must
	dec	r2		; be stripped
	bgt	10$
	tstb	tsrt$c
	beq	lop
	mov	keylnb,reclen
	tstb	sqno$c
	beq	lop
	add	extra,reclen
lop::	call	optimm		;This is the befinning of a pass
	mov	r1,p		;Optimum order of merge to P
	clr	chkcnt		;CHKCNT is used to keep an audit
	clr	chkcnt+2	; on the number of records merged
	call	rrf		;Go to beginning of run-index file
	mov	scr1,r2		;Setup I/O chans - input from scratch
	mov	scr2,scr1	; file just written
	mov	r2,scr2
	mov	scr1,out
	mov	scr2,in
	cmp	#1,r0		;Is this the final pass?
	bne	20$		;If so, and outfile doesn't contain data
	tstb	tsrt$c		;Tag sort?
	beq	10$
	tstb	keys$c		;Yes - are keys to be discarded?
	bne	10$
	mov	trnslo,r0	;Yes, they are.
	add	extra,r0
	add	extra,r0
	mov	#-1,(r0)	;Put a -1 in the column where the keys begin
10$:	tst	in		; from the last merge pass, or initial
				; distribution
	beq	20$		;Rerout output to final output file.
	clr	out
20$:	mov	worklo,bottom
	mov	avail,tsiz	;Calc size for output buffers
	dec	r1		;Using buffer allocation to optimize seeks
	asl	r1
	asl	r1
	mov	ibfrac(r1),tmpsto
	mov	ibfrac+2(r1),tmpsto+2
	add	#2,tmpsto+2
	mov	#ab4,r5
	call	divide		;Divide amt of mem by appropriate fraction
	bic	#377,tmpsto	;Trunc buffersize to a multiple of 512 bytes
	$outbuf	#pra,out,#obuf,tmpsto,bottom
	bcc	30$
	  jmp	$bufer
30$:	mov	r0,bottom
	clr	runso
;This bit works out how many runs are left and merges P runs at a time
; until there are less than P runs, when it merges what are left.  For each
; stage a binary tree is set up for comparison of records from the runs to be
; merged.

Lom::
	mov	p,p+2
	cmp	#1,p+2
	blt	10$
	inc	p+2
10$:	jsr	r5,initt	;Setup merge tree
	.word	bottom,p+2,basem
	mov	r0,bottom
	mov	p+2,r0		;Zero record counts for buffer headers
	mov	#ibufs+rekcnt,r1
20$:	clr	(r1)+
	clr	(r1)
	add	#bhsize-1*2,r1
	dec	r0
	bgt	20$
	mov	p,r0		;Can a full P order merge be done?
	cmp	r0,runs
	ble	30$
	mov	runs,r0		;No, just do remainder
30$:	sub	r0,runs		;Calculate how many runs left when this merge
	mov	#ibufs,r2	; finished.
	mov	r0,r3
40$:	call	gtwd
	mov	r1,wdpnt(r2)
	mov	r1,bytcnt(r2)
	call	gtwd
	mov	r1,blkpnt(r2)
	call	gtwd
	mov	r1,rekcnt(r2)
	call	gtwd
	mov	r1,rekcnt+2(r2)
	mov	#-1,(r2)	;Init buffer status
	add	#bhsize*2,r2	;Advance to next buffer header
	dec	r3
	bgt	40$
	mov	workhi,tsiz	;Calc size of input buffers, which will fit
	sub	bottom,tsiz	;Into the amount of memory left
	mov	r0,tmpsto
	clr	tmpsto+2
	mov	#ab5,r5
	call	divide
	bic	#777,tmpsto	;Trunc to multiple of 512 bytes
	mov	tmpsto,r4
	asr	r4
	mov	r4,r5
	swab	r5		;Calculate block increment for reads
	mov	r0,r3		;Now allocate buffers and set reading
	mov	#ibufs,r1
	mov	bottom,r2
50$:	mov	r4,size(r1)
	mov	r2,bufadr(r1)
	add	r2,wdpnt(r1)	;Work out where run starts in this buffer
	mov	r5,blkinc(r1)
	.read	#pra,in,r2,r4,blkpnt(r1) ;Set block reading
	bcc	60$
	  call	fatal
	  .word	hdwie
60$:
	asl	r0		;Calc # of bytes of usable data in buffer
	sub	bytcnt(r1),r0
	inc	r0		;Allow for GETR not knowing there is
	mov	r0,bytcnt(r1)	; data in buffer
	add	r4,r2		;Advance ptr to beginning of next
	add	r4,r2		; buffer
	add	#bhsize*2,r1
	dec	r3		;Loop on # of buffers
	bgt	50$
	.wait	in		;Wait for transfers to finish
	clr	tmpsto		;Now use TMPSTO to count # of recs merged
	clr	tmpsto+2
	jsr	r5,posn
	.word	obuf,6
	call	ptwd		;Store run-index to new run
	mov	r2,r1
	call	ptwd
merge::
	jsr	r5,treeo	;Merge the runs.
	.word	basem,mirtn,mortn
	bcs	10$
	add	#1,tmpsto
	adc	tmpsto+2
	add	#1,chkcnt
	adc	chkcnt+2
	br	merge
10$:	inc	runso		;Merge of P runs finished
	mov	tmpsto,r1	;Store record count of run just merged
	call	ptwd
	mov	tmpsto+2,r1
	call	ptwd
	tst	runs		;Anything left to merge?
	ble	20$
	mov	basem,bottom	;Yes, reallocate input buffers + trees
	jmp	lom		;And re-init trees, and do it again
20$:	call	close
	cmp	totcnt,chkcnt	;Check if any records lost in merge
	bne	30$
	cmp	totcnt+2,chkcnt+2
	beq	40$
30$:	mov	chkcnt,totcnt
	mov	chkcnt+2,totcnt+2
	  call	fatal		;Should this be a fatal error?
	  .word	lost		; - especially with chaining facility.
;;;;	.print	#lost

40$:	cmp	runso,#1	;All merged? (ie only 1 final run?)
	beq	mergef
	mov	runso,runs
	call	crf
	jmp	lop
.Sbttl	Finish  Off

;This bit determines whether a final copy needs to be done.
; It will only be done if the estimates made in the 
; "miscellaneous calculations" section (just after opening the
; input file) are way out, and can only happen when the output file
; is on disc.  If the file containing the data is on the same disc as the
; output file a .RENAME will be done to save copying.

Mergef::
	tst	out		;Is the data already in the output file?
	bne	10$
	jmp	tidyup		;Yes
10$:	mov	out,in
	clr	out
	mov	in,r0		;Calc which file spec block describes input
	mov	r0,r1		;Multiply chan # by 10.
	asl	r1
	asl	r1
	add	r0,r1
	asl	r1
	cmp	filblk+outfile,filblk(r1) ;Outfile and scratch file containing
	bne	copy		; data on same device?
	mov	limit+2,r0	;Contract core so USR fits in and stays in
	call	coreae
	.close	in		;Close scratch file so it can be renamed
	mov	#renblk,r2	;Copy old file name to rename block
	add	#filblk,r1
	.rept	4
	mov	(r1)+,(r2)+
	.endr
	.purge	#0
	.rename	#pra,#0,#renblk	;Rename appropriately
	bcc	20$
	  jmp	fatal
	  .word	erenme
20$:
	jmp  tidyup

Copy::
	mov	worklo,r0	;Contract core to close scratch file
	call	coreae		; at the correct size for the copy operation
	.close	in		;Close file at correct size
	mov	in,r0		;Work out offset to file names block
	asl	r0		;For subsequent lookup
	mov	r0,r5
	asl	r0
	asl	r0
	add	r0,r5
	add	#filblk,r5	;Convert to address of file name block
	.lookup	#pra,in,r5	;Open file for input
	.settop	#-2		;Re-expand core for copy operation
	mov	r0,workhi
	mov	workhi,r1	;Work out amount of memory available
	sub	worklo,r1
	bic	#777,r1		;Trunc to a multiple of 512 bytes
	clc
	ror	r1		;Conv to # of words
	mov	r1,r2		;Calc # of blocks to read/write
	swab	r2		;At a time (block increment)
	clr	r3		;Block ptr
10$:
	.readw	#pra,in,worklo,r1,r3 ;Read a lump
	bcc	20$
	tstb	@#emterr	;Check if eof
	beq	50$
	  call	fatal
	  .word	hdwie
20$:
	mov	r0,r4		;Put # words read in r4
	.writw	#pra,out,worklo,r4,r3 ;Spew the stuff back out again
	bcc	40$
	tstb	@#emterr	;Oh no! something went wrong
	beq	30$
	  call	fatal
	  .word	hdwoe		;Hard error
30$:
	jmp	xspce		;No room in output file
				;It would happen now!
40$:
	add	r2,r3		;Bump block ptr
	br	10$		;Und noch mal, weil's so gut war!!!
50$:
	mov	limit+2,r0	;Re-contract core for USR
	call	coreae
	.close	in		;Close and delete scratch file which
	.delete	#pra,in,r5	;Was made permanent
	jmp	tidyup		;All done finish off.
.Sbttl	Statistics

;This section prints out sort statistics of the form:
; nnnnn RECORDS SORTED <in hh hr, mm min, ss sec>
; hr, min both appear only if the sort takes long enough to
; warrant these fields.  The time is only printed if a KW11L
; clock is present.  Note the bit in the monitor
; tables must be patched to correctly reflect whether or not
; the clock is 50 Hz or 60 Hz

Stats::
	bit	#chain$,@#jsw
	beq	10$
	jmp	stcmdd		;Don't print statistics if chained to
10$:	.rctrlo
	mov	reccnt,tmpsto	;Reccnt has total count of records read
	mov	reccnt+2,tmpsto+2
	call	nprint
	cmp	reccnt,totcnt	;If any records lost print out # left over
	bne	20$
	cmp	reccnt+2,totcnt+2
	beq	30$
20$:	.ttyout	#'(
	mov	totcnt,tmpsto
	mov	totcnt+2,tmpsto+2
	call	nprint
	.ttyout	#')
30$:	.print	#rsrtd
	mov	@#rmon,r1	;Check if KW11L present
	mov	config(r1),r1
	bit	#kw11l,r1
	beq	estats		;Estats if not
	mov	#50.,ticsec	;50 or 60 Hz clock?
	bit	#clockt,r1
	bne	40$
	mov	#60.,ticsec	;60 Hz
40$:	.gtim	#pra,#ftime	;What time is it?
	mov	ftime,-(sp)	;Put into correct format
	mov	ftime+2,ftime	;For DIVIDE
	mov	(sp)+,ftime+2
	sub	stime+2,ftime	;Finish time  -  start time
	sbc	ftime+2
	sub	stime,ftime+2
	mov	#ab6,r5		;Work out # of secs from # of ticks
	call	divide
	asr	ticsec		;Now round off to integer # secs
	cmp	ticsec,rem
	bgt	50$
	add	#1,ftime	;Yep, add .5 sec and trunc
	adc	ftime+2
50$:	mov	#60.,ticsec	;Work out # secs
	mov	#ab6,r5
	call	divide
	mov	rem,secs
	mov	#ab6,r5		;Work out # mins
	call	divide		;Hrs left over in FTIME
	mov	rem,mins
	.print	#inn
	mov	ftime,tmpsto	;Incredible! it took this sort more
	beq	60$
	call	nprint		; than 1 hr to sort something!
	.print	#hrs
60$:	mov	mins,tmpsto
	beq	70$
	call	nprint		;Print out # of minutes
	.print	#minuts
70$:	mov	secs,tmpsto
	call	nprint
	.print	#secnds
estats::
	.print	#crlf
	jmp	stcmdd

;This routine prints a decimal # on the console

Nprint::
	mov	#filblk,r1
	movb	#200,-(r1)
10$:	mov	#ab7,r5
	call	divide
	add	#60,rem
	movb	rem,-(r1)
	tst	tmpsto
	bne	10$
	.print	r1
	return
.Sbttl	Utility Routines

Core::
	asl	r0		;Convert # of words to # of bytes
	add	workhi,r0	;Work out new high address by adding # words
coreae::mov	r0,-(sp)	; requested to low addr and save
	.settop			;Get it.
	cmp	(sp)+,r0	;Got it?
	beq	10$
	  call	fatal		;Need to use FATAL mechanism for later
	  .word	inscor		; automatic use.
10$:
	cmp	workhi,r0	;Good!
	bhis	20$
	mov	workhi,worklo	;Adjust new work area limits for an expansion
	mov	r0,workhi
	return
20$:	mov	r0,workhi	;No work area for a contraction
	mov	r0,worklo
	return
;	CALL:
;		JSR	R5,GETREC
;		.WORD	BUFHED
;		.WORD	DEST


Getr::
	setup	<@(r5)+,@(r5)+,reclen,wdpnt(r0),bytcnt(r0)>
	mov	r5,-(sp)
	mov	r0,-(sp)
	add	#10,r1
	mov	r1,-(sp)
	mov	trnsli,r1
10$:	dec	r4
	ble	120$
20$:	movb	(r3)+,r0
	beq	10$
	cmp	#cr,r0		;R5 must now be used for address calculation
	beq	100$
	cmp	#32,r0		;Control-Z
	bne	30$
	tstb	dibl$c
	beq	30$
	tst	(sp)+
	sec
	br	90$
30$:
	dec	r2
	blt	40$
	cmp	#tab,r0		;Keep tabs,
	beq	35$
	cmp	#' ,r0		; but scrub all other control characters.
	bgt	10$
35$:
	mov	(r1)+,r5	;Move destination character position into r5
	blt	10$		;If <0 then ignore this character
	add	(sp),r5		;Add base address of destination addr to
	movb	r0,(r5)		; charpos and store it.
	br	10$
40$:	inc	trunc
50$:	mov	#lf,r5
	tst	(sp)+		;Pop transl. array addr from stack
60$:	dec	r4
	bgt	70$
	call	blki
	bcs	90$
	mov	(sp),r0
	mov	wdpnt(r0),r3
	mov	bytcnt(r0),r4
70$:	cmpb	(r3)+,r5
	bne	60$
80$:	clc
90$:	mov	(sp)+,r0
	mov	r3,wdpnt(r0)
	mov	r4,bytcnt(r0)
	mov	(sp)+,r5
	rts	r5
100$:	clr	r0
	tstb	xspc$c
	beq	110$
	mov	#40,r0
110$:	dec	r2
	bmi	50$
	mov	(r1)+,r5
	blt	110$
	add	(sp),r5
	movb	r0,(r5)
	br	110$
120$:	tst	-(sp)		;Push stack
	mov	4(sp),(sp)	;Store buffer header address for BLKI
	call	blki
	bcc	140$
130$:	mov	(sp)+,(sp)+	;Error, get rid of the last two things pushed
	br	90$		; on stack.
140$:	mov	(sp)+,r0	;Pop second copy of buffer header addr from
	mov	wdpnt(r0),r3	; stack
	mov	bytcnt(r0),r4
	br	20$
Getrs::
	mov	@2(r5),r0	;Get address of node in R0
	mov	r5,-(sp)	;Move to start of record in memory
	add	#10,r0		;Move to position to insert keys
	add	keylnb,r0
	tstb	pixn$c		;Check if record seq nos or position indices
	beq	10$
	dec	ibufs+blkpnt	;IBUFS+BLKPNT contains current block
	jsr	r5,posn		; being read from disc, not current buffer
	.word	ibufs,10	; being emptied.  Work out position of
				; record in file
	inc	ibufs+blkpnt
	add	extra,r0	;Write digits backward in record
	mov	r1,r3		;Write out byte position in block
	mov	#3,r4
	call	90$
	mov	r2,r3		;Write out block number
	mov	#6,r4
	call	90$
	br	80$
10$:	mov	extra,r5	;Here for record sequence numbers
	mov	totcnt,r1	;Calculate record sequence number
	mov	totcnt+2,r2
	add	#1,r1
	adc	r2
	mov	#tentbl,r4
20$:	clr	r3		;Use R3 to accumulate digit
30$:	cmp	(r4)+,r2	;This code converts the double precision
	blo	40$		; number in R1 & R2 to ASCII decimal
	bhi	60$		; by comparing each tens column of the
	cmp	(r4),r1		; number with values 1,2,4 & 8 in that
	bhi	60$		; column and adding the digit value when
40$:	sub	(r4)+,r1	; the digit to be output in that column
	sbc	r2		; is greater than the test digit
	sub	-4(r4),r2
	add	(r4),r3
50$:	cmp	(r4)+,#1
	bgt	30$
	br	70$
60$:	tst	(r4)+
	br	50$
70$:	add	#60,r3
	movb	r3,(r0)+
	dec	r5
	bgt	20$
80$:	mov	(sp)+,r5
	jmp	getr
90$:	mov	r3,r5
	bic	#177770,r5
	add	#60,r5
	movb	r5,-(r0)
	asr	r3
	asr	r3
	asr	r3
	dec	r4
	bgt	90$
	return
Putr::
	mov	q,-(sp)
	add	#10,(sp)	;Setup basesource address
	mov	obuf+wdpnt,r2
	mov	olen,r3
	mov	obuf+bytcnt,r4
	mov	trnslo,r5	;Addr of "Translate on output" array
10$:	dec	r3
	blt	tackon
	dec	r4
	bgt	20$
	call	buffo
20$:	mov	(r5)+,r1	;Get source char pos of char to be output
	blt	30$
	add	(sp),r1		;Calc address
	movb	(r1),(r2)+	;Put byte in buffer
	bne	10$		;Back for more if not a null
	tstb	-(r2)		;Reverse buffer pointer over null just put in
30$:	inc	r4		; buffer.
tackon::
	tst	(sp)+
	.irp	x,<#cr,#lf>	;All the record has been output, now
	dec	r4		; tack on crlf
	bgt	.+6
	call	buffo
	movb	x,(r2)+
	.endr
	mov	r4,obuf+bytcnt	;Store buffer header info back in buffer
	mov	r2,obuf+wdpnt	; header
	return

Buffo::
	mov	r2,obuf+wdpnt	;This routine outputs a block
	call	bout
10$:	mov	obuf+wdpnt,r2	;New buffer info into registers
	mov	obuf+bytcnt,r4
	asl	r4
	return
.Enabl	lsb

Bout::
	$out	#pra,out,#-1	;Out with it.
	bcc	40$
	tstb	obuf
	bne	10$
xspce::
	call	fatal
	.word	insalc		;EOF on output
10$:
	call	fatal
	.word	hdwoe		;Hardware error


Close::
	tstb	dibl$c
	beq	30$
	dec	obuf+bytcnt
	bgt	20$
	call	bout
20$:	movb	#32,@obuf+wdpnt
	inc	obuf+wdpnt
30$:	$close	out
	bcs	xspce
40$:	return

.Dsabl	lsb
;	CALL:
;		JSR	R5,INITT
;		.WORD	BASE
;		.WORD	P
;		.WORD	ARGBLK
;		.
;		.
;ARGBLK:BASEx:	.BLKW	1
;	RQx:	.BLKW	1
;	Qx:	.BLKW	1

Initt::
	setup	<@(r5)+,@(r5)+,(r5)+,reclen+2>
	mov	r0,(r2)		;Store base address of tree
	clr	2(r2)		;Clear RQ for this tree
	mov	r0,4(r2)	;Store initial value of Q for tree.
	mov	r5,(sp)		;Save R5 for use as a fast register
	clr	r4		;This keeps count of the node #
10$:	mov	r0,loser(r0)	;loser(j)=j
	clr	rn(r0)		;rn(j)=0
	mov	r4,r5		;fe(j)=loc(x((p+j)/2))
	add	r1,r5
	asr	r5
	call	mlr5r3
	add	(r2),r5
	mov	r5,fe(r0)	;Store address of internal node above
				; this external node
	mov	r4,r5		;fi(j)=loc(x(j/2))
	asr	r5
	call	mlr5r3
	add	(r2),r5
	mov	r5,fi(r0)	;Store address of int node above this int node
	add	r3,r0		;Move to next external node
	inc	r4
	cmp	r1,r4		;Loop for 0<=j<P
	bgt	10$
	return			;Done!

Mlr5r3::
	mov	r0,-(sp)	;Routine multiplies R5 by R3 and places
	mov	r1,-(sp)	; the result in R5
	mov	r5,r0
	clr	r5
	mov	r3,r1
10$:	ror	r1
	bcs	20$
	beq	40$
	br	30$
20$:	add	r0,r5
30$:	asl	r0
	clc
	br	10$
40$:	mov	(sp)+,r1
	mov	(sp)+,r0
	return
Update::
	mov	q,r2		;t=fe(q)
	mov	rq,r5
	mov	fe(r2),r3
10$:	cmp	rn(r3),r5	;If rn(t)<rq then 30$ else if rn(t)>rq then 40$
	blt	30$
	bne	40$
20$:	mov	(r3),r0		;Mov loser(r3),r0
	mov	r2,r1
	add	#10,r1		;Setup available arguments for comparison
	add	#10,r0		; routine
	call	@compare	;If rn(t)=rq and key(t)<key(q) then
	bge	40$		; swap t,q and rn(t),rq
30$:	mov	(r3),r4
	mov	r2,(r3)
	mov	r4,r2
	mov	rn(r3),r4
	mov	r5,rn(r3)
	mov	r4,r5
40$: 	cmp	loc.x1,r3
	bne	50$
	mov	r5,rq
	mov	r2,q
	return
50$:
	mov	fi(r3),r3	;t=fi(t)
	br	10$
Posn::
	mov	r0,-(sp)	;Get address of buffer header
	mov	(r5)+,r0
	mov	r3,-(sp)
	mov	(r5)+,r3	;Get offset in buffer header to buffer
	mov	r5,-(sp)	;Pointer to start of buffer
	mov	wdpnt(r0),r1	;Get current byte pointer in buffer
	add	r0,r3		;Calc addr of buffer
	sub	(r3),r1		;Calc # of bytes put in buffer
	mov	r1,r2
	bic	#177000,r1	;Find # of bytes from start modulo 512.
	bic	#777,r2		;Find # of blocks offset from start of buffer
	swab	r2
	asr	r2
	movb	1(r0),r5	;Get number of blocks per buffer in R5
	mov	blkpnt(r0),r3	;Calculate number of blocks from start
	cmp	#-1,r3		; of file to start of current buffer
	bne	10$
	clr	r3
10$:	call	mlr5r3
	add	r5,r2		;Add on buffer offset in blocks
	mov	(sp)+,r5
	mov	(sp)+,r3
	mov	(sp)+,r0
	rts	r5
Calbuf::
	mov	q,r0		;Get address of node in R0
	mov	@2(sp),r1	;Get base address of tree  (loc(x(0))) in R1
	clr	r2		;Init offset from beginning of buffer header
				; table
	mov	reclen+2,r3	;Length of node into R3
10$:	cmp	r0,r1		;Is loc(x(j))=q?
	beq	20$
	add	r3,r1		;No, bump x(j) and offset to buffer header
	add	#bhsize*2,r2	; table
	br	10$
20$:	mov	#ibufs,bufhed	;Calculate address of first word of buffer
	add	r2,bufhed	; header from offset and store in BUFHED
	return


;	CALL:
;		JSR	R5,TREEO
;		.WORD	ARGBLK		;See INITT for info on ARGBLK
;		.WORD	IRTN
;		.WORD	ORTN

Treeo::
	mov	(r5)+,r1	;Get address of ARGBLK in R1
	mov	(r5)+,irtn	;Address of input routine which
				; inputs a record to a node
	mov	(r5)+,ortn	;Ditto for output routine
	mov	(r1),loc.x1	;Calculate LOC(X(1))=LOC(X(0))+size of node
	add	reclen+2,loc.x1	;Needed by update
	mov	2(r1),rq	;Get RQ, and Q for UPDATE
	mov	4(r1),q
	mov	r5,-(sp)
	mov	r1,-(sp)
s2::	call	calbuf		;Root of tree has already been output, find
	call	@irtn		; out which buffer it came from and replace
	bcc	10$		; it from there.
	mov	#2,rq		;If no records left in run set run # to
	br	s3		; dummy last run(2), otherwise to valid
10$:				; run #(1)
	mov	#1,rq
s3::	call	update		;Insert new rec into tree and find new winner
	tst	rq		;If initial dummy run get another rec, and
	beq	s2		; keep on until tree is flushed of dummies
	cmp	#2,rq		;If run # of record output from tree is a
	bne	20$		; tail-end dummy, save info on this tree, and
	sec			; exit indicating nothing more is forthcoming.
10$:	mov	(sp)+,r1
	mov	q,4(r1)
	mov	rq,2(r1)
	mov	(sp)+,r5
	rts	r5
20$:	call	@ortn		;Record at root of tree is valid data, process
	clc
	br	10$		; it and return
;	CALL:
;		MOV	#BUFHDR,-(SP)
;		CALL	BLKI

Blki::
	mov	r0,-(sp)	;All registers used by blki are saved.
	tstb	fstp$c		;Check if first pass
	beq	40$
	$in	#pra,in,#-1	;Yes, use double buffer I/O routines for input
	bcc	20$		;Error?
	tstb	ibufs		;Yes, just eof?
	beq	10$
	  call	fatal
	  .word	hdwie		;No, hard error
10$:
	sec
	br	30$
20$:
	asl	ibufs+bytcnt
	clc
30$:
	mov	(sp)+,r0
	return

40$:
	mov	r1,-(sp)	;Save r1 for use as buffer header pointer
	mov	6(sp),r1	;Get address of buffer header in r1
	add	blkinc(r1),blkpnt(r1) ;Update block pointer
	.readw	#pra,in,bufadr(r1),size(r1),blkpnt(r1)
	bcc	60$
50$:
	mov	(sp)+,r1
	mov	(sp)+,r0
	return
60$:
	asl	r0		;Now set up buffer header for data
	mov	r0,bytcnt(r1)
	mov	bufadr(r1),wdpnt(r1)
	br	50$
Mirtn::
	mov	bufhed,r0	;Get addr of input buffer header
	sub	#1,rekcnt(r0)	;Decrement record count of merge run
	sbc	rekcnt+2(r0)	; associated with this buffer
	bge	10$
	sec			;No recs left, end of run. simulate eof
	return
10$:
	jsr	r5,@getrec	;Still something there, get it
	.word	bufhed
	.word	q
	return


Mortn::
	call	@putrec
	return
;Routine to fetch one word from run-index file input buffer

Gtwd::
	mov	r0,-(sp)
	dec	ribwct
	bgt	30$
	.readw	#pra,#4,ribbuf,ribsiz,ribblk
	bcc	20$
	tstb	@#emterr
	beq	10$
	  call	fatal
	  .word	hdwie
10$:
	  call	fatal
	  .word	rnfie
20$:
	add	ribinc,ribblk
	mov	ribbuf,ribwpt
	mov	r0,ribwct
30$:
	mov	@ribwpt,r1
	add	#2,ribwpt
	mov	(sp)+,r0
	return


;Routine to write a word to the run-index output buffer

Ptwd::
	dec	robwct
	bgt	30$
	tstb	rnfe$c		;Is a file actually entered yet?
	bne	10$
	mov	#overun,rnfsiz	;No, miscalculated that runs would fit in mem
	call	ernf		;Enter file
	bcc	10$
	  call	fatal
	  .word	tmnyrn
10$:
	.writw	#pra,#4,robbuf,robsiz,robblk
	bcc	20$
	  jmp	xspce
20$:	add	robinc,robblk
	mov	robbuf,robwpt
	mov	robsiz,robwct
30$:
	mov	r1,@robwpt
	add	#2,robwpt
	return


;Routine to .ENTER run-index file

Ernf::
	movb	#-1,rnfe$c
	.enter	#pra,#4,#runfil,rnfsiz
	return


;Routine to "rewind" run-index file for input and output

Rrf::
	tstb	rnfe$c		;Was a file written to disc?
	bne	10$		;10$ if yes
	.irp	bh,<rib,rob>
	mov	#rob,bh'buf	;Reuse whole double buffer as array
	mov	#rbsize*2,bh'siz
	clr	bh'blk
	mov	#rbsize/200,bh'inc
	mov	#rbsize*2+1,bh'wct
	mov	bh'buf,bh'wpt
	.endr
	return
10$:
	mov	#rob,robbuf	;File actually written,
	mov	robbuf,robwpt
	mov	#rbsize+1,robwct
	mov	#rib,ribbuf	;Use separate buffers for input & output
	clr	ribwct
	.irp	bh,<rib,rob>
	mov	#rbsize,bh'siz
	clr	bh'blk
	mov	#rbsize/400,bh'inc
	.endr
	return


;Routine to end output to run-index file

Crf::
	tstb	rnfe$c
	beq	10$
	mov	robwpt,r1	;Here if run-index file opened
	sub	robbuf,r1	;Calc number of words left in buffer
	clc
	ror	r1
	.writw	#pra,#4,robbuf,r1,robblk ;Write them out
	bcc	10$
	tstb	@#emterr
	beq	20$
	  call	fatal
	  .word	hdwoe
10$:	return

20$:	jmp	xspce
Divide::
	.irp	x,<r0,r1,r2,r3,r4>
	mov	x,-(sp)
	.endr
	call	jdiv
	.irp	x,<r4,r3,r2,r1,r0>
	mov	(sp)+,x
	.endr
	return

Multiply::
	.irp	x,<r0,r1,r2,r3,r4>
	mov	x,-(sp)
	.endr
	call	jmul
	.irp	x,<r4,r3,r2,r1,r0>
	mov	(sp)+,x
	.endr
	return


.End	Start
