
; Public Domain

; test install command: install; bases 26; bases uninstall
; test run command: 2642; .; .

%include "lmacros3.mac"
%include "eld.mac"
%include "eldcall.mac"
%include "elddata.mac"

	cpu 8086

	addsection RELOCATEDDATA, nobits vstart=_ELD_RELOC_VSTART
relocateddata:

	addsection HEADER, start=0

	istruc ELD_HEADERX
at eldhxHeader
		; ELD executable header
	istruc ELD_HEADER
at eldhSignature,	db "ELD1"
			db 0,0,0
			db 26
at eldhCodeOffset,	dd CODEOFFSET
at eldhCodeImageLength,	dw code_size
at eldhCodeAllocLength,	dw 0
at eldhDataOffset,	dd DATAOFFSET
at eldhDataImageLength,	dw data_size
at eldhDataAllocLength,	dw total_data_size - data_size
at eldhCodeEntrypoint,	dw linker - code
at eldhReserved
at eldhExtensionSize,	dw header_extension_end - $$
	iend
at eldhxDescriptionOffset,	dd description
PUT_ELDHX_DATETIME_OFFSET
header_extension_end:
	iend

description:		asciz "Convert between numeric bases."


	align 16, db 0

CODEOFFSET equ $ - $$
	addsection CODE, follows=HEADER vstart=_ELD_CODE_VSTART
%define CODEFIXUP - code + 0
code:
		; ELD instance header
	istruc ELD_INSTANCE
at eldiStartCode
at eldiEndCode
at eldiStartData
at eldiEndData
at eldiIdentifier,	fill 8, 32, db "BASES"
at eldiListing,		asciz _ELD_LISTING
	iend

command:
	jmp strict short .entry
.chain:
	extcall cmd3_not_ext, required	; must NOT be extcallcall
	times 10 - ($ - command) nop
.entry:
	push si
	cmp al, '-'
	jne @F
	extcallcall skipcomma
@@:
	dec si

	mov dx, msg.bases
internaldatarelocation
	extcallcall isstring?
	je .ours
	pop si
	dec si
	lodsb
	jmp .chain

.ours:
	pop ax
	extcallcall skipcomma
	dec si
reloc2	mov word [relocateddata], relocateddata
linkdatarelocation lastcmd, -4
linkdatarelocation dmycmd
	mov dx, relocateddata
linkdatarelocation msg.uninstall
	extcallcall isstring?
	je uninstall
	call run
	extcallcall cmd3

uninstall:
	lodsb
	extcallcall chkeol

	call get_es_ext

	push es
	pop ds
	xor bx, bx		; = 0 (no prior, modify ext_command_handler)
	mov di, command		; di -> us
internalcoderelocation
	mov si, word [ss:relocateddata]
linkdatarelocation ext_command_handler
				; si -> first
	test si, si		; none installed ?
	jz .error		; error -->

.loop:
	cmp di, si		; found ?
	je .bx			; yes, use bx -->
	mov bx, si		; bx -> prior handler
	lodsw			; skip entrypoint jmp strict short
	lodsb			; get first byte of chainer
	cmp al, 0E9h		; expecting jmp near ?
	jne .error		; no, error -->
	lodsw			; get rel16 displacement
	add si, ax		; -> next handler
	jmp .loop

.bx:
	test bx, bx		; any prior ?
	jnz .bxnz		; yes -->
	scasw			; skip entrypoint jmp strict short
	cmp byte [di], 0E8h	; is it a call to cmd3_not_ext ?
	jne @F			; no -->
				; yes, reset ext_command_handler to zero
.setbx:
	mov word [ss:relocateddata], bx
linkdatarelocation ext_command_handler
	jmp .done

@@:
	cmp byte [di], 0E9h	; validate
	jne .error		; failure -->
	inc di			; -> rel16 displacement
	mov bx, word [di]	; get displacement
	scasw			; -> after jmp near
	add bx, di		; -> next handler
	jmp .setbx		; set ext_command_handler to next

