; Assembly code for machine-independent part of Midas
;	Last edited: 25 August 1981

.get "MAsmCommon.d"

; GACHA8
.bext FontP

; MINIT0
.bext EndStorage,Storage

; MIDAS
.bext MidasSwat

; MOVERLAY
.bext KillOverlays,OverlayZone,OverlayFlushed

; MSYM
.bextz BHsize

; MDISP
.bext PrepareCharInv,VertIntFlag,NwdsPerScanLine

; MRGN
.bext ScreenTV,ScreenLinesDirty,Displayacx

; MCMD
.bext CmdCommentStream,CmdCS1

; Defined here
.bext Wss,RepPuts,PutsCSS,ResetsCSS,WssCS1,PutsCS1,ResetsCS1
.bext ErrorProtect,DummyCall,DummyCall1
.bext MoveUp,LCycle,Mag,SelfRel,DoubleNeg,DoubleDiv,VUsc
.bext GetField,PutField,MoveLongField
.bext StrSize,SymbKeyComp,BinScan,GetBodySize,SearchBlock
.bext VertIntCode,ClearAndScanConvert
.bext PutTVs,ResetTVs,PutTxts,ResetTxts,BackUp,PaintItem,Wait
.bext GetStorage,GetEvenStorage
.bext MaskT
.bextz WssCSS,OddParity
.bextz AbortFrame,AbortLabel,BlockTable,MSave2,MCount

.zrel

OddParity:		.OddParity
WssCSS:			.WssCSS
AbortFrame:		0
AbortLabel:		0
BlockTable:		0
MSave2:			0
MCount:			0

.srel

Wss:			.Wss
RepPuts:		.RepPuts
PutsCSS:		.PutsCSS
ResetsCSS:		.ResetsCSS
WssCS1:			.WssCS1
PutsCS1:		.PutsCS1
ResetsCS1:		.ResetsCS1
ErrorProtect:		.ErrorProtect
DummyCall:		.DummyCall
DummyCall1:		.DummyCall1
MoveUp:			.MoveUp
LCycle:			.LCycle
Mag:			.Mag
SelfRel:		.SelfRel
DoubleNeg:		.DoubleNeg
DoubleDiv:		.DoubleDiv
GetField:		.GetField
PutField:		.PutField
MoveLongField:		.MoveLongField
VUsc:			.VUsc
StrSize:		.StrSize
SymbKeyComp:		.SymbKeyComp
BinScan:		.BinScan
GetBodySize:		.GetBodySize
SearchBlock:		.SearchBlock
VertIntCode:		.VertIntCode
ClearAndScanConvert:	.ClearAndScanConvert
Wait:			.Wait
PutTVs:			.PutTVs
ResetTVs:		.ResetTVs
PutTxts:		.PutTxts
ResetTxts:		.ResetTxts
BackUp:			.BackUp
PaintItem:		.PaintItem
GetStorage:		.GetStorage
GetEvenStorage:		.GetEvenStorage
MaskT:			457	; Points 1 before table used by Convert

.nrel

.WssCS1:
	mov 0 1
	lda 0 @lvCmdCS1
	jmp .Wss

.WssCSS:
	mov 0 1
	lda 0 @lvCmdCommentStream
; Used to do this differently, but the Puts routines use a peculiar
; retry-call sequence when the buffer overflows, so have to implement
; a Puts call that can be retried.
.Wss:	sta 3 1 2
	jsr @GetFrame
	 10
	jsr @StArgs
	lda 0 @5 2	; Length,,1st char
	lda 1 W177400
	ands 0 1 snr
	jsr @Return
	sta 1 6 2	; Length
	lda 3 4 2	; Stream
	lda 0 4 3
	sta 0 7 2	; Stream+4 = Puts location
WOdd:	lda 1 @5 2
	lda 0 W377
	and 0 1
	lda 0 4 2	; Stream
	jsr @7 2
	 2
	isz 5 2		; Increment to next word
	dsz 6 2		; Skip when count runs out
	jmp .+2
	jsr @Return

	lda 1 @5 2
	lda 0 W177400
	ands 0 1
	lda 0 4 2
	jsr @7 2
	 2
	dsz 6 2
	jmp WOdd
	jsr @Return

W177400:	177400
W377:		377

.PutsCS1:
	mov 0 1
	lda 0 @lvCmdCS1
	jmp .+3
.PutsCSS:
	mov 0 1
	lda 0 @lvCmdCommentStream
	sta 3 1 2
	mov 0 3
	lda 3 4 3
	jmp 1 3

.ResetsCS1:
	lda 0 @lvCmdCS1
	jmp .+2
.ResetsCSS:
	lda 0 @lvCmdCommentStream
	sta 3 1 2
	mov 0 3
	lda 3 5 3
	jmp 1 3

