;*****************************************************************************
;  Scheme 8088 boolean bitwise fixnum operators     BODY CODE OBJECTS
;  (inp x)      input from hardware port x
;  (outp x d)   output to hardware port x data d
;  (band x x)
;  (bor x x)
;  (bxor x x)
;  (bsar x n)   shift x by n to the right
;  (bsal x n)   shift x by n to the left
;  (bror x n)   rotate x by n to the right
;  (brol x n)   rotate x by n to the left
;  (rand8)      random number from 0 to 255
;  (rand12!)    random number from 1.0 to 1.9999999999
;               side effects real so copy must be made:
;               (define rand01 (lambda () (- (rand12!) 1))) is required
;*****************************************************************************
   ((sp #x2c load.lco)

    .align-para
    (l load.lco)        ; lambda code object header
    (iw #x3c00)
    (aw load.size)
    (aw load.start)
    (ag load.lco)
    (iw #x0800)
    (iw 22)               ; number externs *****************************
    (sp #x24 name.inp)
    (sp #x28 inp.bco)
    (sp #x24 name.outp)
    (sp #x28 outp.bco)
    
    (sp #x24 name.band)
    (sp #x28 band.bco)
    (sp #x24 name.bor)
    (sp #x28 bor.bco)
    (sp #x24 name.bxor)
    (sp #x28 bxor.bco)
    (sp #x24 name.bsar)
    (sp #x28 bsar.bco)
    (sp #x24 name.bsal)
    (sp #x28 bsal.bco)

    (sp #x24 name.bror)
    (sp #x28 bror.bco)
    (sp #x24 name.brol)
    (sp #x28 brol.bco)
    (sp #x24 name.rand8)
    (sp #x28 rand8.bco)
    (sp #x24 name.rand12!)
    (sp #x28 rand12!.bco)

    (dl load.start load.lco)
    (push es)
    (push di)
    (push bp)
    (mov iw ax) (iw #x0f00)
    (push ax)
    (push cs)                      ; closure for loading
    (mov iw ax) (aw load.body)
    (push ax)
    (mov iw ax) (iw 1)
    (int #x98)
    
    (dl load.body load.lco)        ; body:   (set! G?? <bco>) ...
    (and ax ax)
    (jz) (db load.body.arg.ok)
    (mov ib dl) (ib 1)
    (int #x90)
    
    (l load.body.arg.ok)
    (mov iw si) (iw 12)
    (mov iw cx) (iw 11)            ; number of set!'s *******************
    (l load.loop)
    (cs:) (lds (si w) bx)          ; DS:BX = untagged to symbol
    (xor bh bh)
    (cs:) (mov (db si w) ax) 4     ; set! symbol = BCO
    (mov ax (bx w))
    (cs:) (mov (db si w) ax) 6
    (mov ax (bx db w)) 2
    (add ib si) 8
    (loop) (db load.loop)

    (xor ax ax)
    (mov ax ds)
    (pop bp) (pop bp)
    (pop di) (pop es)
    (retf)
    (dl load.size load.lco)
    
    (l name.inp)
    (ss "inp")
    (l name.outp)
    (ss "outp")

    (l name.band)
    (ss "band")
    (l name.bor)
    (ss "bor")
    (l name.bxor)
    (ss "bxor")
    (l name.bsar)
    (ss "bsar")
    (l name.bsal)
    (ss "bsal")

    (l name.bror)
    (ss "bror")
    (l name.brol)
    (ss "brol")
    (l name.rand8)
    (ss "rand8")
    (l name.rand12!)
    (ss "rand12!")

;*****************************************************************************
;  body code object for inp
;*****************************************************************************
;  (()
    .align-para
    (l inp.bco)        ; body code object header
    (iw #x3800)
    (aw inp.size)
    (aw inp.start)
    (ag inp.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl inp.start inp.bco)
    (push es)                    ; save CP & FP
    (push di)
    (push bp)
    (mov iw bx) (iw #x0f00)
    (push bx)
;  
    (cmp iw ax) (iw 1)           ; check number args = 1
    (jz) (db inp.arg.ck)
    (mov ib dl) 1
    (int #x90)
;    
    (l inp.arg.ck)
    (mov sp bp)
    (mov (bp db w) ax) 12        ; AX = arg1 tag
    (cmp ib ah) #x08
    (jz) (db inp.arg.ok)
    (mov ib dl) 7
    (int #x90)
    
    (l inp.arg.ok)
    (mov (bp db w) dx) 14        ; DX = arg1 data  port address
    (in.dx.al)
    (xor ah ah)                  ; return as fixnum
    (mov ax ds)
    (mov iw ax) (iw #x0800)

    (pop bp)
    (pop bp)
    (pop di)
    (pop es)
    (retaf) (iw 4)
    
    (dl inp.size inp.bco)
    
;*****************************************************************************
;  body code object for outp   (outp addr data)
;*****************************************************************************
;  (()
    .align-para
    (l outp.bco)        ; body code object header
    (iw #x3800)
    (aw outp.size)
    (aw outp.start)
    (ag outp.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl outp.start outp.bco)
    (push es)                    ; save CP & FP
    (push di)
    (push bp)
    (mov iw bx) (iw #x0f00)
    (push bx)
;  
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db outp.arg.ck)
    (mov ib dl) 1
    (int #x90)
;    
    (l outp.arg.ck)
    (mov sp bp)
    (mov (bp db w) ax) 12        ; AX = arg2 tag
    (cmp ib ah) #x08
    (jnz) (db outp.arg.nok)
    (mov (bp db w) ax) 16        ; AX = arg1 tag
    (cmp ib ah) #x08
    (jz) (db outp.arg.ok)
    (l outp.arg.nok)
    (mov ib dl) 7
    (int #x90)
    
    (l outp.arg.ok)
    (mov (bp db w) dx) 18        ; DX = arg1 addr
    (mov (bp db w) ax) 14        ; AX = arg2 data
    (out.dx.al)

    (xor ax ax)   ; return #f
    (mov ax ds)

    (pop bp)
    (pop bp)
    (pop di)
    (pop es)
    (retaf) (iw 8)
    
    (dl outp.size outp.bco)

    
    
;*****************************************************************************
;  body code object for band
;*****************************************************************************
;  (()
    .align-para
    (l band.bco)        ; body code object header
    (iw #x3800)
    (aw band.size)
    (aw band.start)
    (ag band.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl band.start band.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db band.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l band.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db band.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l band.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db band.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l band.arg2.ok)
    (ss:) (mov (bx db w) ax) 10        ; AX = data arg1
    (ss:) (and (bx db w) ax) 6
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl band.size band.bco)

;*****************************************************************************
;  body code object for bor
;*****************************************************************************
;  (()
    .align-para
    (l bor.bco)        ; body code object header
    (iw #x3800)
    (aw bor.size)
    (aw bor.start)
    (ag bor.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl bor.start bor.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db bor.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l bor.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bor.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l bor.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bor.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l bor.arg2.ok)
    (ss:) (mov (bx db w) ax) 10        ; AX = data arg1
    (ss:) (or (bx db w) ax) 6
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl bor.size bor.bco)

;*****************************************************************************
;  body code object for bxor
;*****************************************************************************
;  (()
    .align-para
    (l bxor.bco)        ; body code object header
    (iw #x3800)
    (aw bxor.size)
    (aw bxor.start)
    (ag bxor.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl bxor.start bxor.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db bxor.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l bxor.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bxor.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l bxor.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bxor.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l bxor.arg2.ok)
    (ss:) (mov (bx db w) ax) 10        ; AX = data arg1
    (ss:) (xor (bx db w) ax) 6
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl bxor.size bxor.bco)

;*****************************************************************************
;  body code object for bsar
;*****************************************************************************
;  (()
    .align-para
    (l bsar.bco)        ; body code object header
    (iw #x3800)
    (aw bsar.size)
    (aw bsar.start)
    (ag bsar.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl bsar.start bsar.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db bsar.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l bsar.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bsar.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l bsar.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bsar.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l bsar.arg2.ok)
    (ss:) (mov (bx db w) ax) 10   ; AX = data arg1
    (ss:) (mov (bx db w) cx) 6    ; CX = data arg2
    (ss:) (sar cl ax)
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl bsar.size bsar.bco)
    
;*****************************************************************************
;  body code object for bsal
;*****************************************************************************
;  (()
    .align-para
    (l bsal.bco)        ; body code object header
    (iw #x3800)
    (aw bsal.size)
    (aw bsal.start)
    (ag bsal.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl bsal.start bsal.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db bsal.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l bsal.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bsal.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l bsal.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bsal.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l bsal.arg2.ok)
    (ss:) (mov (bx db w) ax) 10   ; AX = data arg1
    (ss:) (mov (bx db w) cx) 6    ; CX = data arg2
    (ss:) (sal cl ax)
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl bsal.size bsal.bco)
    
;*****************************************************************************
;  body code object for bror
;*****************************************************************************
;  (()
    .align-para
    (l bror.bco)        ; body code object header
    (iw #x3800)
    (aw bror.size)
    (aw bror.start)
    (ag bror.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl bror.start bror.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db bror.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l bror.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bror.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l bror.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db bror.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l bror.arg2.ok)
    (ss:) (mov (bx db w) ax) 10   ; AX = data arg1
    (ss:) (mov (bx db w) cx) 6    ; CX = data arg2
    (ss:) (ror cl ax)
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl bror.size bror.bco)

;*****************************************************************************
;  body code object for brol
;*****************************************************************************
;  (()
    .align-para
    (l brol.bco)        ; body code object header
    (iw #x3800)
    (aw brol.size)
    (aw brol.start)
    (ag brol.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl brol.start brol.bco)
    (cmp iw ax) (iw 2)           ; check number args = 2
    (jz) (db brol.arg.ck)
    (mov ib dl) 1
    (int #x9f)

    (l brol.arg.ck)               ; DS:AX = 1st arg
    (mov sp bx)
    (ss:) (mov (bx db w) ax) 8
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db brol.arg2.ck)
    (mov ib dl) 7
    (int #x9f)
    
    (l brol.arg2.ck)
    (ss:) (mov (bx db w) ax) 4
    (cmp ib ah) #x08             ; check for fixnum
    (jz) (db brol.arg2.ok)
    (mov ib dl) 7
    (int #x9f)
   
    (l brol.arg2.ok)
    (ss:) (mov (bx db w) ax) 10   ; AX = data arg1
    (ss:) (mov (bx db w) cx) 6    ; CX = data arg2
    (ss:) (rol cl ax)
    (mov ax ds)
    (mov iw ax) (iw #x0800)
    (retaf) (iw 8)        ; kill args
    (dl brol.size brol.bco)

;*****************************************************************************
;  body code object for rand8
;*****************************************************************************
;  (()
    .align-para
    (l rand8.bco)        ; body code object header
    (iw #x3800)
    (aw rand8.size)
    (aw rand8.start)
    (ag rand8.bco)
    (iw #x0800)
    (iw #x0000)
    
    (dl rand8.start rand8.bco)
    (push es)                    ; save CP & FP
    (push di)
    (push bp)
    (mov iw bx) (iw #x0f00)
    (push bx)

    (cmp iw ax) (iw 0)           ; check number args = 0
    (jz) (db rand8.arg.ok)
    (mov ib dl) 1
    (int #x90)
    
    (dl rand8.table rand8.bco)
    (iw 7)    (iw 3)   (iw 0)     ; limit, increment, value
    (iw 11)   (iw 5)   (iw 0)
    (iw 31)   (iw 7)   (iw 0)
    (iw 61)   (iw 13)  (iw 0)

    (iw 163)  (iw 19)  (iw 0)
    (iw 512)  (iw 29)  (iw 0)
    (iw 641)  (iw 73)  (iw 0)
    (iw 811)  (iw 107) (iw 0)

    (iw 1321) (iw 163) (iw 0)
    (iw 2161) (iw 241) (iw 0)
    (iw 4721) (iw 373) (iw 0)
    (iw 8377) (iw 641) (iw 0)
    
    (l rand8.arg.ok)
    (mov cs ax)                  ; DS:SI = table
    (mov ax ds)
    (mov iw si) (aw rand8.table)
    (mov iw cx) (iw 12)          ; CX = table size
    (xor dx dx)                  ; DX = result
    (cld)
    
    (l rand8.loop)
    (lods.w)         ; BX = limit
    (mov ax bx)
    (lods.w)         ; AX = increment
    (add (si w) ax)  ; AX = value + inc
    (cmp bx ax)
    (jb) (db rand8.no)
    (sub bx ax)
    (l rand8.no)
    (mov ax (si w))  ; replace value
    (add ib si) 2
    (xor ax dx)      ; xor result
    (loop) (db rand8.loop)
   
    (sar dx)
    (xor dh dh)
    (mov iw ax) (iw #x0800)  ; return result
    (mov dx ds)

    (pop bp)              ; restore CP & FP
    (pop bp)
    (pop di)
    (pop es)
    (retaf) (iw 0)        ; kill args

    (dl rand8.size rand8.bco)
    
;*****************************************************************************
;  body code object for rand12!
;*****************************************************************************
;  (()
    .align-long
    (l rand12!.real)
    (iw #x3500) (iw 5) 0 0  0 0  0 0  0 0  (iw #x3fff) 

    .align-para
    (l rand12!.bco)        ; body code object header
    (iw #x3800)
    (aw rand12!.size)
    (aw rand12!.start)
    (ag rand12!.bco)
    (iw #x0800)
    (iw #x0001)
    (sp #x25 rand12!.real)
    
    (dl rand12!.start rand12!.bco)
    (push es)                    ; save CP & FP
    (push di)
    (push bp)
    (mov iw bx) (iw #x0f00)
    (push bx)

    (cmp iw ax) (iw 0)           ; check number args = 0
    (jz) (db rand12!.arg.ok)
    (mov ib dl) 1
    (int #x90)
    
    (l rand12!.arg.ok)
    (int3)
    (cs:) (les (dw w) ax) (iw 12) ; ES:DI = untagged real
    (xor ah ah)
    (mov ax di)
    (add ib di) 4
    (mov iw cx) (iw 8)           ; loop index
    (l rand12!.loop)
    (call) (dw rand12!.gen)
    (cld)
    (stos.b)
    (loop) (db rand12!.loop)
    (dec di)
    (es:) (mov (di b) al)        ; add 1
    (or ib al) 128
    (es:) (mov al (di b))

    (call) (dw rand12!.gen)
    (call) (dw rand12!.gen)
    (call) (dw rand12!.gen)

    (cs:) (lds (dw w) ax) (iw 12)     ; DS:AX = tagged real
    
    (pop bp)              ; restore CP & FP
    (pop bp)
    (pop di)
    (pop es)
    (retaf) (iw 0)        ; kill args
;
;  8 bit random number generator
;    
    (dl rand12!.table rand12!.bco)
    (iw 7)    (iw 3)   (iw 0)     ; limit, increment, value
    (iw 11)   (iw 5)   (iw 0)
    (iw 31)   (iw 7)   (iw 0)
    (iw 61)   (iw 13)  (iw 0)

    (iw 163)  (iw 19)  (iw 0)
    (iw 512)  (iw 29)  (iw 0)
    (iw 641)  (iw 73)  (iw 0)
    (iw 811)  (iw 107) (iw 0)

    (iw 1321) (iw 163) (iw 0)
    (iw 2161) (iw 241) (iw 0)
    (iw 4721) (iw 373) (iw 0)
    (iw 8377) (iw 641) (iw 0)
    
    (l rand12!.gen)
    (push cx)
    
    (mov cs ax)                  ; DS:SI = table
    (mov ax ds)
    (mov iw si) (aw rand12!.table)
    (mov iw cx) (iw 12)          ; CX = table size
    (xor dx dx)                  ; DX = result
    (cld)
    
    (l rand12!.gen.loop)
    (lods.w)         ; BX = limit
    (mov ax bx)
    (lods.w)         ; AX = increment
    (add (si w) ax)  ; AX = value + inc
    (cmp bx ax)
    (jb) (db rand12!.no)
    (sub bx ax)
    (l rand12!.no)
    (mov ax (si w))  ; replace value
    (add ib si) 2
    (xor ax dx)      ; xor result
    (loop) (db rand12!.gen.loop)
    (sar dx)
    (xor dh dh)
    (mov dx ax)

    (pop cx)
    (ret)

    (dl rand12!.size rand12!.bco)

;****************************************************************************
    )