.bxnz:
	mov si, bx		; -> prior handler with us as downlink
	xchg di, si		; si -> ours, di -> prior
	cmpsw			; skip entrypoint jmp strict short
	movsb			; copy 0E8h/0E9h
	lodsw			; ax = near rel16 displacement
	add ax, si		; add in our base (= absolute offset)
	sub ax, di
	dec ax
	dec ax			; subtract new base (= relative displacement)
	stosw			; store new rel16 displacement
	movsw			; jmp strict short
	movsw			; linkcall target
	movsb			; trailer
.done:
	clropt [code + eldiFlags], eldifResident
internalcoderelocation -3	; mark block as free
	mov dx, msg.uninstall_done
internaldatarelocation
@@:
	push ss
	pop ds
	extcallcall putsz
	extcallcall cmd3	; return

.error:
	mov ax, 0E01h
	extcallcall setrc
	mov dx, msg.uninstall_error
internaldatarelocation
	jmp @B


get_es_ext:
	mov es, word [relocateddata]
linkdatarelocation extdssel
	extcallcall ispm
	jz @F
	mov es, word [relocateddata]
linkdatarelocation extseg
@@:
	retn


run.notable_j:
	jmp run.notable

run:
	houdini
	push ss
	pop es
	lframe
	lequ 64 + 16, buffersize
	lvar ?buffersize, buffer
	lvar word, grouping
	lvar word, ingroup
	lvar word, minwidth
	lvar qword, summeroverflow
	lvar qword, dividend
	lequ ?dividend, summer
%if ?summer + 8 != ?summeroverflow
 %error Expected contiguous variables
%endif
	lenter
	xor cx, cx
	lvar qword, value
	 push cx
	 push cx
	 push cx
	 push cx
	lvar word, notfirstline
	 push cx

	mov dx, msg.input
internaldatarelocation
	extcallcall isstring?
	jne @F
	extcallcall skipcomma
	dec si
@@:

	mov dx, msg.high
internaldatarelocation
	extcallcall isstring?
	je .high

	mov dx, msg.base
internaldatarelocation
	extcallcall isstring?
	jne @FF
@@:
	extcallcall skipcomma
	cmp al, '='
	je @B
	extcallcall getbyte
	xor cx, cx
	mov cl, dl
	cmp dl, 36
	ja .error
	cmp dl, 2
	jb .error
	dec si
	jmp .havebase

@@:
	mov bx, table
internaldatarelocation
@@:
	xchg si, bx		; si -> table
	lodsw
	xchg cx, ax		; cx = base, zero if end of table
	lodsw
	xchg dx, ax		; dx -> base name
	xchg si, bx		; si -> input
	jcxz .notable_j		; end of table ? -->
	extcallcall isstring?	; match ?
	jne @B			; no -->

.havebase:
	extcallcall skipcomma

	db __TEST_IMM8		; skip lodsb
@@:
	lodsb
	cmp al, '_'
	je @B
	extcallcall iseol?
	je .gotbased
	cmp al, 32
	je .gotbased
	cmp al, 9
	je .gotbased
	cmp al, ','
	je .gotbased
	cmp al, '0'
	jb .error
	cmp al, '9'
	jbe .decdigit
	extcallcall uppercase
	cmp al, 'A'
	jb .error
	cmp al, 'Z'
	ja .error
.alphadigit:
	sub al, 'A' - 10 - '0'
.decdigit:
	sub al, '0'
	mov ah, 0
	cmp ax, cx
	jae .error

	xor di, di			; di = 0
	mov word [bp + ?summer], di
	mov word [bp + ?summer + 2], di
	mov word [bp + ?summer + 4], di
	mov word [bp + ?summer + 6], di
	mov word [bp + ?summeroverflow], di
	mov word [bp + ?summeroverflow + 2], di
	mov word [bp + ?summeroverflow + 4], di
	mov word [bp + ?summeroverflow + 6], di
					; init the sum and overflow variables

	push ax