lvCmdCommentStream:	CmdCommentStream
lvCmdCS1:		CmdCS1

; RepPuts(S,C,Count) does Puts(S,C) Count times
.RepPuts:
	sta 3 1 2
	jsr @GetFrame
	 10
	jsr @StArgs
	lda 0 6 2
	negl# 0 0 snc
	jsr @Return	; Return if Count le 0
	lda 3 4 2	; 3/ Stream
	lda 0 4 3
	sta 0 7 2	; 4 3/ Puts location
RPslp:	lda 0 4 2
	lda 1 5 2
	jsr @7 2
	 2
RPtest:	dsz 6 2
	jmp RPslp
	jsr @Return

; Subroutine to move a block of words from its current position to an
; overlapping position at a larger address (i.e., MBlock won't work).
; Arg1 = "To", Arg2 = "From", Arg3 = word count.
.MoveUp:
	inc 3 3
	sta 3 1 2	; Save return
	lda 3 3 2	; Arg3 = word count
	add# 3 3 snr	; Skip if word count ne 0
	jmp @1 2	; else return
	sta 3 MCount
	mov 1 3		; 3←"From"
	sta 2 MSave2	; Preserve stack pointer
	mov 0 2		; 2←"To"
	mkminusone 1 1
MUpLp:	lda 0 0 3
	sta 0 0 2
	add 1 2		; Subtract 1 from "To"
	add 1 3		; Subtract 1 from "From"
MUp1:	dsz MCount
	jmp MUpLp
	lda 2 MSave2	; Restore stack pointer
	jmp @1 2	; Return to caller


; VUsc(V1,V2,length) does an unsigned compare of vectors V1 and V2,
; returning -1 if V1 < V2, 0 if V1 eq V2, or 1 if V1 > V2.
.VUsc:	sta 3 1 2
	jsr @GetFrame
	 10
	jsr @StArgs
VC0:	lda 0 @4 2
	lda 1 @5 2
	sub# 0 1 szr
	jmp VC1
	dsz 6 2
	jmp VC2
	mkzero 0 0
	jsr @Return
VC1:	sleu 0 1
	mkone 0 0 skp
	mkminusone 0 0
	jsr @Return
VC2:	isz 4 2
	isz 5 2
	jmp VC0
	77400

; Calls @p1 with p2 arguments, p3, p4, p5, ...
; The circumlocution allows reexcution of the call if it failes due to
; an overlay fault.
.DummyCall1:
	sta 3 1 2
	sta 0 lvFcn
	jsr @GetFrame
	 24
	jsr @StArgs
	lda 0 5 2		; 2nd arg = NArgs for call
	sta 0 NParams
	lda 3 Three
	lda 1 Five
	sub# 0 3 snr
	lda 1 10 2
	sta 1 3 2
	lda 0 6 2
	lda 1 7 2
	jmp DCcall

; As above, but calls @p1 with arguments p2, p3, p4 ...
.DummyCall:
	sta 3 1 2
	sta 0 lvFcn
	jsr @GetFrame
	 24			; 4 fixed + 20 formals
	jsr @StArgs
	neg 0 0
	com 0 0			; NArgs-1 = Args for call
	sta 0 NParams
	lda 3 Three
	lda 1 Four		; 2nd formal-1 (frame relative)
	sub# 0 3 snr		; Skip if NArgs for call unequal 3
	lda 1 7 2		; Exactly 3--save 3rd
	sta 1 3 2		; Else save pointer to extra args
	lda 0 5 2		; 2nd arg = 1st for call
	lda 1 6 2		; 3rd arg = 2nd for call
DCcall:	jsrii lvFcn
NParams:
	 0
	jmp @Return

Three:		3
Four:		4
Five:		5
Seven:		7
lvFcn:		0
.OverlayZone:	OverlayZone
.OverlayFlushed:	OverlayFlushed
.KillOverlays:	KillOverlays

; Calls @p1 with args p2, p3, ..., pN after establishing
; AbortLabel and AbortFrame to capture DisplayError and ErrorAbort calls.
; Also fixes up state of overlay stuff on returns and errors.
; Frame of ErrorProtect winds up with:
;	arg 0	old AbortFrame
;	arg 1	old AbortLabel
;	arg 2	0 if must kill overlays on exit else -1
;	args 3 to n	args 2 to n-1 of called procedure.
.ErrorProtect:
	sta 3 1 2
	sta 0 lvFcn		; Set function name for call = caller's arg 1
	lda 0 0 3		; NArgs
	lda 3 Seven		; **Don't know why this is 7.  Why not 4?
	add 0 3
	sta 3 Frsize		; Frame size = 4 fixed + NArgs
	neg 0 0
	com 0 0
	sta 0 NArgs		; Nargs for protected call = NArgs-1
	lda 0 AbortFrame	; Old AbortFrame in place of arg1
	jsr @GetFrame
Frsize:	 24
	jsr @StArgs		; Returns nargs in ac0
	sta 2 AbortFrame	; AbortFrame = MyFrame()
	lda 1 Four		; Second formal -1 (frame relative)
	sub# 0 1 snr		; Skip if NArgs for call unequal to 3
				; (but test against 4 here since ac0 has
				; NArgs for call+1)
	 lda 1 7 2		; Exactly three--save third
	sta 1 3 2		; else save number extra args for call
	lda 0 @.OverlayZone
	mov# 0 0 snr
	 jmp .+3		; Remember to kill overlays if no zone
	lda 0 @.OverlayFlushed
	mov# 0 0 szr
	 mkzero 3 3 skp		; or if OverlayZone exists but is empty
	 mkminusone 3 3		; Otherwise, don't touch OverlayZone
	lda 0 5 2		; Second arg = 1st for call
	lda 1 6 2		; 3rd arg = 2nd for call
	sta 3 6 2		; 0 if must kill overlays on return
				; at arg3 (now a temp)
	lda 3 AbortLabel
	sta 3 5 2		; Save old AbortLabel at arg2 (now a temp)
	jsr Erp4
EProtL:	mkzero 0 0		; Return 0 if aborted
	jmp Erp5

Erp4:	sta 3 AbortLabel	; Set AbortLabel to EProtL
	jsrii lvFcn		; Call the function
NArgs:	 0
Erp5:	lda 1 4 2
	sta 1 AbortFrame	; Restore AbortFrame
	lda 1 5 2
	sta 1 AbortLabel	; Restore AbortLabel
	lda 1 6 2
	mov# 1 1 szr		; Skip if must kill overlays
	 jmp @Return
	sta 0 6 2		; Preserve result
	jsrii .KillOverlays
	 0
	lda 0 6 2
	jmp @Return

; Left-cycle ac0 by count in ac1
.LCycle:
	cycle 0
	jmp 1 3


; Mag(X) = (X < 0 ? -X,X)
.Mag:	movl# 0 0 szc
	neg 0 0
	jmp 1 3


.SelfRel:		; SelfRel(X) = X + X!0
	sta 0 1 2
	lda 1 @1 2
	add 1 0
	jmp 1 3


.DoubleNeg:
	sta 3 1 2
	mov 0 3
	lda 0 1 3
	lda 1 0 3
	neg 0 0 snr
	neg 1 1 skp
	com 1 1
	sta 1 0 3
	sta 0 1 3
	lda 3 1 2
	jmp 1 3

; DoubleDiv(V,Divisor) divides unsigned double-precision V by single-precision
; Divisor, leaving quotient in V and returning remainder in ac0.
.DoubleDiv:
	sta 3 1 2
	sta 2 MSave2
	mov 0 3		; V
	mov 1 2		; Divisor
	mkzero 0 0
	lda 1 0 3	; High part of dividend
	div		; 0←remainder, 1←quotient
	77400
	sta 1 0 3	; Save high quotient
	lda 1 1 3
	div
	77400
	sta 1 1 3	; Save low quotient
	lda 2 MSave2
	lda 3 1 2
	jmp 1 3


.StrSize:
	sta 0 1 2
	lda 0 @1 2
	lda 1 S77400		; Sign bit is a flag
	ands 1 0
	movzr 0 0
	inc 0 0
	jmp 1 3

S77400:	77400

; GetField(Bit1,NBits,DVec) returns field le 16 bits in size from DVec
.GetField:
	sta 3 1 2
	lda 3 @lvMaskT
	add 1 3
	lda 3 0 3
	sta 3 2 2	; Mask
	mov 0 3
	lda 0 GF20
	mov# 1 1 szr	; Swat if NBits eq 0
	adcl# 0 1 snc	; Skip if ac1 le ac0
	77400		; Swat if NBits > 16
	lda 0 GF177760
	and 3 0
	sub 0 3		; Bit1 & 17B
	add 1 3		; (Bit1 & 17B)+NBits
	lda 1 GF20
	sub 1 3		; Shift count = (Bit1 & 17B)+NBits-16
	cycle 14	; W = Bit1 rshift 4
	mov 3 1
	lda 3 3 2	; DVec
	add 0 3
	lda 0 0 3	; DVec!W
	movl# 1 1 szc	; Skip if cycling left
	jmp GFrt	; No, value entirely in first word
	neg 1 1 snr	; Skip if shift count ne 0
	jmp GFdone
	lda 3 1 3	; DVec!(W+1)
	movl 3 3
	movl 0 0
	inc 1 1 szr
	jmp .-3
	jmp GFdone
GFrt:	cycle 0
GFdone:	lda 3 2 2
	and 3 0
	lda 3 1 2
	jmp 1 3

GF177760:	177760
GF20:		20
lvMaskT:	MaskT

;and PutField(Bit1,NBits,DVec,Field) be
;[	if (NBits le 0) % (NBits > 16) then CallSwat()
;	DVec = DVec+(Bit1 rshift 4)	// Bit1 starts at 0
;	let Shift = 16-(Bit1 & 17B)-NBits
;	let Mask = MaskT!NBits
;	Field = Field & Mask
;//Loop done once unless field crosses word boundary
;	[ DVec!0 = ((DVec!0) & not (Mask lshift Shift)) + (Field lshift Shift)
;	  DVec,Shift = DVec+1,Shift+16
;	] repeatwhile Shift < 16
;]

.PutField:
	sta 3 1 2
	jsr @GetFrame
	 12
	jsr @StArgs
; 4,2 Bit1 becomes Shift
; 5,2 NBits becomes Mask
; 6,2 DVec
; 7,2 Field
	lda 3 @lvMaskT
	lda 1 5 2
	add 1 3
	lda 0 0 3
	sta 0 5 2	; Mask = MaskT!NBits
	lda 3 GF20
	negl# 1 1 szc	; Skip if NBits le 0
	adcl# 3 1 snc	; Skip if NBits le 20
	77400		; Swat
	sub 1 3		; 20B-NBits
	lda 0 4 2	; Bit1
	lda 1 PF17
	and 0 1
	sub 1 0
	sub 1 3		; NBits-20B-(Bit1 & 17B)
	sta 3 4 2	; Shift (neg means right, pos left)
	cycle 14	; Bit1 rshift 4
	lda 1 6 2
	add 0 1
	sta 1 6 2	; DVec+(Bit1 rshift 4) is first word
	mov 3 1
PFloop:	lda 0 5 2	; Mask
	jsr @Lshift	; Neg count shifts right
	sta 0 PFmask	; Mask lshift Shift
	lda 0 7 2
	lda 1 4 2
	jsr @Lshift	; Field lshift Shift
	lda 1 6 2	; DVec
	jsr @Snq0	; DVec!0 = (DVec!0 & not PFmask)+
PFmask:	 0		; ((Field lshift Shift) & PFmask)
	lda 1 4 2
	movl# 1 1 snc	; Skip if Shift < 0
	jsr @Return
	isz 6 2		; DVec = DVec+1
	lda 3 GF20
	add 3 1
	sta 1 4 2	; Shift = Shift+20B
	jmp PFloop

PF17:		17

;and MoveLongField(Source,SBit1,NBits,Dest,DBit1) be
;[	while NBits > 0 do
;	[ let B = Min(NBits,16)
;	  PutField(DBit1,B,Dest,GetField(SBit1,B,Source))
;	  DBit1,SBit1,NBits = DBit1+16,SBit1+16,NBits-16
;	]
;]

.MoveLongField:
	sta 3 1 2
	jsr @GetFrame
	 20
	jsr @StArgs
	lda 1 7 2
	sta 1 12 2	; Dest in position
	lda 1 6 2
MLFlp:	negl# 1 1 snc	; Skip if NBits > 0
	jsr @Return
	lda 0 GF20
	adcl# 0 1 snc	; Skip is ac1 le ac0
	mov 0 1
	sta 1 11 2	; Min(20B,NBits)
	lda 3 4 2
	sta 3 3 2	; Source is 3rd arg for GetField
	lda 0 5 2
	jsr .GetField
	 3
	sta 0 13 2	; 4th arg for PutField in position
	lda 0 MLF7	; Rel. position of 3rd arg on stack-3
	sta 0 3 2
	lda 0 10 2
	lda 1 11 2
	jsr .PutField
	 4
	lda 0 GF20
	lda 1 5 2
	add 0 1
	sta 1 5 2	; SBit1 = SBit1+20B
	lda 1 10 2
	add 0 1
	sta 1 10 2	; DBit1 = DBit1+20B
	lda 1 6 2
	sub 0 1
	sta 1 6 2	; NBits = NBit2-20B
	jmp MLFlp

MLF7:	7

; Vertical interrupt routine
.VertIntCode:
	sta 0 A0
	adc 0 0		; -1 = true
	sta 0 @lvVertIntFlag
	lda 0 A0
	bri

A0:	0
lvVertIntFlag: VertIntFlag


; Clear and scan convert a string (from ScreenTV) into a bit buffer
; 4,2 = Arg1 = BitBuffer
; 5,2 = Arg2 = StringVec, incremented during loop
; 6,2 set to NwdsPerScanLine
; 7,2 DBA Destination bit address
; 10,2 DWA Destination word address-NwdsPerScanLine
; 11,2 StringVec>>lh, decremented for end test

; * Must agree with MDECL.D *
PFVecSize = 62
EvecSize = 12

.ClearAndScanConvert:
	sta 3 1 2
	jsr @GetFrame
	 21+PFVecSize+EvecSize		; 4+nargs+Ntemps (?)
	jsr @StArgs
	lda 0 c20
	add 2 0
	sta 0 14 2	; PseudoFontVec
	lda 0 cEvec
	add 2 0
	sta 0 15 2	; Evec
	lda 0 @lvNwdsPerScanLine
	sta 0 6 2
	neg 0 0
	lda 3 4 2	; BitBuffer
	inc 3 3
	inc 3 3		; BitBuffer+2
	add 3 0
	sta 0 10 2	; BitBuffer+2-NWDS = initial DWA
	lda 0 c20
	sta 0 7 2	; DBA initially 20 means start at bit 0
	mov 3 1		; BitBuffer+2
	lda 3 -1 3	; BitBuffer!1
	neg 3 3		; - Count
	adc 3 1		; Last
	mkzero 0 0	; Value
	blks		; Zero(BitBuffer+2,BitBuffer!1)--Convert OR's
	lda 3 @5 2
	lda 1 casc177400
	ands 1 3 snr
	jsr @Return	; Return if no characters
	sta 3 11 2	; StringVec>>lh

CASodd:	lda 3 @5 2
	lda 0 c177
	and 3 0
	lda 1 c200
	and# 1 3 szr
	jmp InvOdd
	lda 3 @lvFontP
	add 0 3 skp
OddC1:	isz 10 2	; Inc wrd loc and loop
; 3/ char loc in font
OddC2:	lda 0 10 2	; Dest word address-NWDS
	convert +6
	jmp OddC1
	subz 3 1 szc	; Decrement DBA
	jmp OddC0
	isz 10 2
	lda 3 c20
	add 3 1
OddC0:	sta 1 7 2	; New DBA

	isz 5 2		; Inc wrd loc
	lda 1 @5 2
	lda 0 c77400
	dsz 11 2
	ands 1 0 skp
	jsr @Return
	movl# 1 1 szc
	jmp InvEvn
	lda 3 @lvFontP
	add 0 3 skp
EvnC1:	isz 10 2
EvnC2:	lda 0 10 2
	convert +6
	jmp EvnC1
	subz 3 1 szc
	jmp EvnC0
	isz 10 2
	lda 3 c20
	add 3 1
EvnC0:	sta 1 7 2
	dsz 11 2	; Skip when char. count runs out
	jmp CASodd
	jsr @Return

InvOdd:	lda 1 14 2	; PseudoFontVec
	lda 3 15 2
	sta 3 3 2	; Evec
	jsrii lvPrepareCharInv
	 3
	lda 3 15 2
	jmp OddC2

InvEvn:	lda 1 14 2
	lda 3 15 2
	sta 3 3 2
	jsrii lvPrepareCharInv
	 3
	lda 3 15 2
	jmp EvnC2


cEvec:		20+PFVecSize
c20:		20
c200:		200
c177:		177
c77400:		77400
casc177400:	177400
lvPrepareCharInv:	PrepareCharInv
lvNwdsPerScanLine:	NwdsPerScanLine
lvFontP:		FontP

; BackUp(S) used for display lines
.BackUp:
	sta 3 1 2
	mov 0 3
	lda 0 14 3		; TV!0
	neg 0 0 snr		; Skip if not empty
	jmp BUretn
	com 0 0			; TV!0 = TV!0-1
TxtFin:	sta 0 14 3
	mkminusone 0 0
	sta 0 @lvScreenLinesDirty
	lda 1 -2 3		; First word of Rgn structure
	movzl 1 1		; Rgn.DispDirty = 1 -or-
	movor 1 1		; R!0 = R!0 % 100000B
	sta 1 -2 3
BUretn:	lda 3 1 2
	jmp 1 3

lvScreenLinesDirty:	ScreenLinesDirty

; Resets(S) for display lines
.ResetTxts:
	sta 3 1 2
	mov 0 3
	mkzero 0 0
	jmp TxtFin


; Resets(S) for TV's
.ResetTVs:
	sta 3 1 2
	mov 0 3
	mkzero 0 0
	sta 0 14 3
	jmp BUretn


; Puts(S,Char) for display lines
.PutTxts:
	sta 3 1 2
	sta 1 2 2
	mov 0 3
	lda 1 -2 3		; Rgn.DispDirty = 1 as above
	movzl 1 1
	movor 1 1
	sta 1 -2 3
	mkminusone 0 0
	sta 0 @lvScreenLinesDirty
	jmp PTX1


; Puts(S,Char) for TV's
.PutTVs:
	sta 3 1 2
	sta 1 2 2
	mov 0 3
PTX1:	lda 0 14 3		; TV!0
	lda 1 1 3		; S>>ST.par2 = max length
	inc 0 0
	adcl# 1 0 snc
	jmp BUretn
	sta 0 14 3
	add 0 3
	lda 0 2 2
	sta 0 14 3		; TV!(TV!0) = Char
	lda 3 1 2
	jmp 1 3

lvScreenTV:		ScreenTV
lvDisplayacx:		Displayacx
PI377:			377
PI177400:		177400

; PaintItem(L,TV,charX) accepts absolute display positions setup by a
; setup by a previous call to PaintSetup(R,rlx).  It moves characters
; from TV into ScreenTV for L (L = Displayalx+rlx).
.PaintItem:
	inc 3 3
	sta 3 1 2	; Return address
	lda 3 @lvScreenTV
	add 0 3
	lda 0 0 3	; 0/ S = ScreenTV!L
	inc 1 3		; 3/ From = TV+1
; No range check necessary here because MarkMenus makes one
	lda 1 -1 3	; 1/ TV!0
	sta 1 MCount	; MCount/ TV!0
	sta 2 MSave2
	lda 2 3 2	; 2/ charX
	lda 1 @lvDisplayacx
	add 2 1		; 1/ Displayacx+charX = offset
	inc 1 1
	movzr 1 2
	add 0 2		; 2/ To = S + ((offset+1) rshift 1)
	movr 1 1 szc	; Skip if start on even byte
	jmp PIoddE
; 2/ To
; 3/ From
; MCount/ remaining chars
PIeven:	lda 0 0 2
	lda 1 PI377
	ands 1 0
	lda 1 0 3
	adds 1 0
	inc 3 3
	dsz MCount
	jmp PIodd
	sta 0 0 2
	lda 2 MSave2
	jmp @1 2

PIoddE:	lda 0 0 2
PIodd:	lda 1 PI177400
	and 1 0
	lda 1 0 3
	add 1 0
	sta 0 0 2
	inc 3 3
	inc 2 2
	dsz MCount
	jmp PIeven
	lda 2 MSave2
	jmp @1 2

; Routine to compute odd parity on arg1 and arg2, returning true
; if the number of 1's in arg1 xor arg2 is even, else false
.OddParity:
	sta 3 1 2
	mov 0 3
	andzl 1 3
	add 1 0
	sub 3 0		; Xor = arg1+arg2-2*(arg1 and arg2)

	movs 0 1
	mov 0 3
	andzl 1 3
	add 1 0
	sub 3 0		; Xor of two bytes in each byte of 0

	mov 0 3
	cycle 4
	mov 3 1
	andzl 0 3
	add 0 1
	sub 3 1		; Xor in four four-bit slices

	lda 0 P151454	; Magic parity word
	cycle 0
	movr# 0 0 szc	; Skip if parity is odd
	adc 0 0 skp	; Return -1 to make odd parity
	sub 0 0		; Return 0 to make odd parity
	lda 3 1 2
	jmp 1 3

P151454:		151454


; Wait(N) spins for about N*100 microseconds (N must be > 0)
.Wait:	sta 2 MSave2
	mov 0 1
	lda 2 WaitMul
	mkzero 0 0
; mul multiplies unsigned integers in 1 and 2 generating a 32-bit product;
; low order result added to 0 left in 1; high order result in 0.
	mul
	lda 2 MSave2
	neg 1 1 szr
	com 0 0 skp
	neg 0 0
	inc 1 1 snr
	inc 0 0 szr
	jmp .-2
	jmp 1 3

WaitMul:	25.

;and SymbKeyComp(K1, K2) = valof  // "K1" - "K2"
;[	let N1, N2 = K1>>lh, K2>>lh
;	if N1 eq 0 then resultis N2 eq 0 ? 0,-1
;	if N2 eq 0 then resultis +1	// empty string preceds all others
;	let Dif = K1>>rh - K2>>rh
;	if Dif ne 0 then resultis Dif
;	let Nmin = Min(N1,N2)
;	let Xmax = (Nmin-1) rshift 1
;	for X = 1 to Xmax do
;	[ Dif = K1!X - K2!X; if Dif ne 0 then resultis Dif
;	]
;	if (Nmin & 1) eq 0 do
;	[ Xmax = Xmax+1; Dif = (K1!Xmax)<<lh - (K2!Xmax)<<lh
;	  if Dif ne 0 then resultis Dif
;	]
;	resultis N1 - N2
;]

SKC1z:	ands 3 0 szr		; resultis 0 if both null strings
	mkminusone 0 0		; K2 not null, resultis -1
	jmp @SKCRtn

SKC2z:	mkone 0 0		; resultis +1 if K2 null & K1 not null
	jmp @SKCRtn

; SymbKeyComp(K1,K2) = valof "K1" - "K2"
; **Non-reentrant**
.SymbKeyComp:
	inc 3 3
	sta 3 SKCRtn		; Save return
	sta 0 K1
	sta 1 K2
	lda 1 @K1		; K1!0
	lda 0 @K2		; K2!0
	lda 3 c177400
	ands 3 1 snr
	jmp SKC1z		; K1 is null string
	ands 3 0 snr
	jmp SKC2z		; K2 is null string
; Both strings are non-null
	sta 1 N1		; K1>>lh = K1 length
	sta 0 N2		; K2>>lh = K2 length
	lda 0 @K1
	lda 1 @K2
	lda 3 c377
	and 3 1
	and 3 0
	sub 1 0	 szr		; K1>>rh - K2>>rh
	jmp @SKCRtn		; result if non-zero
; 1st chars are equal
	lda 0 N1
	lda 3 N2
	subl# 3 0 snc		; Skip if ac3 ge ac1
	mov 3 0
	sta 0 Nmin		; Nmin = min(N1,N2)
	inc 0 0
	movzr 0 0
	sta 0 Xmax		; Xmax = (Nmin+1) rshift 1
	jmp Lp1

N1:	0
N2:	0
K1:	0
K2:	0
Xmax:	0
Nmin:	0
SKCRtn:	0
c377:	377
c177400: 177400

Lp:	lda 0 @K1
	lda 1 @K2
	sub 1 0 szr
	jmp @SKCRtn		; Return with dif if unequal
Lp1:	isz K1
	isz K2
	dsz Xmax		; Skip when word count runs out
	jmp Lp

	lda 0 Nmin		; Nmin
	mkone 1 1
	and 1 0 szr		; Skip if Nmin is even
	jmp Xit
	lda 0 @K1
	lda 1 @K2
	lda 3 c177400
	ands 3 0
	ands 3 1
	sub 1 0 szr
	jmp @SKCRtn
Xit:	lda 0 N1
	lda 1 N2
	sub 1 0			; Length(K1)-length(K2)--longer greater
	jmp @SKCRtn

;//Returns index of greatest record in block with key le Key
;//if equal returns + index; if not equal returns - index
;//assumes SymbKeyComp(K1,K2) roughly is "K1 - K2"
;and BinScan(Block,Key) = valof
;[	let k,l = BHsize,Block>>BH.LastPntr
;	let C = SymbKeyComp(Key, Block+Block!l)
;	if C ge 0 then resultis (C > 0 ? -l, l)
;//Now know (symbol at k le Key) & (Key < symbol at l)
;	while k < l do
;	[ let m = (k+l) rshift 1
;	  C = SymbKeyComp(Key,Block+Block!m)
;	  if C eq 0 then resultis m
;	  test C < 0; ifso l = m; ifnot test k ne m
;	    ifso k = m; ifnot resultis -k
;	]
;	resultis -k
;]
.BinScan:
	inc 3 3
	sta 3 1 2		; Save return address
	sta 0 Block
	sta 1 Key
	lda 3 BHsize
	sta 3 K
	mov 0 3
	lda 1 0 3		; Block>>BH.LastPntr
	sta 1 L
	add 1 3
	lda 1 0 3		; Block!L
	add 0 1			; AC1←Block+Block!L
	lda 0 Key
	jsr .SymbKeyComp
	 2
	movl# 0 0 szc		; Skip if compared ge
	jmp BinBeg
	mov 0 1
	lda 0 L
	add# 1 1 szr		; Skip if compared eq
	neg 0 0			; resultis -L if unequal
	jmp @1 2		; resultis L if equal

Block:	0
Key:	0
K:	0
L:	0
M:	0

; Loop here with K in 0, L in 3 and K < L
BinLp:	add 3 0
	movzr 0 0
	sta 0 M			; M = (K+L) rshift 1
	lda 3 Block
	mov 3 1
	add 0 3
	lda 0 0 3		; Block!M
	add 0 1			; Block+Block!M
	lda 0 Key
	jsr .SymbKeyComp
	 2
	mov 0 1			; AC1←compare result
	lda 0 M
	mov# 1 1 snr		; if compare eq 0 then
	jmp @1 2		; resultis M
	movl# 1 1 snc		; Skip if C < 0
	jmp .+3
	sta 0 L
	jmp BinBeg
	lda 1 K
	sub# 1 0 szr		; if K eq M then
	jmp .+3
	neg 1 0
	jmp @1 2		; resultis -K
	sta 0 K
BinBeg:	lda 0 K
	lda 3 L
	adcl# 0 3 snc		; Skip if AC3 le AC0 (L le K)
	jmp BinLp
	neg 0 0
	jmp @1 2

AddrSymb:	3*400		; Symbol type eq AddrSymb in l.h.
SB77400:	77400

; SearchBlock(B,BOffset,BName,Addr,MemX)
.SearchBlock:
	sta 3 1 2
	jsr @GetFrame
	 22
	jsr @StArgs
	lda 3 AddrSymb
	lda 1 10 2		; MemX
	add 3 1
	sta 1 10 2		; AddrSymb,,MemX
	lda 3 @4 2		; Block = B>>BT.Core = B!0
	sta 3 4 2
	lda 0 BHsize
	mov 0 1
	add 3 0			; Block+BHsize = 1st pointer
	sta 0 14 2		; Block+I
	lda 3 0 3		; Block>>BH.LastPntr
	sub 1 3
	inc 3 3
	sta 3 11 2		; Last ptr - 1st ptr+1 = item count (> 0)
SBllp:	lda 3 4 2		; Block
	lda 0 @14 2		; Block!I
	add 0 3
	sta 3 12 2		; Block+Block!I
	lda 0 0 3
	lda 1 SB77400		; (Sign bit is a flag)
	ands 1 0		; String length in bytes
	movzr 0 0
	sta 0 13 2		; Save number of words in string - 1
	add 0 3			; Pointer to 1st non-text word - 1
	lda 0 1 3		; Type,,X
	lda 1 10 2
	sub# 1 0 szr		; AddrSymb and desired MemX?
	jmp SBend		; No, loop
	lda 0 7 2		; Get Addr being sought
	lda 3 2 3		; 1st word is address
	sub 3 0
	lda 3 @5 2		; Get best offset so far
	subl# 3 0 szc		; Better than best?
	movl# 0 0 szc		; Yes, greater than 0?
	jmp SBend		; No, loop
	sta 0 @5 2		; Yes, save new best offset
	lda 3 13 2		; Symbol size-1 = word count-1
	lda 1 6 2		; Pointer to name buffer
	add 3 1			; Last
	com 3 3			; - word count
	lda 0 12 2
	neg 0 0
	com 0 0			; From-1 = pointer to text-1
	blt
SBend:	isz 14 2		; Increment Block+I
	dsz 11 2		; Skip when item count runs out
	jmp SBllp
	jmp @Return

; GetBodySize(PtrToBody)
.GetBodySize:
	sta 3 1 2
	sta 0 2 2		; Preserve this arg just for the swat call
	mov 0 3
	lda 0 0 3		; Have symbol type in l.h. of 0
	lda 1 c3400
	ands 1 0		; Get symbol type in 0
	jsr GBS1
	 1			; Undefined--null string only
	 1			; MemSymb
	 1			; RegSymb
	 2			; AddrSymb
	 3			; LAddrSymb
	 170000			; Undefined
	 170000			; Undefined
	 170000			; Undefined
GBS1:	add 0 3
	lda 0 0 3		; Get body size for this type from table
	movl# 0 0 szc		; Skip if a defined block type
	jmp GBSswt		; else CallSwat
	lda 3 1 2
	jmp 1 3

GBSswt:	lda 0 2 2
	jsr @GetFrame
	 10
	jsr @StArgs
	lda 0 cNegBodySize
	jmp SwatCl

c3400:		3400
cNegBodySize:	NegBodySize

; GetStorage(Size) returns a pointer to a block of length size
;and GetStorage(Size) = valof
;[	EndStorage = EndStorage-Size
;	resultis Usc(Storage,EndStorage) < 0 ? EndStorage,
;		MidasSwat(OutOfStorage)
;]
.GetStorage:
	mov 0 1
	lda 0 @lvEndStorage
	sub 1 0
	sta 0 @lvEndStorage	; EndStorage = EndStorage-Size
	lda 1 @lvStorage
	adcz# 1 0 szc		; Approximates Usc with args reversed
	jmp .+4
	subz 0 1 szr
	subzl 1 1
	jmp .+2
	adc 1 1
	movl# 1 1 szc
	jmp 1 3			; resultis EndStorage
	sta 3 1 2
	jsr @GetFrame
	  10
	jsr @StArgs
	lda 0 OOS
SwatCl:	jsrii lvMidasSwat
	 1
	jsr @Return

OOS:		OutOfStorage
lvMidasSwat:	MidasSwat
lvEndStorage:	EndStorage
lvStorage:	Storage


; GetEvenStorage(Size) returns a pointer to a block of length size
; beginning on even word
.GetEvenStorage:
	sta 3 1 2
	jsr @GetFrame
	 10
	jsr @StArgs
	lda 0 4 2
	jsr .GetStorage		; Allocate a block of the exact size
	 1
	movr# 0 0 snc		; Skip if it's odd
	jsr @Return		; Even--return
	dsz @lvEndStorage	; Odd--increase size by 1 word
	lda 0 @lvEndStorage	; return even pointer
	jsr @Return

.end