; ModŠle, de module FORTH
; Guillaume Tello
; guillaume.tello@orange.fr
; july 2024

GEMDOS MACRO    ; fn,pile
   move #\1,-(sp)
   trap #1
   if \2<=8
      addq.l #\2,sp
   else
      add.w #\2,sp
   endif
   ENDM

		section	text
		
FNSTART	equ 7			; num‚ro de la fonction qui d‚marre le groupe des fonctions …
							; deux paramŠtres d‚pendant de Bsize

debut:	
	dc.b "READ_FOM"	; identifiant module g‚n‚ral FORTH
	dc.b "BITS"			; objets support‚s
	dc.w 14				; type n=nbr de redef diff‚rentes de modexe
	dc.b "BINARY  "	; nom court
	dc.w 100				; version 1.00
	dc.b "Binary Words on B,W,L ˝GT 2024",0 ; long name (30 caractŠres + z‚ro)
	dc.b 4+2+1			; masque de bits:
							;   1 si do_param pr‚sent
							;   2 si mots red‚finis
							;   4 si ne pas renvoyer d0 sur la pile (sauf pour do_param)
	bra modinfo			; fixe la taille
	bra modpal			; renvoie carry
	bra modexe			; ensemble des fonctions
	bra do_param		; initialise (taille = LONG, carry=0)
	
	dc.b "Bsize",0		; fixera la taille de l'op‚rande
	dc.b "Bcarry",0	; renvoie le dernier bit sorti
	dc.b "Bcc",0		; fonction 1 : Carry clear
	dc.b "Bcs",0		; fonction 2 : Carry set
	dc.b "Bclr",0		; fonction 3 : Bit test and clear
	dc.b "Bchg",0		; fonction 4 : Bit test and change
	dc.b "Bset",0		; fonction 5 : Bit test and set
	dc.b "Btst",0		; fonction 6 : Bit test
							; ---------- limite FNSTART -----------
	dc.b "Blsl",0		; fonction 7 : Logical shift left
	dc.b "Blsr",0		; fonction 8 : Logical shift right
	dc.b "Basl",0		; fonction 9 : Arithmetic shift left
	dc.b "Basr",0		; fonction 10: Arithmetic shift right
	dc.b "Brol",0		; fonction 11: Rotate left
	dc.b "Bror",0		; fonction 12: Rotate right
	dc.b "Broxl",0		; fonction 13: Rotate left with extended
	dc.b "Broxr",0		; fonction 14: Rorate left with extended
	even					; assure la parit‚	
	
	; taille (0,1,2)  p modinfo  ou  taille Bsize
	; en 4(SP)on trouve SNDB
	; sur A6 la pile FORTH
	
modinfo:
	lea fn_byte(pc),a0
	move.l (a6)+,d1
	beq.s _comm
	lea fn_word(pc),a0
	subq.l #1,d1
	beq.s _comm
	bra.s do_param

	; p modpal  ou Bcarry
	; renvoie l'‚tat du bit de la derniŠre op‚ration
	
modpal:
	lea carry(pc),a0
	move.l (a0),-(a6)
	rts

	; initialisation loars de modload
	
do_param:
	lea fn_long(pc),a0
_comm:
	lea fn_ptr(pc),a1
	move.l a0,(a1)			; met par d‚faut les routines LONG
	moveq #0,d0				; retour Ok
	lea carry(pc),a0
	move.l d0,(a0)			; et efface le carry
	rts


; pile 4(SP):sndb, inutilis‚

modexe:	
	cmp.l #'XFOM',d1
	bne.s .nul				; ici choisir que faire si appel direct … modexe
								; message d'erreur ou un traitement par d‚faut
	subq.l #FNSTART,d0
	bpl.s .groupe2

	lea fn_byte(pc),a0	; ici fonctions en une seule version
	cmp #-5,d0
	ble.s .commun			; fonctions Bcs, Bcc sans paramŠtres
	move.l (a6)+,d2
	move.l (a6)+,d1
	bra.s .commun
		
.groupe2:
								; ici fonctions … 2 params et 3 versions B,W,L
	move.l (a6)+,d2		; n, nombre de bits
	move.l (a6)+,d1		; valeur … traiter
	
	move.l fn_ptr(pc),a0	; pointe sur le bon tableau selon la taille
.commun:
	add.l d0,d0				; pointe sur des words
	move.w 0(a0,d0.l),d0	; offset … partir de "base" de la routine
	lea base(pc),a0
	add d0,a0				; ajoute offset
	jmp (a0)					; saute … la routine
.nul:
	rts						; si appel hors des mots, ne fait rien
	