@@:
	mov ax, word [bp + ?value + di]	; ax = word from value prior
	mul cx				; dx:ax = multiplied word from prior
	add word [bp + ?summer + di], ax
	adc word [bp + ?summer + di + 2], dx
	adc word [bp + ?summer + di + 4], 0
	adc word [bp + ?summer + di + 6], 0
					; add into sum (may overflow)
	jc .error			; (probably not needed)
	scasw				; di += 2
	cmp di, 8
	jb @B

	pop ax				; = next digit
	mov di, word [bp + ?summeroverflow]
	or di, word [bp + ?summeroverflow + 2]
	or di, word [bp + ?summeroverflow + 4]
	or di, word [bp + ?summeroverflow + 6]
					; overflowed ?
	jnz .error			; yes -->

		; add in next digit
	add ax, word [bp + ?summer]	; keep sum low word in ax
	adc word [bp + ?summer + 2], di
	adc word [bp + ?summer + 4], di
	adc word [bp + ?summer + 6], di	; add to sum higher words
	jc .error

	mov word [bp + ?value], ax	; store sum low word
	mov ax, word [bp + ?summer + 2]
	mov word [bp + ?value + 2], ax
	mov ax, word [bp + ?summer + 4]
	mov word [bp + ?value + 4], ax
	mov ax, word [bp + ?summer + 6]
	mov word [bp + ?value + 6], ax	; store sum higher words

	jmp @BB				; handle next digit -->

.error_pop:
	pop si
.error:
	extcallcall error

.high:
	lodsb
	extcallcall getexpression
	mov word [bp + ?value + 4], dx
	mov word [bp + ?value + 6], bx
	extcallcall iseol?
	je .gotbased
	extcallcall skipcomm0
	dec si
	mov dx, msg.output
internaldatarelocation
	extcallcall isstring?
	je .output
	mov dx, msg.low
internaldatarelocation
	extcallcall isstring?
	jne .error

.notable:
	lodsb
	extcallcall getexpression
	mov word [bp + ?value], dx
	mov word [bp + ?value + 2], bx
.gotbased:
	extcallcall skipcomm0
	dec si
	mov dx, msg.output
internaldatarelocation
	extcallcall isstring?
	jne .notoutput
.output:
	extcallcall skipcomma
	mov di, outputtable		; set defaults
internaldatarelocation
	mov byte [di], 16		; base 16
	mov byte [di + 2], 255		; special: use base's default group
	mov byte [di + 4], 0		; no minimum width

.outputloop:
	extcallcall iseol?
	je .outputdone
	dec si
	mov bx, outputkeywords
internaldatarelocation

@@:
	mov cx, [bx]
	jcxz .error
	mov dx, [bx + 2]
	lea bx, [bx + 6]
	extcallcall isstring?
	jne @B

@@:
	extcallcall skipcomma
	cmp al, '='
	je @B

	extcallcall getbyte
	cmp dl, byte [bx - 6 + 4]
	jb .error
	cmp dl, byte [bx - 6 + 5]
	ja .error
	mov bx, cx
	mov byte [bx], dl
	extcallcall skipcomm0
	jmp .outputloop

.outputdone:
	houdini
	mov si, di
	mov ah, byte [si + 2]
	cmp ah, 255			; group not specified ?
	jne @FF				; no, is specified -->
	mov al, byte [si]		; get our base
	mov di, basetable
internaldatarelocation			; -> default based table
@@:
	scasb				; ours ?
	mov ah, byte [di + 1]		; = this base's default group
	je @F				; yes -->
	cmp byte [di - 1], 0		; was last ?
	lea di, [di + 10 - 1]		; di -> next base
	jne @B				; no, loop -->
	mov ah, 0			; no group
@@:
	mov byte [si + 2], ah		; store the group to use
	jmp @F

.notoutput:
	lodsb
	extcallcall chkeol

	mov si, basetable
internaldatarelocation
@@:
	mov di, relocateddata
linkdatarelocation line_out

.loopbase:
	lodsw
	xchg cx, ax
	test cx, cx
	jnz @F
	extcallcall trimputs
	lleave code
	retn

