--- /dev/null
+.define .aar2
+
+! Load address of array element, decriptor contains 2-bytes integers
+! Expects on stack: pointer to array descriptor
+! index
+! base address
+! Yields on stack: address of array element
+
+.aar2:
+ pop h
+ shld .retadr1
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! hl = pointer to descriptor
+ pop d ! de = index
+ mov a,e ! bc = index - lower bound
+ sub m
+ inx h
+ mov c,a
+ mov a,d
+ sbb m
+ inx h
+ mov b,a
+ push b ! first operand to multiply
+ inx h
+ inx h
+ mov c,m ! bc = size
+ inx h
+ mov b,m
+ push b ! second operand to multiply
+ call .mli2 ! de = size * (index - lower bound)
+ pop h ! hl = base address
+ dad d ! hl = address of array[index]
+ push h
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr1
+ pchl
--- /dev/null
+.define .adi4
+
+! Add two 32 bits signed or unsigned integers
+! Expects on stack: operands
+! Yields on stack: result
+
+.adi4: pop h
+ shld .retadr ! get return address out of the way
+ pop d
+ pop h
+ xthl
+ dad d
+ shld .tmp1
+ pop d
+ pop h
+ jnc 1f
+ inx h
+1: dad d
+ push h
+ lhld .tmp1
+ push h
+ lhld .retadr
+ pchl
--- /dev/null
+.define .and
+
+! Any size logical-'and'.
+! Expects: size in de-registers
+! operands on stack
+! Yields: result on stack
+
+.and: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi h,0
+ dad sp
+ mov c,l
+ mov b,h !now bc points to top of first operand
+ dad d !and hl points to top of second perand
+ push h !this will be the new stackpointer
+1: ldax b
+ ana m
+ mov m,a
+ inx h
+ inx b
+ dcx d
+ mov a,e
+ ora d
+ jnz 1b
+
+ pop h
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .blm
+
+! Block move
+! Expects in de-reg: size of block
+! Expects on stack: destination address
+! source address
+
+.blm: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! hl = destination address
+ pop b ! bc = source address
+
+1: ldax b
+ mov m,a
+ inx b
+ inx h
+ dcx d
+ mov a,d
+ ora e
+ jnz 1b
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
+
--- /dev/null
+.define .cii
+
+! Convert integer to integer
+! Expects in a-reg: 1 for signed integer to signed integer (cii)
+! 0 for unsigned integer to unsigned integer (cuu)
+! Expects on stack: destination size
+! source size
+! source
+! Yields on stack: result
+
+.cii: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ sta .areg ! save a-register
+ pop b
+ mov e,c
+ pop b ! c = source size
+ mov b,e ! b = destination size
+ mov a,b
+ cmp c
+ jz 3f ! destination size = source size
+ jc shrink ! destination size < source size
+
+! if destination size > source size only:
+ lxi h,0
+ dad sp
+ mov e,l
+ mov d,h ! de = stackpointer
+ mov a,b
+ sub c ! c = (still) source size
+ mov b,a ! b = destination size - source size
+ cma
+ mov l,a
+ mvi h,255
+ inx h
+ dad d ! hl = stackpointer - (dest. size - source size)
+ sphl ! new stackpointer
+
+1: ldax d ! move source downwards
+ mov m,a
+ inx d
+ inx h
+ dcr c
+ jnz 1b
+
+ ral ! a-reg still contains most significant byte of source
+ jnc 1f ! jump if is a positive integer
+ lda .areg
+ ora a
+ jz 1f ! jump if it is a cuu
+ mvi c,255 ! c-reg contains filler byte
+
+1: mov m,c ! fill
+ inx h
+ dcr b
+ jnz 1b
+ jmp 3f ! done
+
+!if destination size < source size only:
+shrink: mov l,c ! load source size in hl
+ mvi h,0
+ dad sp
+ mov d,h
+ mov e,l ! de points just above source
+ mov l,b ! load destination size in hl
+ mvi h,0
+ dad sp ! hl points just above "destination"
+
+1: dcx d ! move upwards
+ dcx h
+ mov a,m
+ stax d
+ dcr b
+ jnz 1b
+ sphl
+
+3: lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .cmi4
+
+! Compare 32 bits integers
+! Expects: operands on stack
+! a-register = 1 for signed integers
+! a-register = 0 for unsigned integers
+! Yields in de-registers: -1 if second operand < first operand
+! 0 if second operand = first operand
+! 1 if second operand > first operand
+
+.cmi4: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi b,4
+ lxi h,0
+ dad sp
+ dad b
+ dcx h
+ mov d,h
+ mov e,l !now de points to the first operand
+ dad b !and hl to the second
+ ora a !is it a cmi or cmu?
+ jz 1f
+
+!for cmi only:
+ mov a,m
+ ral
+ jnc 2f
+ ldax d !second operand is negative
+ ral
+ jc 1f !jump if both operands are negative
+ lxi d,-1 !second operand is smaller
+ jmp 4f
+2: ldax d !second operand is positive
+ ral
+ jnc 1f !jump if both operand are positive
+ lxi d,1 !second operand is larger
+ jmp 4f
+
+!cmi and cmu rejoin here
+1: ldax d
+ cmp m
+ jz 3f
+ jnc 2f
+ lxi d,1 !second operand is larger
+ jmp 4f
+2: lxi d,-1 !second operand is smaller
+ jmp 4f
+3: dcx d
+ dcx h
+ dcr c
+ jnz 1b
+ lxi d,0 !operands are equal
+
+4: lxi h,8
+ dad sp
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .cms
+
+! Any size compare
+! Expects: size in de-registers
+! operands on stack
+! Yields in de-registers: 0 if operands are equal
+! 1 if operands are not equal
+
+.cms:
+ pop h
+ shld .retadr
+
+ mov l,e
+ mov h,d
+ mov a,l
+ rar
+ cc eoddz !trap is size is odd
+ dad sp !now hl points to second operand
+ !and sp points to the first.
+1: dcx sp
+ pop psw !get next byte in accumulator
+ cmp m
+ inx h
+ dcx d
+ jnz 2f !jump if bytes are not equal
+ mov a,d
+ ora e
+ jnz 1b
+ jmp 3f
+2: dad d
+ lxi d,1
+3: sphl
+
+ lhld .retadr
+ pchl
--- /dev/null
+.define .com
+
+! Complement bytes on top of stack.
+! Expects in de-registers: number of bytes
+
+.com: pop h
+ shld .retadr
+ lxi h,0
+ dad sp
+1: mov a,m
+ cma
+ mov m,a
+ inx h
+ dcx d
+ mov a,e
+ ora d
+ jnz 1b
+ lhld .retadr
+ pchl
+
--- /dev/null
+.define .csa
+
+! Case jump
+! Expects on stack: address of case descriptor
+! case index
+! This is not a subroutine, but just a piece of code that computes
+! the jump address and jumps to it.
+! Traps if resulting address is zero.
+
+.csa: pop h !hl = address of case descriptor
+ pop d !de = index
+ push b !save localbase
+ mov c,m
+ inx h
+ mov b,m
+ inx h
+ push b !save default pointer on stack
+ mov a,e
+ sub m
+ inx h
+ mov c,a
+ mov a,d
+ sbb m
+ inx h
+ mov b,a !bc = index - lower bound
+ jc 1f !get default pointer
+ mov a,m
+ inx h
+ sub c
+ mov a,m
+ inx h
+ sbb b
+ jc 1f !upper-lower should be >= index-lower
+ dad b
+ dad b !hl now points to the wanted pointer
+ mov a,m
+ inx h
+ mov h,m
+ mov l,a !hl = pointer for index
+ ora h
+ jz 1f !get default pointer if pointer = 0
+ pop b !remove default pointer
+ pop b !localbase
+ pchl !jump!!!!
+
+1: pop h !get default pointer
+ mov a,l
+ ora h
+ cz ecase !trap
+ pop b !restore localbase
+ pchl !jump!!!!
+
--- /dev/null
+.define .csb
+
+! Table lookup jump
+! Expects on stack: address of case descriptor
+! case index
+! This is not a subroutine, but just a piece of code that computes
+! the jump address and jumps to it.
+! Traps if resulting address is zero.
+
+.csb: pop h !hl = pointer to descriptor
+ pop d !de = case index
+ push b !save localbase
+ mov c,m !bc = default pointer
+ inx h
+ mov b,m
+ inx h
+ push b !save default on stack
+ mov c,m !bc = number of entries
+ inx h
+ mov b,m
+ inx h
+!loop: try to find the case index in the descriptor
+1: mov a,b
+ ora c
+ jz 4f !done, index not found
+ mov a,m !do we have the right index?
+ inx h
+ cmp e
+ jnz 2f !no
+ mov a,m
+ inx h
+ cmp d
+ jnz 3f !no
+ mov a,m
+ inx h
+ mov h,m
+ mov l,a
+ pop psw !remove default pointer
+ jmp 5f
+
+2: inx h !skip high byte of index
+3: inx h !skip jump address
+ inx h
+ dcx b
+ jmp 1b
+
+4: pop h !take default exit
+5: pop b !restore localbase
+ mov a,l !jump address is zero?
+ ora h
+ cz ecase !trap
+ pchl !jump!!!!
+
--- /dev/null
+.define .dup
+
+! Duplicate top bytes of stack
+! Expects in de-registers: number of bytes to duplicate
+
+.dup: mov a,e !trap if number is odd
+ rar
+ cc eoddz
+
+ pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ mov h,d
+ mov l,e
+ dad sp
+1: dcx h
+ mov b,m
+ dcx h
+ mov c,m
+ push b
+ dcx d
+ dcx d !number of bytes must be a word-multiple i.e. even
+ mov a,d
+ ora e
+ jnz 1b
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+
+.define .dvi2
+
+! 16 bits signed and unsigned integer divide and remainder routine
+! Bit 0 of a-reg is set iff quotient has to be delivered
+! Bit 7 of a-reg is set iff the operands are signed, so:
+! Expects in a-reg: 0 if called by rmu 2
+! 1 if called by dvu 2
+! 128 if called by rmi 2
+! 129 if called by dvi 2
+! Expects on stack: divisor
+! dividend
+! Yields in de-reg: quotient or remainder
+
+.dvi2: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ sta .areg
+ pop b ! bc = divisor
+ mov a,b ! trap if divisor = 0
+ ora c
+ cz eidivz
+ pop d ! de = dividend
+
+ mvi h,0
+ lda .areg
+ ral
+ jnc 0f ! jump if unsigned
+
+ mov a,d
+ ral
+ jnc 1f ! jump if dividend >= 0
+ mvi h,129 ! indicate dividend is negative
+ xra a ! negate dividend
+ sub e
+ mov e,a
+ mvi a,0
+ sbb d
+ mov d,a
+ ! de is positive now
+
+1: mov a,b
+ ral
+ jc 2f ! jump if divisor < 0
+0: inr h ! indicate negation
+ xra a ! negate divisor
+ sub c
+ mov c,a
+ mvi a,0
+ sbb b
+ mov b,a
+ ! bc is negative now
+
+2: push h ! save h-reg
+ lxi h,0 ! initial value of remainder
+ mvi a,16 ! initialize loop counter
+
+3: push psw ! save loop counter
+ dad h ! shift left: hl <- de <- 0
+ xchg
+ dad h
+ xchg
+ jnc 4f
+ inx h
+
+4: push h ! save remainder
+ dad b ! subtract divisor (add negative)
+ jnc 5f
+ xthl
+ inx d
+
+5: pop h
+ pop psw ! restore loop counter
+ dcr a
+ jnz 3b
+
+ pop b ! b-reg becomes what once was h-reg
+ lda .areg
+ rar ! what has to be delivered: quotient or remainder?
+ jnc 6f
+
+! for dvi 2 and dvu 2 only:
+ mov a,b
+ rar
+ jc 8f ! jump if divisor and dividend had same sign
+ xra a ! negate quotient
+ sub e
+ mov e,a
+ mvi a,0
+ sbb d
+ mov d,a
+ jmp 8f
+
+! for rmi 2 and rmu 2 only:
+6: mov a,b
+ ral
+ jnc 7f ! negate remainder if dividend was negative
+ xra a
+ sub l
+ mov l,a
+ mvi a,0
+ sbb h
+ mov h,a
+7: mov d,h ! return remainder
+ mov e,l
+
+8: lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .dvi4
+
+! 32 bits integer divide and remainder routine
+! Bit 0 of a-reg is set iff quotient has to be delivered
+! Bit 7 of a-reg is set iff the operands are signed, so:
+! Expects in a-reg: 0 if called by rmu 4
+! 1 if called by dvu 4
+! 128 if called by rmi 4
+! 129 if called by dvi 4
+! Expects on stack: divisor
+! dividend
+! Yields on stack: quotient or remainder
+
+.dvi4: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ sta .areg
+ pop h ! store divisor
+ shld block3
+ xchg
+ pop h
+ shld block3+2
+ dad d
+ jc 1f
+ mov a,l
+ ora h
+ cz eidivz ! trap if divisor = 0
+
+1: pop h ! store dividend
+ shld block1
+ pop h
+ shld block1+2
+ lxi h,0 ! store initial value of remainder
+ shld block2
+ shld block2+2
+
+ mvi b,0
+ lda .areg
+ ral
+ jnc 2f ! jump if unsigned
+
+ lda block1+3
+ ral
+ jnc 1f
+ mvi b,129
+ lxi h,block1
+ call compl ! dividend is positive now
+
+1: lda block3+3
+ ral
+ jnc 2f
+ inr b
+ lxi h,block3
+ call compl ! divisor is positive now
+
+2: push b ! save b-reg
+ mvi b,32
+
+dv0: lxi h,block1 ! left shift: block2 <- block1 <- 0
+ mvi c,8
+ xra a
+1: mov a,m
+ ral
+ mov m,a
+ inx h
+ dcr c
+ jnz 1b
+ lxi h,block2+3 ! which is larger: divisor or remainder?
+ lxi d,block3+3
+ mvi c,4
+1: ldax d
+ cmp m
+ jz 0f
+ jnc 3f
+ jmp 4f
+0: dcx d
+ dcx h
+ dcr c
+ jnz 1b
+
+4: lxi d,block2 ! remainder is larger or equal: subtract divisor
+ lxi h,block3
+ mvi c,4
+ xra a
+1: ldax d
+ sbb m
+ stax d
+ inx d
+ inx h
+ dcr c
+ jnz 1b
+ lxi h,block1
+ inr m
+
+3: dcr b
+ jnz dv0 ! keep looping
+
+ pop b
+ lda .areg ! quotient or remainder?
+ rar
+ jnc 4f
+
+! for dvi 4 and dvu 4 only:
+ mov a,b
+ rar
+ lxi h,block1 ! complement quotient if divisor
+ cc compl ! and dividend have different signs
+ lhld block1+2 ! push quotient
+ push h
+ lhld block1
+ push h
+ jmp 5f
+
+! for rmi 4 and rmu 4 only:
+4: mov a,b
+ ral
+ lxi h,block2
+ cc compl ! negate remainder if dividend was negative
+ lhld block2+2
+ push h
+ lhld block2
+ push h
+
+5: lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
+
+! make 2's complement of 4 bytes pointed to by hl.
+compl: push b
+ mvi c,4
+ xra a
+1: mvi a,0
+ sbb m
+ mov m,a
+ inx h
+ dcr c
+ jnz 1b
+ pop b
+ ret
+
--- /dev/null
+.define .exg
+
+! Exchange top bytes of stack
+! Expects in de-registers the number of bytes to be exchanged.
+
+.exg: mov a,e
+ rar
+ cc eoddz !trap if numer of bytes is odd
+ pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi h,0
+ dad sp
+ mov b,h
+ mov c,l !now bc points to first operand
+ dad d !and hl to the second
+ push d !place number of bytes on top of stack
+1: mov d,m
+ ldax b
+ mov m,a
+ mov a,d
+ stax b
+ xthl !caused by a lack of registers
+ dcx h !decrement top of stack
+ mov a,h
+ ora l
+ xthl
+ inx h
+ inx b
+ jnz 1b
+
+ pop d
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .inn
+
+! Any size bit test on set.
+! Expects in de-reg: size of set (in bytes)
+! Expects on stack: bit number
+! set to be tested
+! Yields in de-reg.: 0 if bit is reset or bit number out of range
+! 1 if bit is set
+
+.inn: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h
+ xchg !hl = size, de = bit number
+ mov a,d !test if bit number is negative
+ ral
+ jc 3f
+ mov a,e
+ ani 7
+ mov b,a !save bits 0-2 of bit number in b-reg
+ mvi c,3
+1: xra a
+ mov a,d !shift bit number right 3 times
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a
+ dcr c
+ jnz 1b
+
+ mov a,l !test if bit number is small enough
+ sub e
+ mov a,h
+ sbb d
+ jc 3f
+ xchg
+ dad sp
+ xchg
+ ldax d !a-register = wanted byte
+2: dcr b !dcr doesn't affect carry bit
+ jm 4f
+ rar
+ jmp 2b
+
+3: xra a !return 0 if bit number out of range
+4: ani 1
+ mov e,a
+ mvi d,0
+ dad sp
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
+
--- /dev/null
+.define .ior
+
+
+! Any size inclusive-or.
+! Expects: size in de-registers
+! operands on stack
+! Yields: result on stack
+
+.ior: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi h,0
+ dad sp
+ mov c,l
+ mov b,h !now bc points to top of first operand
+ dad d !and hl points to top of second operand
+ push h !this will be the new stackpointer
+1: ldax b
+ ora m
+ mov m,a
+ inx h
+ inx b
+ dcx d
+ mov a,e
+ ora d
+ jnz 1b
+
+ pop h
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .lar2
+
+! Load array element, descriptor contains 2-bytes integers
+! Expects on stack: pointer to array descriptor
+! index
+! base address
+! Yields on stack: array element
+! Adapted from .aar2 and .loi
+
+.lar2:
+ pop h
+ shld .retadr1
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! hl = pointer to descriptor
+ pop d ! de = index
+ mov a,e ! bc = index - lower bound
+ sub m
+ inx h
+ mov c,a
+ mov a,d
+ sbb m
+ inx h
+ mov b,a
+ push b ! first operand to multiply
+ inx h
+ inx h
+ mov c,m ! bc = size
+ inx h
+ mov b,m
+ push b ! second operand to multiply
+ call .mli2 ! de = size * (index - lower bound)
+ pop h ! hl = base address
+ dad d ! hl = address of array[index]
+ dad b ! hl= load pointer
+ xra a ! clear carry bit
+ mov a,b ! divide bc by 2
+ rar
+ mov b,a
+ mov a,c
+ rar
+ mov c,a
+ jnc 1f
+
+! for 1 byte array element only:
+ mov a,c ! trap if bc odd and <>1
+ ora b
+ cnz eoddz
+ dcx h
+ mov e,m
+ mvi d,0
+ push d
+ jmp 2f
+
+1: dcx h
+ mov d,m
+ dcx h
+ mov e,m
+ push d
+ dcx b
+ mov a,b
+ ora c
+ jnz 1b
+
+2: lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr1
+ pchl
--- /dev/null
+.define .loi
+
+! Load indirect
+! Expects in de-registers: number of bytes to be loaded
+! (this number should be 1 or even )
+! Expects on stack: base address
+! Yields on stack: result
+
+.loi: pop h
+ shld .retadr
+ mov l,c ! free bc for scratch
+ mov h,b
+ shld .bcreg
+
+ pop h ! hl = base address
+ dad d ! hl = load pointer
+ xra a ! clear carry bit
+ mov a,d ! divide d by 2
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a
+ jnc 1f
+
+! if 1 byte has to be loaded only:
+ mov a,d
+ ora e
+ cnz eoddz ! trap if number is odd and <> 1
+ dcx h
+ mov c,m
+ mvi b,0
+ push b
+ jmp 2f
+
+1: dcx h
+ mov b,m
+ dcx h
+ mov c,m
+ push b
+ dcx d ! is count exhausted?
+ mov a,d
+ ora e
+ jnz 1b
+
+2: lhld .bcreg
+ mov c,l
+ mov b,h
+ lhld .retadr
+ pchl
--- /dev/null
+.define .mli2
+
+! 16 bits signed integer multiply
+! the algorithm multiples A * B, where A = A0*2^8 + A1 and B = B0*2^8 + B1
+! product is thus A0*B0*2^16 + 2^8 * (A0 * B1 + B0 * A1) + A0 * B0
+! hence either A0 = 0 or B0 = 0 or overflow.
+! initial part of code determines which high byte is 0 (also for negative #s)
+! then the multiply is reduced to 8 x 16 bits, with the 8 bit number in the
+! a register, the 16 bit number in the hl register, and the product in de
+! Expects operands on stack
+! Yields result in de-registers
+
+.mli2: pop h
+ shld .retadr ! get the return address out of the way
+ lxi h,255
+ pop d
+ mov a,d ! check hi byte for 0
+ cmp h ! h = 0
+ jz 1f ! jump if de is a positive 8 bit number
+ cmp l
+ jz 5f ! jump if de is a negative 8 bit number
+ xchg
+ shld .tmp1 ! we ran out of scratch registers
+ pop h
+ mov a,h
+ cmp e
+ jz 7f ! jump if second operand is 8 bit negative
+ jmp 6f ! assume second operand is 8 bit positive
+
+1: mov a,e ! 8 bit positive number in a
+ pop h ! 16 bit number in hl
+
+! here is the main loop of the multiplication. the a register is shifted
+! right 1 bit to load the carry bit for testing.
+! as soon as the a register goes to zero, the loop terminates.
+! in most cases this requires fewer than 8 iterations.
+2: lxi d,0
+ ora a
+3: rar ! load carry bit from a
+ jnc 4f ! add hl to de if low bit was a 1
+ xchg
+ dad d
+ xchg
+4: dad h
+ ora a ! sets zero correct and resets carry bit
+ jnz 3b ! if a has more bits, continue the loop
+ lhld .retadr ! go get return address
+ pchl
+
+! the 8 bit operand is negative. negate both operands
+5: pop h
+ mov a,l
+ cma
+ mov l,a
+ mov a,h
+ cma
+ mov h,a
+ inx h ! 16 bit negate is 1s complement + 1
+ xra a
+ sub e ! negate 8 bit operand
+ jmp 2b
+
+! second operand is small and positive
+6: mov a,l
+ lhld .tmp1
+ jmp 2b
+
+! second operand is small and negative
+7: mov e,l
+ lhld .tmp1
+ mov a,l
+ cma
+ mov l,a
+ mov a,h
+ cma
+ mov h,a
+ inx h
+ xra a
+ sub e
+ jmp 2b
--- /dev/null
+.define .mli4
+
+! 32 bits signed and unsigned integer multiply routine
+! Expects operands on stack
+! Yields product on stack
+
+.mli4: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! store multiplier
+ shld block1
+ pop h
+ shld block1+2
+ pop h ! store multiplicand
+ shld block2
+ pop h
+ shld block2+2
+ lxi h,0
+ shld block3 ! product = 0
+ shld block3+2
+ lxi b,0
+lp1: lxi h,block1
+ dad b
+ mov a,m ! get next byte of multiplier
+ mvi b,8
+lp2: rar
+ jnc 2f
+ lhld block2 ! add multiplicand to product
+ xchg
+ lhld block3
+ dad d
+ shld block3
+ lhld block2+2
+ jnc 1f
+ inx h
+1: xchg
+ lhld block3+2
+ dad d
+ shld block3+2
+
+2: lhld block2 ! shift multiplicand left
+ dad h
+ shld block2
+ lhld block2+2
+ jnc 3f
+ dad h
+ inx h
+ jmp 4f
+3: dad h
+4: shld block2+2
+
+ dcr b
+ jnz lp2
+
+ inr c
+ mov a,c
+ cpi 4
+ jnz lp1
+
+ lhld block3+2
+ push h
+ lhld block3
+ push h
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .mlu2
+
+! 16 bits unsigned multiply routine
+! Expects operands on stack
+! Yields result in de-registers
+! This routine could also be used for signed integers, but it won't
+! because there is a more clever one just for signed integers.
+
+.mlu2:
+ pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop b ! bc = multiplier
+ pop d ! de = multiplicand
+ lxi h,0 ! hl = product
+
+1: mov a,b ! if multiplier = 0 then finished
+ ora c
+ jz 3f
+
+ xra a ! reset carry
+ mov a,b ! shift multiplier right
+ rar
+ mov b,a
+ mov a,c
+ rar
+ mov c,a
+
+ jnc 2f !if carry set: add multiplicand to product
+ dad d
+
+2: xchg ! shift multiplicand left
+ dad h
+ xchg
+ jmp 1b ! keep looping
+
+3: xchg ! de becomes product
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .ngi4
+
+! Exchange 32 bits integer by its two's complement
+! Expects operand on stack
+! Yields result on stack
+
+.ngi4: pop d
+ lxi h,0
+ dad sp
+ xra a
+ sub m
+ mov m,a
+ inx h
+ mvi a,0
+ sbb m
+ mov m,a
+ inx h
+ mvi a,0
+ sbb m
+ mov m,a
+ inx h
+ mvi a,0
+ sbb m
+ mov m,a
+ push d
+ ret
--- /dev/null
+.define .nop
+
+.nop: push b
+ lhld hol0+4
+ mov d,h
+ mov e,l
+ call prstring
+ lxi d,lin
+ call prstring
+ lhld hol0
+ call prdec
+ lxi d,stpr
+ call prstring
+ lxi h,0
+ dad sp
+ call prdec
+ lxi d,newline
+ call prstring
+ pop b
+ ret
+
+
+lin: .asciz " lin:"
+stpr: .asciz " sp:"
+newline:.asciz "\n"
--- /dev/null
+.define .rck
+
+! Range check
+! Expects on stack: address of range check descriptor
+! index
+! Yields index on stack unchanged
+! Causes a trap if index is out of bounds
+
+.rck: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! hl = return address
+ pop d ! de = index
+ mov c,m ! bc = lower bound
+ inx h
+ mov b,m
+ inx h
+ mov a,d
+ xor b
+ jm 1f ! jump if index and l.b. have different signs
+ mov a,e
+ sub c
+ mov a,d
+ sbb b
+ jmp 2f
+
+1: xor b ! now a = d again
+2: cm erange ! trap if index too small
+
+ mov c,m
+ inx h
+ mov b,m
+ mov a,d
+ xor b
+ jm 1f ! jump if index and u.b. have different signs
+ mov a,c
+ sub e
+ mov a,b
+ sbb d
+ jmp 2f
+
+1: xor d ! now a = b
+2: cm erange ! trap if index is too large
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .rol4
+
+! Rotate 4 bytes left
+! Expects in de-reg: number of rotates
+! Expects on stack: operand
+! Yields on stack: result
+
+.rol4 pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+.rol4: pop h ! low-order bytes of operand
+ pop b ! high order bytes of operand
+
+ mov a,e
+ ani 31
+ jz 2f
+ mov e,a
+
+ mov a,b
+ ral
+1: mov a,l
+ ral
+ mov l,a
+ mov a,h
+ ral
+ mov h,a
+ mov a,c
+ ral
+ mov c,a
+ mov a,b
+ ral
+ mov b,a
+
+ dcr e
+ jnz 1b ! keep looping
+
+2: push b
+ push h
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .ror4
+
+! Rotate 4 bytes right
+! Expects in de-reg: number of rotates
+! Expects on stack: operand
+! Yields on stack: result
+
+.ror4 pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+.ror4: pop h ! low-order bytes of operand
+ pop b ! high order bytes of operand
+
+ mov a,e
+ ani 31
+ jz 2f
+ mov e,a
+
+ mov a,l
+ rar
+1: mov a,b
+ rar
+ mov b,a
+ mov a,c
+ rar
+ mov c,a
+ mov a,h
+ rar
+ mov h,a
+ mov a,l
+ rar
+ mov l,a
+
+ dcr e
+ jnz 1b ! keep looping
+
+2: push b
+ push h
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .sar2
+
+! Store array element, descriptor contains 2-bytes integers
+! Expects on stack: pointer to array descriptor
+! index
+! base address
+! array element
+! Adapted from .aar2 and .sti
+
+.sar2:
+ pop h
+ shld .retadr1
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop h ! hl = pointer to descriptor
+ pop d ! de = index
+ mov a,e ! bc = index - lower bound
+ sub m
+ inx h
+ mov c,a
+ mov a,d
+ sbb m
+ inx h
+ mov b,a
+ push b ! first operand to multiply
+ inx h
+ inx h
+ mov c,m ! bc = size
+ inx h
+ mov b,m
+ push b ! second operand to multiply
+ call .mli2 ! de = size * (index - lower bound)
+ pop h ! hl = base address
+ dad d ! hl = address of array[index]
+ xra a
+ mov a,b
+ rar
+ mov b,a
+ mov a,c
+ rar
+ mov c,a ! bc = word count
+ jnc 1f
+
+! if 1 byte array element only:
+ mov a,c ! trap if bc odd and <>1
+ ora b
+ cnz eoddz
+ pop d
+ mov m,e
+ jmp 2f
+
+1: pop d
+ mov m,e
+ inx h
+ mov m,d
+ inx h
+ dcx b
+ mov a,b
+ ora c
+ jnz 1b
+
+2: lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr1
+ pchl
--- /dev/null
+.define .sbi4
+
+! Subtract two 32 bits signed or unsigned integers.
+! Expects operands on stack
+! Yields result on stack
+
+.sbi4:
+ pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi h,0
+ dad sp !now hl points to the first operand
+ mov d,h
+ mov e,l
+ inx d
+ inx d
+ inx d
+ inx d !and de points to the second.
+ mvi b,4
+ xra a
+1: ldax d
+ sbb m
+ stax d
+ inx d
+ inx h
+ dcr b
+ jnz 1b
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .set
+
+! Create set with one bit on
+! Expects in de-reg: size of set to be created
+! Expects on stack: bit number
+! Yields on stack: resulting set
+
+.set: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ mov a,e
+ rar
+ cc eoddz ! trap if size is odd
+ xchg ! hl = size of set
+ pop d ! de = bit number
+ mov a,e ! c = bit number in byte
+ ani 7
+ sta .areg ! save bit number in byte
+
+ mvi b,3 ! de = byte number
+1: xra a
+ mov a,d
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a
+ dcr b
+ jnz 1b
+
+ mov a,l ! trap if bit number is too large
+ sub e
+ mov a,h
+ sbb d
+ cc eset
+
+ lxi b,0 ! make empty set on stack
+1: push b
+ dcx h
+ dcx h
+ mov a,l
+ ora h
+ jnz 1b
+
+ lxi h,0
+ dad sp
+ dad d ! hl points to byte that will contain a one
+ lda .areg
+ mov c,a ! c = bit number in byte
+ mvi a,1
+1: dcr c
+ jm 2f
+ rlc
+ jmp 1b
+
+2: mov m,a
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .set2
+
+! Create 16 bits set with one bit on
+! Expects in de-reg: bit number
+! Yields in de-reg: resulting set
+
+.set2: mov a,d !trap if bit number >= 16
+ ora a
+ cnz eset
+ mov a,e
+ cpi 16
+ cnc eset
+
+ pop h
+ shld .retadr
+ mov a,e
+ ani 7
+ mov d,a
+ mvi a,1
+1: dcr d
+ jm 2f
+ rlc
+ jmp 1b
+2: mov d,a
+ mov a,e
+ ani 8
+ jnz 3f ! jump if bit 3 is set
+
+ mov e,d
+ mvi d,0
+ jmp 4f
+
+3: mvi e,0
+
+4: lhld .retadr
+ pchl
--- /dev/null
+.define .sli2
+
+! Shift 16 bits integer left
+! Expects on stack: number of shifts
+! number to be shifted
+! Yields in de-reg: result
+
+.sli2: pop h
+ shld .retadr
+
+ pop d !de = number of shifts
+ pop h !hl= number to be shifted
+ mov a,d !if de>15 return zero
+ ora a
+ jnz 2f
+ mov a,e
+ cpi 16
+ jnc 2f
+1: dcr e
+ jm 3f
+ dad h
+ jmp 1b
+
+2: lxi h,0
+3: xchg !result in de-registers
+
+ lhld .retadr
+ pchl
--- /dev/null
+.define .sli4
+
+! Shift 32 bits integer left
+! Expects on stack: number of shifts
+! number to be shifted
+! Yields on stack: result
+
+.sli4:
+ pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop b !number of shifts
+ pop d !low-order bytes of number to be shifted
+ pop h !high-order bytes
+ mov a,b !if bc>=32 return 0
+ ora a
+ jnz 2f
+ mov a,c
+ cpi 32
+ jnc 2f
+1: dcr c
+ jm 3f
+ dad h
+ xchg
+ dad h
+ xchg
+ jnc 1b
+ inx h
+ jmp 1b
+
+2: lxi h,0
+ lxi d,0
+
+3: push h
+ push d
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
+
--- /dev/null
+.define .sri2
+
+! Shift 16 bits signed or unsigned integer right
+! Expects in a-reg.: 1 if signed integer
+! 0 if unsigned integer
+! Expects on stack: number of shifts
+! number to be shifted
+! Yields in de-reg.: result
+
+.sri2: pop h
+ shld .retadr
+
+ pop h !hl = number of shifts
+ pop d !de = number to be shifted
+ mvi h,0
+ ora a
+ jz 1f !jump if unsigned integer
+ mov a,d
+ ral
+ jnc 1f !jump if positive signed integer
+ mvi h,255 !now h=1 if negative signed number, h=0 otherwise.
+
+1: mov a,l !return 0 or -1 if hl>=16
+ cpi 16
+ jnc 3f
+
+2: dcr l
+ jm 4f
+ mov a,h
+ rar !set carry bit correct
+ mov a,d
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a
+ jmp 2b
+
+3: mov d,h
+ mov e,h
+
+4: lhld .retadr
+ pchl
--- /dev/null
+.define .sri4
+
+! Shift 32 bits signed or unsigned integer right
+! Expects in a-reg.: 1 if signed integer
+! 0 if unsigned integer
+! Expects on stack: number of shifts
+! number to be shifted
+! Yields on stack: result
+
+.sri4: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ pop b !number of shifts
+ pop d !low-order bytes of number to be shifted
+ pop h !high-order bytes
+ mvi b,0
+ ora a
+ jz 1f !jump if unsigned integer
+ mov a,h
+ ral
+ jnc 1f !jump if positive signed integer
+ mvi b,255
+
+1: mov a,c
+ cpi 32
+ jnc 3f
+
+2: dcr c
+ jm 4f
+ mov a,b
+ rar
+ mov a,h
+ rar
+ mov h,a
+ mov a,l
+ rar
+ mov l,a
+ mov a,d
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a
+ jmp 2b
+
+3: mov d,b
+ mov e,b
+ mov h,b
+ mov l,b
+
+4: push h
+ push d
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .sti
+
+! Store indirect
+! Expects on stack: number of bytes to be stored
+! bytes to be stored
+
+.sti: pop h
+ shld .retadr
+ mov l,c
+ mov h,b
+ shld .bcreg ! save bc
+
+ pop h
+ xra a
+ mov a,d
+ rar
+ mov d,a
+ mov a,e
+ rar
+ mov e,a ! de = word count
+ jnc 1f
+
+! if 1 byte array element only:
+ mov a,d ! trap if de odd and <>1
+ ora e
+ cnz eoddz
+ pop b
+ mov m,c
+ jmp 2f
+
+1: pop b
+ mov m,c
+ inx h
+ mov m,b
+ inx h
+ dcx d
+ mov a,d
+ ora e
+ jnz 1b
+
+2: lhld .bcreg
+ mov c,l
+ mov b,h
+ lhld .retadr
+ pchl
+
--- /dev/null
+.define .xor
+
+
+! Any size exclusive-or.
+! Expects: size in de-registers
+! operands on stack
+! Yields: result on stack
+
+.xor: pop h
+ shld .retadr
+ mov h,b
+ mov l,c
+ shld .bcreg
+
+ lxi h,0
+ dad sp
+ mov c,l
+ mov b,h !now bc points to top of first operand
+ dad d !and hl points to top of second operand
+ push h !this will be the new stackpointer
+1: ldax b
+ xra m
+ mov m,a
+ inx h
+ inx b
+ dcx d
+ mov a,e
+ ora d
+ jnz 1b
+
+ pop h
+ sphl
+
+ lhld .bcreg
+ mov b,h
+ mov c,l
+ lhld .retadr
+ pchl
--- /dev/null
+.define .inn2
+
+! Bit test on 16 bits set
+! Expects on stack: bit number
+! set to be tested
+! Yields in de-registers: 0 if bit is reset or bit number out of range
+! 1 if bit is set
+
+.inn2: pop h
+ shld .retadr
+
+ pop d !bit number
+ pop h !set to be tested
+ mov a,e
+ cpi 16
+ jnc 3f
+ cpi 8
+ jnc 1f
+ mov e,a
+ mov a,l !l-reg contains the wanted bit
+ jmp 2f
+
+1: sbi 8
+ mov e,a
+ mov a,h !h-reg contains the wanted bit
+
+2: dcr e
+ jm 4f
+ rar
+ jmp 2b
+
+3: xra a !return 0 if bit number out of range
+4: ani 1
+ mov e,a
+ mvi d,0
+
+ lhld .retadr
+ pchl
--- /dev/null
+.define prdec
+
+! print hl-reg as a decimal number.
+
+prdec: push h
+ push d
+ push b
+ push psw
+ lxi d,table
+ mvi b,4
+1: call convert
+ ori 0x30
+ call putchar
+ dcr b
+ jnz 1b
+ mov a,l
+ ori 0x30
+ call putchar
+ pop psw
+ pop b
+ pop d
+ pop h
+ ret
+
+convert:
+ push b
+ mov b,h
+ mov c,l
+ xchg
+ mov e,m
+ inx h
+ mov d,m
+ inx h
+ push h ! save pointer to new value
+ mov h,b
+ mov l,c
+ mvi b,255
+1: inr b
+ mov a,l
+ sub e
+ mov l,a
+ mov a,h
+ sbb d
+ mov h,a
+ jnc 1b
+ dad d
+ mov a,b
+ pop d
+ pop b
+ ret
+
+table:
+ .short 10000
+ .short 1000
+ .short 100
+ .short 10
+
--- /dev/null
+.define prstring
+
+! print a string of characters to the console
+! entry: de-reg points to the string
+! string terminator is 0x00
+! exit: de-reg points to string terminator
+
+prstring:
+ push psw
+1: ldax d
+ ora a
+ jz 2f
+ call putchar
+ inx d
+ jmp 1b
+2: pop psw
+ ret
+
--- /dev/null
+.define endtext, enddata, endbss
+.text
+endtext: .align 2
+.data
+enddata: .align 2
+.bss
+endbss: .align 2
--- /dev/null
+.define .trp
+.define earray, erange, eset, eiovfl, efovfl, efunfl, eidivz, eidivz
+.define efdivz, eiund, efund, econv, estack, eheap, eillins, eoddz
+.define ecase, ememflt, ebadptr, ebadpc, ebadlae, ebadmon, ebadlin, ebadgto
+.define eunimpl
+
+! Trap routine
+! Expects trap number on stack.
+! Just returns if trap has to be ignored.
+! Otherwise it calls a user-defined trap handler if provided.
+! When no user-defined trap handler is provided or when the user-defined
+! trap handler causes a new trap, a message is printed
+! and control is returned to the monitor.
+
+ EARRAY = 0
+ ERANGE = 1
+ ESET = 2
+ EIOVFL = 3
+ EFOVFL = 4
+ EFUNFL = 5
+ EIDIVZ = 6
+ EFDIVZ = 7
+ EIUND = 8
+ EFUND = 9
+ ECONV = 10
+ ESTACK = 16
+ EHEAP = 17
+ EILLINS = 18
+ EODDZ = 19
+ ECASE = 20
+ EMEMFLT = 21
+ EBADPTR = 22
+ EBADPC = 23
+ EBADLAE = 24
+ EBADMON = 25
+ EBADLIN = 26
+ EBADGTO = 27
+ EUNIMPL = 63 ! unimplemented em-instruction called
+
+earray: lxi h,EARRAY
+ push h
+ call .trp
+ ret
+
+erange: lxi h,ERANGE
+ push h
+ call .trp
+ ret
+
+eset: lxi h,ESET
+ push h
+ call .trp
+ ret
+
+eiovfl: lxi h,EIOVFL
+ push h
+ call .trp
+ ret
+
+efovfl: lxi h,EFOVFL
+ push h
+ call .trp
+ ret
+
+efunfl: lxi h,EFUNFL
+ push h
+ call .trp
+ ret
+
+eidivz: lxi h,EIDIVZ
+ push h
+ call .trp
+ ret
+
+efdivz: lxi h,EFDIVZ
+ push h
+ call .trp
+ ret
+
+eiund: lxi h,EIUND
+ push h
+ call .trp
+ ret
+
+efund: lxi h,EFUND
+ push h
+ call .trp
+ ret
+
+econv: lxi h,ECONV
+ push h
+ call .trp
+ ret
+
+estack: lxi h,ESTACK
+ push h
+ call .trp
+ ret
+
+eheap: lxi h,EHEAP
+ push h
+ call .trp
+ ret
+
+eillins:lxi h,EILLINS
+ push h
+ call .trp
+ ret
+
+eoddz: lxi h,EODDZ
+ push h
+ call .trp
+ ret
+
+ecase: lxi h,ECASE
+ push h
+ call .trp
+ ret
+
+ememflt:lxi h,EMEMFLT
+ push h
+ call .trp
+ ret
+
+ebadptr:lxi h,EBADPTR
+ push h
+ call .trp
+ ret
+
+ebadpc: lxi h,EBADPC
+ push h
+ call .trp
+ ret
+
+ebadlae:lxi h,EBADLAE
+ push h
+ call .trp
+ ret
+
+ebadmon:lxi h,EBADMON
+ push h
+ call .trp
+ ret
+
+ebadlin:lxi h,EBADLIN
+ push h
+ call .trp
+ ret
+
+ebadgto:lxi h,EBADGTO
+ push h
+ call .trp
+ ret
+
+eunimpl:lxi h,EUNIMPL
+ push h
+ call .trp
+ ret
+
+.trp:
+ pop h
+ xthl
+ push h ! trap number and return address exchanged
+ mov a,l
+ cpi 16
+ jnc 3f ! jump if trap cannot be ignored
+
+! check if trap has to be ignored
+ xchg ! de = trap number
+ lhld .ignmask
+ push h ! hl = set to be tested
+ push d
+ call .inn2 ! de = 1 if bit is set, 0 otherwise
+ mov a,e
+ rar
+ jnc 3f ! jump if trap should not be ignored
+ pop h ! remove trap number
+ ret ! OGEN DICHT EN ... SPRING!!!
+
+3:
+ lhld .trapproc ! user defined trap handler?
+ mov a,l
+ ora h
+ jz 1f ! jump if there was not
+ xra a
+ sta .trapproc ! .trapproc := 0
+ sta .trapproc+1
+ lxi d,2f
+ push d
+ pchl ! call user defined trap handler
+2:
+ pop d
+ ret
+1:
+ mvi a,0x0A !newline
+ call putchar
+ lxi d,text1
+ call prstring
+ pop h
+ call prdec
+ lxi d,text2
+ call prstring
+ lhld hol0
+ call prdec
+ lxi d,text3
+ call prstring
+ lhld hol0+4
+ xchg
+ call prstring
+ mvi a,0x0A !newline
+ call putchar
+ jmp .stop
+
+
+text1: .asciz "trap number "
+text2: .asciz "\nline "
+text3: .asciz " of file "
+
public / ack.git / commitdiff