base:

	; remet les indicateurs en cas de roxl ou roxr
	
recall_carry:
	tst.b carry+3(pc)
	beq.s .rc0
	ori #$11,ccr			; si CARRY=1, remet X et C
	rts
.rc0:
	andi #$EE,ccr			; si CARRY=0, elŠve X et C
	rts

	; Rotate left avex bit X, pour B,W,L
Broxlb:
	bsr.s recall_carry
	roxl.b d2,d1
	bra.s set_carry
	
Broxlw:
	bsr.s recall_carry
	roxl.w d2,d1
	bra.s set_carry
	
Broxll:
	bsr.s recall_carry
	roxl.l d2,d1
	bra.s set_carry

	; Rotate right avex bit X, pour B,W,L
Broxrb:
	bsr.s recall_carry
	roxr.b d2,d1
	bra.s set_carry
	
Broxrw:
	bsr.s recall_carry
	roxr.w d2,d1
	bra.s set_carry
	
Broxrl:
	bsr.s recall_carry
	roxr.l d2,d1
	bra.s set_carry


	; Logical shift left B,W,L

Blslb:
	lsl.b d2,d1
	bra.s set_carry
	
Blslw:
	lsl.w d2,d1
	bra.s set_carry
	
Blsll:
	lsl.l d2,d1
	bra.s set_carry


	; Logical shift right B,W,L
	
Blsrb:
	lsr.b d2,d1
	bra.s set_carry
	
Blsrw:
	lsr.w d2,d1
	bra.s set_carry
	
Blsrl:
	lsr.l d2,d1
	bra.s set_carry

	; Rotate right B,W,L
	
Brorb:
	ror.b d2,d1
	bra.s set_carry
	
Brorw:
	ror.w d2,d1
	bra.s set_carry
	
Brorl:
	ror.l d2,d1
;	bra.s set_carry	se poursuit naturellement !
	
	
set_carry:
	lea carry+3(pc),a0
	bcs.s .on
	bclr #0,(a0)
	bra.s .exit
.on:
	bset #0,(a0)
.exit:
	move.l d1,-(a6)
	rts	

	; Arithmetic shift left B,W,L

Baslb:
	asl.b d2,d1
	bra.s set_carry
	
Baslw:
	asl.w d2,d1
	bra.s set_carry
	
Basll:
	asl.l d2,d1
	bra.s set_carry

	; Arithmetic shift right B,W,L
	
Basrb:
	asr.b d2,d1
	bra.s set_carry
	
Basrw:
	asr.w d2,d1
	bra.s set_carry
	
Basrl:
	asr.l d2,d1
	bra.s set_carry

	; Rotate left B,W,L
	
Brolb:
	rol.b d2,d1
	bra.s set_carry
	
Brolw:
	rol.w d2,d1
	bra.s set_carry
	
Broll:
	rol.l d2,d1
	bra.s set_carry
	
	; Clear or Set carry
	
Bcac: lea carry+3(pc),a0
	bclr #0,(a0)
	rts
	
Bcas: lea carry+3(pc),a0
	bset #0,(a0)
	rts

	; pour ces 4 : val #bit fonction
	; modifie ‚ventuellement val selon la fonction
	; carry contient l'‚tat pr‚c‚dent du bit concern‚
	
Bclear:
	bclr d2,d1
	bra.s store_z
	
Bchange:
	bchg d2,d1
	bra.s store_z
	
Bsetto1:
	bset d2,d1
	
store_z:
	lea carry+3(pc),a0
	beq.s .zero
	bset #0,(a0)
	move.l d1,-(a6)
	rts
.zero:
	bclr #0,(a0)
	move.l d1,-(a6)
	rts

Btest:
	btst d2,d1
	bra.s store_z
	

	data
			; groupe 1, en valeur n‚gative par rapport … fn_byte
			dc.w Bcac-base,Bcas-base	
			dc.w Bclear-base,Bchange-base,Bsetto1-base,Btest-base
			; groupe 2
fn_byte: dc.w Blslb-base,Blsrb-base,Baslb-base,Basrb-base,Brolb-base,Brorb-base
			dc.w Broxlb-base,Broxrb-base
fn_word: dc.w Blslw-base,Blsrw-base,Baslw-base,Basrw-base,Brolw-base,Brorw-base
			dc.w Broxlw-base,Broxrw-base
fn_long: dc.w Blsll-base,Blsrl-base,Basll-base,Basrl-base,Broll-base,Brorl-base
			dc.w Broxll-base,Broxrl-base



	bss
	
fn_ptr: ds.l 1
carry: ds.l 1

	end