@@:
	push di
	lea di, [bp + ?buffer + ?buffersize - 1]
	mov ax, word [bp + ?value]
	mov word [bp + ?dividend], ax
	mov ax, word [bp + ?value + 2]
	mov word [bp + ?dividend + 2], ax
	mov ax, word [bp + ?value + 4]
	mov word [bp + ?dividend + 4], ax
	mov ax, word [bp + ?value + 6]
	mov word [bp + ?dividend + 6], ax

	lodsw
	mov word [bp + ?grouping], ax	; group length
	test ax, ax			; no group ?
	jz @F				; yes, leave as zero (will underflow)
	inc ax				; increment to fix the counting
		;  (do not count first iteration towards group)
@@:
	mov word [bp + ?ingroup], ax	; set current group counter
	lodsw
	dec ax
	mov word [bp + ?minwidth], ax
	std
.loopdigit:
	dec word [bp + ?ingroup]
	jnz @F
	mov al, '_'
	stosb
	mov ax, word [bp + ?grouping]
	mov word [bp + ?ingroup], ax
@@:
	xor dx, dx
	mov ax, word [bp + ?dividend + 6]
	div cx
	mov word [bp + ?dividend + 6], ax
	mov bx, ax
	mov ax, word [bp + ?dividend + 4]
	div cx
	mov word [bp + ?dividend + 4], ax
	or bx, ax
	mov ax, word [bp + ?dividend + 2]
	div cx
	mov word [bp + ?dividend + 2], ax
	or bx, ax
	mov ax, word [bp + ?dividend]
	div cx
	mov word [bp + ?dividend], ax
	or bx, ax
	xchg ax, dx
	add al, '0'
	cmp al, '9'
	jbe @F
	add al, -('9' + 1) + 'A'
@@:
	stosb
	dec word [bp + ?minwidth]
	jns .loopdigit
	test bx, bx
	jnz .loopdigit
	cld

	lea dx, [di + 1]

	pop di
	lea cx, [bp + ?buffer + ?buffersize]
	sub cx, dx
	rol byte [bp + ?notfirstline], 1; is first line ?
	jnc .notnewline			; yes, never do prefix linebreak -->
	mov bx, relocateddata + 76
linkdatarelocation line_out
	sub bx, di			; = how much remains
	jc .newline
	cmp bx, cx
	jae @F
.newline:
	push dx
	push cx
	push ax
	extcallcall trimputs
	pop ax
	pop cx
	pop dx
	mov di, relocateddata
linkdatarelocation line_out
	mov al, 32
	stosb
@@:
.notnewline:
	lodsw
	push si
	xchg si, ax
	push cx
	extcallcall copy_single_counted_string
	pop cx

	mov si, dx
	rep movsb

	pop si
	lodsw
	xchg si, ax
	extcallcall copy_single_counted_string
	xchg si, ax
	mov byte [bp + ?notfirstline], 0FFh
	jmp .loopbase

	lleave ctx


	eldcall_dump_callcall ELDCALL_CALLCALL_LIST

endinstalled equ ($ + CODEFIXUP + 15) & ~15


start:
	mov bx, es
	 push ss
	 pop es
	call skipcomma
	dec si
	mov dx, relocateddata
linkdatarelocation msg.install
	call isstring?
	je install
	call run
	call uninstall_oneshot
	xor ax, ax
	retf


uninstall_oneshot:
	testopt [ss:relocateddata], 1
linkdatarelocation options7, -3
	jnz @F

	mov ax, word [cs:code + eldiEndCode]
internalcoderelocation
	sub ax, word [cs:code + eldiStartCode]
internalcoderelocation
	sub word [relocateddata], ax
linkdatarelocation extseg_used

	mov ax, word [cs:code + eldiEndData]
internalcoderelocation
	sub ax, word [cs:code + eldiStartData]
internalcoderelocation
	sub word [relocateddata], ax
linkdatarelocation extdata_used
@@:
	retn


install:
	lodsb
	extcall chkeol

	houdini
	mov es, bx		; => ext seg (writable)
	mov ax, endresident - endinstalled
	sub word [es:code + eldiEndCode], ax
internalcoderelocation		; adjust size
	sub word [relocateddata], ax
linkdatarelocation extseg_used	; adjust size
	mov bx, word [relocateddata]
linkdatarelocation ext_command_handler
				; -> prior
	mov di, command		; -> our handler
internalcoderelocation
	test bx, bx		; installing as first ?
	jz .only_first		; yes, simple --> (leave as extcall cmd3_not_ext)
	scasw			; skip entrypoint jmp strict short
	mov al, 0E9h		; = jmp near opcode
	stosb			; store
	xchg ax, bx		; ax -> next handler
	sub ax, di
	dec ax
	dec ax			; ax = ax - (di + 2)
	stosw			; store our downlink as rel16 displacement

.only_first:
	setopt [es:code + eldiFlags], eldifResident
internalcoderelocation -3	; mark block as resident
	mov word [relocateddata], command
linkdatarelocation ext_command_handler, -4
internalcoderelocation		; -> our entrypoint

	testopt [relocateddata], 4
linkdatarelocation options7, -3
	jnz @F
	mov dx, msg.installed
internaldatarelocation
	call putsz
@@:
	xor ax, ax
	retf


DATAOFFSET equ CODEOFFSET + code_size
	addsection DATA, follows=CODE vstart=_ELD_DATA_VSTART
%define DATAFIXUP - datastart + 0
datastart:
PUT_ELD_DATETIME

	align 2, db 0
outputtable:	dw 0, 0, 0
		dw msg.empty
internaldatarelocation
		dw msg.empty
internaldatarelocation
		dw 0

basetable:
		dw 16, 4, 0
		dw msg.empty
internaldatarelocation
		dw msg.blank
internaldatarelocation
		dw 10, 3, 0
		dw msg.baseten
internaldatarelocation
		dw msg.blank
internaldatarelocation
		dw 2, 4, 0
		dw msg.basetwo
internaldatarelocation
		dw msg.blank
internaldatarelocation
		dw 8, 3, 0
		dw msg.baseeight
internaldatarelocation
		dw msg.blank
internaldatarelocation
		dw 0


table:
	dw 16, msg.hex
internaldatarelocation
	dw 16, msg.hexadecimal
internaldatarelocation
	dw 10, msg.dec
internaldatarelocation
	dw 10, msg.decimal
internaldatarelocation
	dw 2, msg.bin
internaldatarelocation
	dw 2, msg.binary
internaldatarelocation
	dw 8, msg.oct
internaldatarelocation
	dw 8, msg.octal
internaldatarelocation
	dw 0


outputkeywords:
	dw outputtable + 0
internaldatarelocation
	dw msg.base
internaldatarelocation
	db 2, 36
	dw outputtable + 2
internaldatarelocation
	dw msg.group
internaldatarelocation
	db 0, 64
	dw outputtable + 4
internaldatarelocation
	dw msg.width
internaldatarelocation
	db 0, 64
	dw 0


msg:
.bases:			asciz "BASES"
.uninstall_done:	db "BASES uninstalled."
%if _ELD_RECLAIM_HINT
			db " (Don't forget to use reclaim.eld)"
%endif
			asciz 13,10
.uninstall_error:	asciz "BASES unable to uninstall!",13,10
.blank:			counted " "
.empty:			counted
.baseten:		counted "#"
.basetwo:		counted "2#"
.baseeight:		counted "8#"
.hex:			asciz "HEX"
.hexadecimal:		asciz "HEXADECIMAL"
.dec:			asciz "DEC"
.decimal:		asciz "DECIMAL"
.bin:			asciz "BIN"
.binary:		asciz "BINARY"
.oct:			asciz "OCT"
.octal:			asciz "OCTAL"
.high:			asciz "HIGH"
.low:			asciz "LOW"
.base:			asciz "BASE"
.group:			asciz "GROUP"
.width:			asciz "WIDTH"
.input:			asciz "INPUT"
.output:		asciz "OUTPUT"

uinit_data: equ $
.installed:		asciz "BASES installed.",13,10

	align 16, db 0
init_data_end:
data_size equ $ - datastart


	absolute uinit_data

	alignb 16
uinit_data_end:

%if uinit_data_end >= init_data_end
 total_data_size equ $ - datastart
%else
 total_data_size equ init_data_end - datastart
%endif
%assign _DATA_SIZE total_data_size

	usesection CODE

%include "eldlink.asm"

	align 16
code_size equ $ - code
