;*****************************************************************************
;  Scheme 8088 Expanded Memory garbage collector     BOOT OBJECTS
;  to call:
;     push arg1 = number paras needed as fixnum 
;     push return
;     push closure ptr
;     push frame ptr
;     jmpf to gc
;  gc will return to return address above
;*****************************************************************************
   ((l gc.begin)
    (el coproc.type #x108) ; coproc type  0=none 1=87/287 2=387  SS:108
    (el proc.type #x109)   ; processor type 1=8088 2=286 3=386 4=486
    (el em.handle #x10a)   ; Expanded Memory Handle  0 if EM not used
    (el em.pages #x10c)    ; Number of Expanded 16K pages

;  FFF8 heap allocation pointer
;  FFF4 beginning of heap memory
;  FFF0 end of heap memory
;  FFEC current semi-space base  (starts as beginning)
;  FFE8 current semi-space end
;  FFE4 new semi-space base (not used for EGC)
;  FFE0 new semi-space end (not used for EGC)
;  FFDE critical area flag
;  FFDC pending break
;  FFD8 global symbol table vector
    
    (el gc.alloc.seg #xfffa)
    (el gc.alloc.off #xfff8)
    (el gc.begin.seg #xfff6)
    (el gc.cur.base.seg #xffee)
    (el gc.cur.base.off #xffec)
    (el gc.cur.end.seg #xffea)
    (el gc.cur.end.off #xffe8)

    (el gc.new.base.seg #xffe6)  ;*********** delete
    (el gc.new.end.seg #xffe2)  ;*********** delete
    
    (el gc.top.stack #xffdc)  ;point past last collected stack object
;---------------------------------------------------------------------------
;  Expanded Memory GC temporaries @ CS:offset
;---------------------------------------------------------------------------
    (jmp) (dw egc.start) 0
    (iw 0) (iw 0)   ; temp @ CS:4   Physical EMM 16K page (copy from address)
    (iw 0) (iw 0)   ; temp @ CS:8   Physical EMM 16K page (copy to address)
    (iw 0) (iw 0)   ; temp @ CS:12  Logical address (copy to address)
    (iw 0)          ; temp @ CS:16  Physical copy from page # 
    (iw 0)          ; temp @ CS:18  Physical copy to page #
    0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0  ; zero buffer for padding
    
    (el gc.pef.off 4)
    (el gc.pef.seg 6)
    (el gc.pet.off 8)
    (el gc.pet.seg 10)
    (el gc.logic.off 12)
    (el gc.logic.seg 14)
    (el gc.page.f 16)
    (el gc.page.t 18)
    (el zero.buf 20)
    
;---------------------------------------------------------------------------
;  start of collector code
;---------------------------------------------------------------------------
    (l egc.start)
    (mov sp ax)    ; check for misaligned stack
    (and iw ax) (iw 3)
    (jz) (db gc.setup)
    (call) (dw gc.pcon)
    (ss "EGC: misaligned stack")
    (mov ib dl) 255
    (jmp) (dw gc.error)
;-------------------------------------------------
;  setup temps for Garbage Collection
;-------------------------------------------------
    (l gc.emm.err)
    (ss "EGC: EMM error")
    (mov ib dl) 255
    (jmp) (dw gc.error)
    
    (l gc.setup)
    (mov iw ax) (iw #x4100)  ; get EMM page frame
    (int #x67)
    (and ah ah)
    (jnz) (db gc.emm.err)
    (mov bx bp)              ; BP = EMM page frame
    
    (mov iw ax) (iw #x4400)  ; Map page 0 to logical 0
    (xor bx bx)
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (and ah ah)
    (jnz) (db gc.emm.err)
    
    (mov iw ax) (iw #x4401)  ; Map page 1 to logical 0
    (xor bx bx)
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (and ah ah)
    (jnz) (db gc.emm.err)
    
    (xor ax ax)
    (cs:) (mov ax (dw w)) (aw gc.pef.off)   ; set from address to 1st page 
    (cs:) (mov bp (dw w)) (aw gc.pef.seg)

    (mov bp bx)
    (add iw bx) (iw #x0400) 
    (cs:) (mov ax (dw w)) (aw gc.pet.off)   ; set to address to 2nd page 
    (cs:) (mov bx (dw w)) (aw gc.pet.seg)

    (ss:) (mov (dw w) bx) (aw gc.cur.base.seg)
    (cs:) (mov ax (dw w)) (aw gc.logic.off)   ; set to logical address to
    (cs:) (mov bx (dw w)) (aw gc.logic.seg)   ; current base
    
    (xor ax ax)
    (cs:) (mov ax (dw w)) (aw gc.page.f)    ; set page #'s to 0
    (cs:) (mov ax (dw w)) (aw gc.page.t)

;-------------------------------------------------
;  print stats
;-------------------------------------------------
;    (call) (dw gc.pcon)
;    (ss 13 10 "GC: base:")  ; *******
;    (ss:) (mov (dw w) ax) (aw gc.cur.base.seg)
;    (call) (dw print.dec)
;    (call) (dw gc.pcon) (ss " total:")
;    (ss:) (mov (dw w) ax) (aw gc.cur.end.seg)
;    (ss:) (sub (dw w) ax) (aw gc.cur.base.seg)
;    (call) (dw print.dec)
;    (call) (dw gc.pcon) (ss " before:")
;    (ss:) (mov (dw w) ax) (aw gc.alloc.seg)
;    (ss:) (sub (dw w) ax) (aw gc.cur.base.seg)
;    (call) (dw print.dec)

;    (int #xa0) ;*******************************STOP
    
;------------------------------------------------------
;  traverse stack
;  stack is either single object or triple
;  single object:  any Scheme object
;  triple:  #x0F00:Frame Pointer
;           untagged closure pointer  or  untagged BCO pointer
;           untagged return address to LCO or BCO
;  NOTE: if FP=0 then return address points
;        to a uncollectable object  (ie scheme function caller int #xf8)
;------------------------------------------------------
;  (()
    (mov sp bp)                ; SS:BP = pointer to stack
    (l gc.stack.loop)
    (cmp iw bp) (aw gc.top.stack) 
    (jnz) 3
    (jmp) (dw gc.sweep)
    
    (ss:) (lds (bp db w) dx) 0 ; DS:DX = arg off stack
    (cmp ib dh) #x0f           ; stack triple?
    (jz) (db gc.s3)
    (call) (dw gc.copy.obj)    ; single object
;    (call) (dw gc.pcon) (ss "s")  ;*****
;    (call) (dw hex.ds.ax) ;*****    (int #x95) ;*****
    (ss:) (mov dx (bp db w)) 0 ; update object on stack
    (ss:) (mov ds (bp db w)) 2
    (add ib bp) 4
    (jmps) (db gc.stack.loop)
;
;  stack triple
;
    (l gc.s3)         ; stack triple (Frame, Closure, Return)
;    (call) (dw gc.pcon) (ss 13 10 "@")  ;*****
;    (mov bp ax)  ;*****
;    (call) (dw hex.ds.ax) ;*****  print Frame Pointer
;
;  closure      not collectable if = 0
;    
    (ss:) (lds (bp db w) bx) 4 ; DS:BX = closure address
    (mov ds ax)
    (or bx ax)
    (jz) (db gc.copy.noclos)
	
    (mov (bx w) ax)            ; AX = closure object header
    (cmp ib ah) #x36       ; closure 
    (jz) (db gc.clos.ok)
    (cmp ib ah) #x38       ; BCO
    (jz) (db gc.clos.ok)
    (cmp ib ah) #xA6       ; forwarded closure
    (jz) (db gc.clos.ok)
    (cmp ib ah) #xA8       ; forwarded BCO    
    (jz) (db gc.clos.ok)
    (call) (dw gc.pcon)
    (ss "GC.copy.obj: bad closure")
    (mov ah dl)
    (jmp) (dw gc.error)

    (l gc.clos.ok)
    (mov bl al)                ; AL = offset
    (and ib ah) #x6f           ; clear type header bit & foward bit
    (mov ax dx)
    (call) (dw gc.copy.obj)    ; DS:DX = typed closure object
;   (mov dx ax) (call) (dw hex.ds.ax) ;*****    (int #x95) ;******
    (xor dh dh)                ; update closure offset & segment
    (ss:) (mov dx (bp db w)) 4
    (ss:) (mov ds (bp db w)) 6

;    (jmp) (dw gc.ret.ck) ;*****
    (l gc.copy.noclos)
;    (call) (dw gc.pcon) (ss 13 10 " ZC ")  ;*****
;
;  return address    not collectable if FP=0
;
    (l gc.ret.ck)
    (ss:) (mov (bp db w) ax) 2 ; AX = frame pointer
    (and ax ax)                ; if FP=0 then return address is not
    (jz) (db gc.copy.noret)    ; a collectable object

    (ss:) (lds (bp db w) bx) 8 ; DS:BX = return address
    (xor bx bx)
    (mov (bx w) ax)  ; AX = return code object header
    (cmp ib ah) #x3c   ;LCO
    (jz) (db gc.ret.ok)
    (cmp ib ah) #x38   ;BCO
    (jz) (db gc.ret.ok)
    (cmp ib ah) #xAC   ; forwarded LCO    
    (jz) (db gc.ret.ok)
    (cmp ib ah) #xA8   ; forwarded BCO    
    (jz) (db gc.ret.ok)
    (call) (dw gc.pcon)
    (ss "GC.copy.obj: bad return address")
    (mov ah dl)
    (jmp) (dw gc.error)

    (l gc.ret.ok)
    (xor al al)        ; AL = 0  offset for code object always 0
    (and ib ah) #x6f   ; clear type header bit & forward bit
    (mov ax dx)
    (call) (dw gc.copy.obj)
;   (mov dx ax) (call) (dw hex.ds.ax) ;*****    (int #x95) ;*******
    (ss:) (mov ds (bp db w)) 10 ; update return segment only
                          ; (offset does not change)
    (add ib bp) 12
    (jmp) (dw gc.stack.loop)

    (l gc.copy.noret)
;    (ss:) (lds (bp db w) ax) 8 ;***** DS:AX = return address
;    (call) (dw hex.ds.ax) ;*****    (int #x95) ;*******
    
    (add ib bp) 12
    (jmp) (dw gc.stack.loop)
;------------------------------------------------------
;  Sweep new semi-space copying all uncopied objects
;  Pointers to forwarded objects are updated
;  ES:DI = physical sweep pointer
;  DS:DX = object @ sweep pointer
;------------------------------------------------------
;  (()
;--------------------------------**
;  add CX to sweep pointer ES:DI
;----------------------------------
    (l gc.sweep.up)
    (add cx di)
    (jb) (db gc.sweep.carry)
    (mov di ax)
    (and iw ax) (iw #xc000)
    (jnz) (db gc.sweep.carry)
    (ret)
    
    (l gc.sweep.carry)    
    (mov di ax)
    (rcl ah) (rcl ah) (rcl ah)
    (mov ah al)
    (and iw ax) (iw #x0007)  ; AX = number of EMM pages to change
    (and iw di) (iw #x3fff)  ; DI = remainder

    (push bx)
    (push dx)
    
    (cs:) (mov (dw w) bx) (aw gc.page.f)  ; BX = current (from) page
    (add ax bx)
    (cs:) (mov bx (dw w)) (aw gc.page.f)  ; update (from) page

    (mov iw ax) (iw #x4400)  ; Map page 0 to logical BX
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (and ah ah)
    (jz) (db gc.sweep.up.ok)
    (call) (dw gc.pcon) (ss "gc.sweep.up: EMM error")
    (mov ib dl) 255
    (jmp) (dw gc.error)
    
    (l gc.sweep.up.ok)
    (pop dx)
    (pop bx)
    
    (ret)
;-------------------------------------------------------------
;  begin sweep
;-------------------------------------------------------------
    (l gc.sweep)
;    (call) (dw gc.pcon) (ss "GC.SWEEP")
    (cs:) (les (dw w) di) (aw gc.pef.off)   ; ES:DI = physical (from) pointer
    
    (l gc.sweep.loop)
;
; if sweep pointer = allocation pointer then end
;    
    (cs:) (cmp (dw w) di) (aw gc.pet.off)  ; (from) offset = (to) offset ?
    (jnz) (db gc.sweep.ck)
    (cs:) (mov (dw w) ax) (aw gc.page.f)  ; AX = current (from) page
    (cs:) (cmp (dw w) ax) (aw gc.page.t)  ; (from) page = (to) page ?
    (jnz) (db gc.sweep.ck)
    (jmp) (dw gc.end)
;
;  check type of object    
;    
    (l gc.sweep.ck)
    (es:) (mov (di w) dx)  ; DX = object type & offset
    (mov dx ax)
    (and ib ah) #xf0
    (cmp ib ah) #x30   ; check for variable length header
    (jnz) 3
    (jmp) (dw gc.sweep.var)
    (cmp ib ah) #x70   ; check for variable length header
    (jnz) 3
    (jmp) (dw gc.sweep.var)
    (cmp ib dh) #x0f   ; check for stack triple in a continuation
    (jz) (db gc.sweep.3)
    (and dh dh)
    (jns) (db gc.sweep.simple)
    (call) (dw gc.pcon) (ss "gc.sweep: bad object found")
    (mov ib dl) 255
    (jmp) (dw gc.error)
;--------------------------------------------
;  simple object
;--------------------------------------------
    (l gc.sweep.simple)
    (es:) (lds (di w) dx)
    (call) (dw gc.copy.obj)     ; DS:DX = copied object
    (es:) (mov dx (di db w)) 0  ; update object
    (es:) (mov ds (di db w)) 2
    (mov iw cx) (iw 4)
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;--------------------------------------------
;  stack triple
;--------------------------------------------
    (l gc.sweep.3)     ; stack triple (Frame, Closure, Return)
;    (push ax) (mov iw ax) (iw #x0200)(mov ib dl) #\@ (int #x21) (pop ax)
;    (int #x95)        ; print Frame Pointer
;
;  closure    not colectible if = 0
;
    (es:) (mov (di db w) bp) 2   ; BP = frame pointer
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (es:) (lds (di w) bx)        ; DS:BX = closure address
    (mov ds ax)
    (or bx ax)
    (jz) (db gc.sw.ret.ck)
    
    (mov (bx w) ax)        ; AX = closure object header
    (cmp ib ah) #x36       ; closure 
    (jz) (db gc.sw.clos.ok)
    (cmp ib ah) #x38       ; BCO
    (jz) (db gc.sw.clos.ok)
    (cmp ib ah) #xA6       ; forwarded closure
    (jz) (db gc.sw.clos.ok)
    (cmp ib ah) #xA8       ; forwarded BCO    
    (jz) (db gc.sw.clos.ok)
    (call) (dw gc.pcon)
    (ss "GC.sweep.obj: bad closure")
    (mov ah dl)
    (jmp) (dw gc.error)

    (l gc.sw.clos.ok)
    (mov bl al)                ; AL = offset
    (and ib ah) #x6f           ; clear type header bit & foward bit
    (mov ax dx)
    (call) (dw gc.copy.obj)    ; DS:AX = typed closure object
;   (mov dx ax) (int #x95) ;******
    (xor dh dh)                ; update closure offset & segment
    (es:) (mov dx (di db w)) 0
    (es:) (mov ds (di db w)) 2
;
;  return address    not collectible if FP = 0
;
    (l gc.sw.ret.ck)
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (and bp bp)                ; if FP=0 then return address is not
    (jz) (db gc.sw.noret)      ; a collectable object
    
    (es:) (lds (di w) bx) ; DS:BX = return address
    (xor bx bx)
    (mov (bx w) ax)    ; AX = return code object header
    (cmp ib ah) #x3c   ; LCO
    (jz) (db gc.sw.ret.ok)
    (cmp ib ah) #x38   ; BCO
    (jz) (db gc.sw.ret.ok)
    (cmp ib ah) #xAC   ; forwarded LCO    
    (jz) (db gc.sw.ret.ok)
    (cmp ib ah) #xA8   ; forwarded BCO    
    (jz) (db gc.sw.ret.ok)
    (call) (dw gc.pcon)
    (ss "GC.sweep.obj: bad return address")
    (mov ah dl)
    (jmp) (dw gc.error)

    (l gc.sw.ret.ok)
    (xor al al)        ; AL = 0  offset for code object always 0
    (and ib ah) #x6f   ; clear type header bit & forward bit
    (mov ax dx)
    (call) (dw gc.copy.obj)
;   (mov dx ax) (int #x95) ;*******
    (es:) (mov ds (di db w)) 2 ; update return segment only
                               ; (offset does not change)

    (l gc.sw.noret)
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;--------------------------------------------
;  variable length object
;--------------------------------------------
;  (()
    (l gc.sweep.var)
    (mov dx ax)
    (and ib ah) 3        ; branch to byte, word, long sized
    (jnz) 3
    (jmp) (dw gc.sweep.byte)
    (dec ah)
    (jz) (db gc.sweep.word)
    (dec ah)
    (jz) (db gc.sweep.long)
    (call) (dw gc.pcon)
    (ss "GC.sweep: bad var size")
    (mov ib dl) 255
    (jmp) (dw gc.error)
;
;  long sized    
;    
    (l gc.sweep.long)   ; skip header on long sized objects
    (mov dx ax)
    (cmp ib ah) #x36
    (jz) (db gc.sweep.closure)
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;
;  closure
;
    (l gc.sweep.closure)
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (es:) (mov (di db w) ds) 2  ; DS = LCO code pointer segment
    (mov iw dx) (iw #x2c00)     ; DS:DX = LCO pointer (offset always 0)
    (call) (dw gc.copy.obj)
;   (mov dx ax) (int #x95)
    (es:) (mov ds (di db w)) 2  ; update code pointer segment
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;
;  word sized
;
    (l gc.sweep.word)
    (es:) (mov (di db w) ax) 2  ; AX = size of word sized object
    (add ax ax)              ; AX = byte size
    (add iw ax) (iw 7)       ; AX = byte size + 4 (for header) + 3 (round up)
    (and iw ax) (iw #xfffc)  ; AX = truncate
    (mov ax cx)
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;
;  byte sized
;
    (l gc.sweep.byte)
    (es:) (mov (di db w) ax) 2  ; AX = size of byte sized object
    (add iw ax) (iw 7)          ; AX = size + 4 (for header) + 3 (round up)
    (cmp ib dh) #x30            ; check for string
    (jnz) (db gc.sweep.bns)
    (inc ax)                    ; add 1 for extra zero on strings
    (l gc.sweep.bns)
    (and iw ax) (iw #xfffc)     ; AX = truncate
    (mov ax bp)                 ; BP = byte size of object rounded to long

    (mov dx ax)
    (cmp ib ah) #x3c      ; Lambda Code Object
    (jz) (db gc.sweep.code)
    (cmp ib ah) #x38      ; Body Code Object
    (jz) (db gc.sweep.code)

    (mov bp cx)           ; skip bytes in object
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)
;
;  code byte sized
;
    (l gc.sweep.code)
    (mov di ax)
    (and iw ax) (iw 3)     ; check for aligned code object ****
    (jz) (db gc.sw.code)
    (call) (dw gc.pcon)
    (ss "GC.sweep.code: misaligned code")
    (mov ib dl) 255
    (jmp) (dw gc.error)
;
;  calculate logical (from) address
;
    (l gc.sw.code)  ; logical segment = heap.base + (16K * page + offset) / 16
    (mov di bx)
    (shr bx)(shr bx)(shr bx)(shr bx)
    (cs:) (mov (dw w) ax) (aw gc.page.f)
    (add ax ax)(add ax ax)(add ax ax)(add ax ax)(add ax ax)
    (add ax ax)(add ax ax)(add ax ax)(add ax ax)(add ax ax)
    (add ax bx)
    (ss:) (add (dw w) bx) (aw gc.cur.base.seg)   ; BX = logical segment
    
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (sub cx bp)                  ; sub 4 from total
    (call) (dw gc.sweep.up)

    (es:) (mov bx (di db w)) 2   ; update segment of LCO closure gen pointer
;
;  copy all externs of LCO or BCO    
;    
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (sub cx bp)                  ; sub 4 from total
    (call) (dw gc.sweep.up)
    
    (es:) (mov (di db w) bx) 2   ; BX = number of externs

    (mov iw cx) (iw 4)           ; add 4 to sweep
    (sub cx bp)                  ; sub 4 from total
    (call) (dw gc.sweep.up)
    
    (and bx bx)                  ; do we have any more externs ?
    (jz) (db gc.sw.code.end)

    (l gc.sw.code.loop)
    
    (es:) (lds (di w) dx)        ; DS:DX = extern
    (push bx)
    (call) (dw gc.copy.obj)
    (pop bx)
;   (mov dx ax) (int #x95)       ; DX:DX = copied object
    (es:) (mov dx (di db w)) 0
    (es:) (mov ds (di db w)) 2
    (mov iw cx) (iw 4)           ; add 4 to sweep
    (sub cx bp)                  ; sub 4 from total
    (call) (dw gc.sweep.up)
    (dec bx)
    (jnz) (db gc.sw.code.loop)

    (l gc.sw.code.end)
    (mov bp cx)                ; add remaining bytes to sweep
    (call) (dw gc.sweep.up)
    (jmp) (dw gc.sweep.loop)

;---------------------------------------------------------------------------**
;  copy object DS:DX to new semi-space @ physical address EMM page 1
;  returns new object in DS:DX as logical address
;  bashes AX,BX,CX,SI
;-----------------------------------------------------------------------------
;  (()
;
;  simple object ?    
;    
    (l gc.copy.obj)
    (mov dx ax)        ; AX = type & current offset
    (and ib ah) #xf0   ; check for simple object
    (jnz) (db gc.ck0)

    (mov dx ax)
    (and al al)        ; check for zero offset (all simples except #t)
    (jz) (db gc.copy.endj)
    (and ah ah)        ; check for zero type (boolean)
    (jz) (db gc.copy.endj)
    (call) (dw gc.pcon) (ss "gc.copy: simple non-zero offset ")
    (xor al al)
    (l gc.copy.endj)
;    (call) (dw gc.pcon) (ss " S.") (mov dx ax) (int #x95)
    (ret)
;
;  check for heap errors    
;    
    (l gc.ck0)
    (mov dx ax)
    (and ib ah) #x80
    (jz) (db gc.ck1)
    (call) (dw gc.pcon) (ss "gc.copy: forwarded pointer")
    (jmp) (dw gc.error)
    
    (l gc.ck1)
;    (mov dx ax)
;    (and ib al) #xf3   ; check for align object
;    (jz) (db gc.ck1.aligned)
;    (call) (dw gc.pcon) (ss " GC.MAO:") ;*****************
;    (mov dx ax) (int #x95)
;;    (jmp) (dw gc.error)  ;********************************
;
;  fixed object  (outside semi-space)  ? 
;
    (l gc.ck1.aligned)
    (mov ds ax)        ; check object for outside semi-space
    (ss:) (cmp (dw w) ax) (aw gc.begin.seg)
    (jae) (db gc.ck2)  ; if outside then return object

    (mov dx ax)
;    (call) (dw gc.pcon) (ss " O.") (mov dx ax) (int #x95)
    (ret)
;
;  forwarded object ?
;    
    (l gc.ck2)
    (mov dx ax)        ; check for forwarded object
    (xor ah ah)
    (mov ax si)        ; DS:SI = untagged to object
    (mov (si w) ax)
    (and ib ah) #x80   ; forwarded object if bit 7 set
    (jns) (db gc.ck3)

;    (call) (dw gc.pcon) (ss " F.")
    (lds (si w) ax)    ; DS:AX = forward object pointer
    (xor dh ah)        ; test forward type with actual type
    (xor ib ah) #x80
    (jz) (db gc.copy.fok)
    (call) (dw gc.pcon) (ss "gc.copy: forwarded object mismatch")
    (jmp) (dw gc.error)
    (l gc.copy.fok)
;   (mov dh ah) (int #x95)
    (mov al dl)        ; DS:DX = objects new location
    (ret)
;----------------------------------------------
;  check type of complex object
;----------------------------------------------
;  (()
    (l gc.ck3)
    (mov dx ax)
    (and ib ah) #xf0
    (cmp ib ah) #x10   ; check for fixed length object
    (jz) (db gc.copy.fix)
    (cmp ib ah) #x20   ; check for variable length object
    (jz) (db gc.copy.var)
    (cmp ib dh) #x64   ; unresolved BCO
    (jz) (db gc.copy.var)
    (cmp ib dh) #x6c   ; CVO
    (jz) (db gc.copy.cvo)
    
    (l gc.copy.ge)
    (call) (dw gc.pcon)
    (ss "GC.copy.obj: bad object group")
    (mov dx ax)
    (int #x95)
    (jmp) (dw gc.error)
;
;  copy fixed sized object: box, pair, symbol, port
;
    (l gc.copy.fix)
    (xor cx cx)       ; CX = 4 * object size
    (mov dh cl)
    (and ib cl) 3
    (inc cx)
    (add cx cx)
    (add cx cx)
    (jmp) (dw gc.copy.emm)
;
;  copy Code Vector Object    
;
    (l gc.copy.cvo)
    (mov iw cx) (iw #x000c)
    (cs:) (sub (dw w) cx) (aw gc.logic.off) ; CX = 12 - logical offset
    (jz) (db gc.para.ok)
    (push es)
    (push di)
    (push ds)            ; align new address to 12 (#xC) offset 
    (push si)
    (mov cs ax)
    (mov ax ds)
    (mov iw si) (aw zero.buf)
    (call) (dw gc.copy.page)
    (pop si)
    (pop ds)
    (pop di)
    (pop es)
    (jmps) (db gc.para.ok)
;
;  copy variable sized object    
;
    (l gc.copy.var)
    (mov dx ax)            ; check for paragraph bounded object
    (and ib ah) #x08
    (jz) (db gc.para.ok)
    (cs:) (mov (dw w) ax) (aw gc.logic.off) ; CX = logical offset
    (and ax ax)
    (jz) (db gc.para.ok)
    (mov iw cx) (iw 16)    ; paragraph align new address
    (sub ax cx)
    (push es)
    (push di)
    (push ds)              ; align new address to 0 offset 
    (push si)
    (mov cs ax)
    (mov ax ds)
    (mov iw si) (aw zero.buf)
    (call) (dw gc.copy.page)
    (pop si)
    (pop ds)
    (pop di)
    (pop es)
;
;  check variable sized object DS:DX with header @DS:SI
;
    (l gc.para.ok)
    (mov (si w) ax)    ; AX = object header
    (xor ib ah) #x10   ; invert header bit
    (cmp ah dh)        ; check header type AH to object type DH
    (jz) (db gc.var.ok)
    
    (cmp ib ah) #x20   ; check for unresolved/BCOun to string mismatch *****
    (jnz) (db gc.mismatch)
    (cmp ib dh) #x24
    (jz) (db gc.var.ok)
    (cmp ib dh) #x64
    (jz) (db gc.var.ok)
    
    (l gc.mismatch)
    (call) (dw gc.pcon)
    (ss "GC.copy.obj: pointer/object mismatch")
    (mov dh dl)
    (jmp) (dw gc.error)
;
;  copy variable sized object
;
    (l gc.var.ok)
    (mov (si db w) cx) 2 ; CX = size of object
    (mov dx ax)
    (and ib ah) 3        ; branch to byte, word, long sized
    (jz) (db gc.var.byte)
    (dec ah)
    (jz) (db gc.var.word)
    (dec ah)
    (jz) (db gc.var.long)
    
    (call) (dw gc.pcon)
    (ss "GC.copy.obj: bad var size")
    (jmp) (dw gc.error)
;
;  byte variable sized
; 
    (l gc.var.byte)
    (add iw cx) (iw 7)    ; CX = byte size + 4 (for header) + 3 (round up)
    (cmp ib dh) #x20      ; check object for string
    (jz) (db gc.var.bs)
    (cmp ib dh) #x24      ; check object for unresolved (string)
    (jz) (db gc.var.bs)
    (cmp ib dh) #x64      ; check object for BCO unresolved (string)
    (jnz) (db gc.var.bns)
    (l gc.var.bs)
    (inc cx)              ; add 1 for extra zero on strings
    (l gc.var.bns)
    (and iw cx) (iw #xfffc) ; truncate to long number bytes
    (jmps) (db gc.var.copy)

    (l gc.var.word)
    (add cx cx)           ; CX = byte size of word object
    (add iw cx) (iw 7)    ; CX = byte size + 4 (for header) + 3 (round up)
    (and iw cx) (iw #xfffc) ; truncate to long number bytes
    (jmps) (db gc.var.copy)
    
    (l gc.var.long)
    (inc cx)          ; add 1 for header
    (add cx cx)       ; CX = byte size of long object
    (add cx cx)
    
    (l gc.var.copy)  ;  copy object @ DS:SI sized by CX bytes
;------------------------------------------------------------------------
;  Copy object from DS:SI to logical address (physical address EMM page 1)
;  Writes foward pointer @ logical address with type DH
;  block is CX bytes
;------------------------------------------------------------------------
;  (()
    (l gc.copy.emm)
    (push es)
    (push di)
    
    (mov cx ax)        ; size must be long sized
    (and iw ax) (iw 3)
    (jz) (db gc.emm.ok)
    (call) (dw gc.pcon) (ss "gc.copy.emm: bad size")
    (jmp) (dw gc.error)

    (l gc.emm.ok)
    (cs:) (les (dw w) di) (aw gc.logic.off) ; ES:DI = logical address of new
    (push es)
    (push di)
    (push ds)
    (push si)
    (push cx)
    (call) (dw gc.copy.page)
    (pop cx)       ; CX = byte size of copied object
    (pop di)       ; ES:DI = untagged to old object
    (pop es)       ; DH = tag of object
    (pop si)       ; DS:SI = logical address of new object
    (pop ds)
;
;  write foward pointer
;
    (mov si ax)         
    (mov dh ah)
    (mov ax dx)            ; DS:DX = tagged new object

    (or ib ah) #x80        ; DS:AX = tagged fowarded new object
    (es:) (mov ax (di db w)) 0   ; (ES:DI) = DS:AX    write forward pointer
    (es:) (mov ds (di db w)) 2
    
;    (call) (dw gc.pcon) (ss " C.")
;    (mov dx ax) (int #x95)

    (pop di)
    (pop es)
    (ret)
;----------------------------------------------------------------------**
;  copy block from DS:SI to EMM page 1   CX = number bytes
;  updates physical and logical address
;  bashes AX,BX,CX,SI,DI,ES
;------------------------------------------------------------------------    
    (l gc.copy.page)
;
;   update logical address
;
    (cs:) (les (dw w) di) (aw gc.logic.off) ; ES:DI = logical address
    (add cx di)
    (mov di ax)
    (and iw ax) (iw #x000f)              ; AX = new offset
    (cs:) (mov ax (dw w)) (aw gc.logic.off)
    (mov di ax)
    (shr ax) (shr ax) (shr ax) (shr ax)
    (mov es bx)
    (add bx ax)                          ; AX = new segment
    (cs:) (mov ax (dw w)) (aw gc.logic.seg)
;
;  compare object size to space in current EMM page
;
    (cs:) (les (dw w) di) (aw gc.pet.off)   ; ES:DI = physical EMM address
    (mov cx ax)
    (and iw ax) (iw #xc000)    ; is object larger than (16K bytes)?
    (jnz) (db gc.page.multi)
    (mov cx ax)             ; AX = copy size in bytes
    (add di ax)
    (sub iw ax) (iw #x4000) ; AX = EMM offset + copy size - 16K
    (jns) (db gc.page.cut)   ; if too big then copy must be cut into pieces
;
;  object will fit in current EMM page
;   
    (cld)
    (shr cx)       ; CX = CX / 2 
    (movs.w cx)    ; copy object to EMM page
    (cs:) (mov di (dw w)) (aw gc.pet.off)   ; update physical EMM address
    (ret)
;
;  object will NOT fit in current EMM page   cut into 2 pieces   size = CX
;
    (l gc.page.cut)
    (mov iw ax) (iw #x4000)
    (sub di ax)   ; AX = 16K - current EMM offset = bytes left
    (sub ax cx)
    
    (mov cx bx)
    (mov ax cx)
    (cld)
    (shr cx)       ; CX = CX / 2 
    (movs.w cx)    ; copy 1st part of object to EMM page
    (mov bx cx)

    (push bx)
    (push dx)
    (mov iw ax) (iw #x4401)  ; Map physical page 1 to new logical page
    (cs:) (mov (dw w) bx) (aw gc.page.t)
    (inc bx)
    (cs:) (mov bx (dw w)) (aw gc.page.t)
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (pop dx)
    (pop bx)
    (and ah ah)
    (jnz) (db gc.page.err)
    
    (xor di di)
    (and cx cx)
    (jz) (db gc.page.cut.end)
    (cld)
    (shr cx)       ; CX = CX / 2 
    (movs.w cx)    ; copy 2nd part of object to EMM page
    (l gc.page.cut.end)
    (cs:) (mov di (dw w)) (aw gc.pet.off)   ; update physical EMM address
    (ret)
;
;  EMM error
;
    (l gc.page.err)
    (call) (dw gc.pcon) (ss "gc.copy.page: EMM error")
    (jmp) (dw gc.error)
;
;  object will NOT fit in current EMM page   cut into multiple pieces
;  size = CX
;  ES:DI = physical EMM address
;
    (l gc.page.multi)
    (mov iw ax) (iw #x4000)
    (sub di ax)   ; AX = 16K - current EMM offset = bytes this page
    (sub ax cx)   ; CX = object size - byte this page  (bytes left)
    
    (l gc.page.multi.loop)  ; AX = copy size  CX = bytes left
    (mov cx bx)
    (mov ax cx)
    (cld)
    (shr cx)       ; CX = CX / 2 
    (movs.w cx)    ; copy 1st part of object to EMM page
    (mov bx cx)    ; CX = bytes left

    (push bx)
    (push dx)
    (mov iw ax) (iw #x4401)  ; Map physical page 1 to new logical page
    (cs:) (mov (dw w) bx) (aw gc.page.t)
    (inc bx)
    (cs:) (mov bx (dw w)) (aw gc.page.t)
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (pop dx)
    (pop bx)
    (and ah ah)
    (jnz) (db gc.page.err)
    
    (xor di di)
    (and cx cx)
    (jz) (db gc.page.multi.end)
    
    (mov cx ax)
    (and iw ax) (iw #xc000)         ; if remaining object > 16K
    (jnz) (db gc.page.multi.more)   ; then cut again
    
    (cld)
    (shr cx)       ; CX = CX / 2 
    (movs.w cx)    ; copy 2nd part of object to EMM page
    (l gc.page.multi.end)
    (cs:) (mov di (dw w)) (aw gc.pet.off)   ; update physical EMM address
    (ret)

    (l gc.page.multi.more)
    (sub iw cx) (iw #x4000)  ; CX = remaining object - 16K
    (mov iw ax) (iw #x4000)  ; AX = bytes to copy
    (jmp) (dw gc.page.multi.loop)   ; AX = copy size  CX = bytes left
    
;--------------------------------------------------------------
;  copy page from EM pages to heap
;--------------------------------------------------------------
    (l gc.end)
    (mov di bp)     ; BP = remainder of last page
    (xor bx bx)     ; set logical page to 0
    (ss:) (mov (dw w) es) (aw gc.cur.base.seg)
    (xor di di)     ; ES:DI = copy to pointer

    (l gc.end.loop)
    (mov iw ax) (iw #x4400)  ; Map physical page 0 to logical page BX
    (ss:) (mov (dw w) dx) (aw em.handle)
    (int #x67)
    (and ah ah)
    (jnz) (db gc.end.err)

    (cs:) (cmp (dw w) bx) (aw gc.page.t)
    (jz) (db gc.end.last)
    
    (cs:) (mov (dw w) ds) (aw gc.pef.seg)
    (xor si si)              ; DS:SI = copy from pointer
    (mov iw cx) (iw #x2000)  ; CX = number of words to copy
    (cld)
    (movs.w cx)              ; COPY
    (mov es ax)              ; update ES:DI 
    (add iw ax) (iw #x400)
    (mov ax es)
    (xor di di)
    (inc bx)                 ; next page
    (jmps) (db gc.end.loop)
;
;  last page    
;    
    (l gc.end.last)
    (mov bp cx)              ; convert byte size to word size
    (shr cx)
    (jz) (db gc.return.ck)
    (cs:) (mov (dw w) ds) (aw gc.pef.seg)
    (xor si si)              ; DS:SI = copy from pointer
    (cld)
    (movs.w cx)              ; COPY
    (jmps) (db gc.return.ck)
    
    (l gc.end.err)
    (call) (dw gc.pcon) (ss "gc.end: EMM error")
    (jmp) (dw gc.error)
    
;--------------------------------------------------------------
;  return from GC
;--------------------------------------------------------------
    (l gc.return.ck)
    (cs:) (lds (dw w) si) (aw gc.logic.off)
    (ss:) (mov ds (dw w)) (aw gc.alloc.seg)  ; update allocation pointer
    (ss:) (mov si (dw w)) (aw gc.alloc.off)

;    (mov iw ax) (iw #x0300)  ; get cursor position
;    (xor bx bx)
;    (int #x10)
;    (mov dx cx)              ; CX = current
;    (mov iw ax) (iw #x0200)  ; set cursor position
;    (xor bx bx)
;    (mov iw dx) (iw #x0100)
;    (int #x10)
    
;    (call) (dw gc.pcon) (ss " after:")  ;***************
;    (ss:) (mov (dw w) ax) (aw gc.alloc.seg)
;    (ss:) (sub (dw w) ax) (aw gc.cur.base.seg)
;    (call) (dw print.dec)
;    (call) (dw gc.pcon) (ss " avail:")
;    (ss:) (mov (dw w) ax) (aw gc.cur.end.seg) ; AX = paragraph availible
;    (ss:) (sub (dw w) ax) (aw gc.alloc.seg)
;    (call) (dw print.dec)
;    (call) (dw gc.pcon) (ss " need:")
;    (mov sp bp)
;    (ss:) (mov (bp db w) ax) 14  ; AX = arg1
;    (call) (dw print.dec)
;    (call) (dw gc.pcon) (ss 13 10)  ; ******

;    (mov iw ax) (iw #x0200)  ; restore cursor position
;    (xor bx bx)
;    (mov cx dx)
;    (int #x10)

    
    (ss:) (mov (dw w) ax) (aw gc.cur.end.seg) ; AX = paragraph availible
    (ss:) (sub (dw w) ax) (aw gc.alloc.seg)
    (jna) (db gc.overflow)       ; if < 1 para then fatal error
    (cmp iw ax) (iw 10)          ; if < 10 paras then memory full
    (jb) (db gc.full)
    (mov sp bp)
    (ss:) (sub (bp db w) ax) 14  ; subtract arg1 from avail
    (ja) (db gc.return)
    
    (l gc.full)
    (call) (dw gc.pcon) (ss 13 10 "GC: memory full!" 13 10)
    (mov ib dl) 0
    (int #x9e)

    (l gc.overflow)
    (call) (dw gc.pcon) (ss 13 10 "GC: failure to free space!"
			    13 10 "System can not recover properly" 13 10)
    (int #xa0)

    (l gc.return)
    (ss:) (lds (bp db w) ax) 12  ; DS:AX = arg1
    (pop bp)                     ; restore CP & FP
    (pop bp)
    (pop di)
    (pop es)
    (retaf) (iw 4)               ; kill arg

    (l gc.error)
    (int3)
    (call) (dw gc.pcon) (ss 13 10 "GC: FATAL ERROR" 13 10)
    (int #xa0)

;--------------------------------------------------------------
; print scheme string following call and continue after string 
; (note: Scheme string ends with 0)
;--------------------------------------------------------------
;  (()
    (dl gc.hold.ax gc.begin)
    (iw 0)
    
    (l gc.pcon)
    (cs:) (mov ax (dw w)) (aw gc.hold.ax)
    (pop ax)
    (push ds)
    (push dx)
    (push cx)
    (push bx)
    ;
    (mov ax bx)               ; bx=offset to string
    (mov cs ax)               ; ds=segment to string
    (mov ax ds)
    (mov (bx db w) cx) 2      ; put word length in cx
    (add ib bx) 4
    (mov bx dx)               ; dx=offset to string
    (mov iw bx) (iw 1)
    (mov iw ax) (iw #x4000)
    (int #x21)
    (mov dx ax)               ; ax=return address
    (add cx ax)
    (inc ax)                  ; add1 for ending 0 
    ;
    (pop bx)
    (pop cx)
    (pop dx)
    (pop ds)
    (push ax)
    (cs:) (mov (dw w) ax) (aw gc.hold.ax)
    (ret)
;--------------------------------------------------------------
; print DS:AX as hex
;--------------------------------------------------------------
    (l hex.ds.ax)
    (push si)
    (mov ax si)
    (call) (dw hex.ds.si)
    (pop si)
    (ret)
;--------------------------------------------------------------
; print DS:SI as hex
;--------------------------------------------------------------
;  (()
    (l hex.ds.si)
    (push ds)
    (push si)
    (push es)
    (push di)
    
    (push ax)
    (push bx)
    (push cx)
    (push dx)
    ;
    (mov cs ax) ; ES:DI = hex buffer
    (mov ax es)
    (mov iw di) (aw hex.buf)
    (cld)
    
    (mov ds ax)
    (mov ib cl) 12
    (shr cl ax)
    (call) (dw hex.digit)
    (mov ds ax)
    (mov ib cl) 8
    (shr cl ax)
    (call) (dw hex.digit)
    (mov ds ax)
    (mov ib cl) 4
    (shr cl ax)
    (call) (dw hex.digit)
    (mov ds ax)
    (call) (dw hex.digit)
    (mov ib al) #\:
    (stos.b)
    (mov si ax)
    (mov ib cl) 12
    (shr cl ax)
    (call) (dw hex.digit)
    (mov si ax)
    (mov ib cl) 8
    (shr cl ax)
    (call) (dw hex.digit)
    (mov si ax)
    (mov ib cl) 4
    (shr cl ax)
    (call) (dw hex.digit)
    (mov si ax)
    (call) (dw hex.digit)
    (mov ib al) #\space
    (stos.b)
    
    (mov cs ax)               ; ds=segment to string
    (mov ax ds)
    (mov iw dx) (aw hex.buf)  ; dx=offset to string
    (mov iw cx) (iw 10)       ; put length in cx
    (mov iw bx) (iw 1)
    (mov iw ax) (iw #x4000)
    (int #x21)

    (pop dx)
    (pop cx)
    (pop bx)
    (pop ax)

    (pop di)
    (pop es)
    (pop si)
    (pop ds)
    (ret)

    (l hex.digit)
    (and iw ax) (iw #xf)
    (cmp ib al) 10
    (jb) (db hex.num)
    (add ib al) 7
    (l hex.num)
    (add ib al) #\0
    (stos.b)
    (ret)
    
    (dl hex.buf gc.begin)
    (ss "0000:0000   ")

;---------------------------------------------------------
; print ax as decimal
;---------------------------------------------------------
    (l print.dec)
    (push bx)
    (push cx)
    (push dx)
    (push di)
    (push ds)
; 
    (push ax)
;
    (and ax ax)                 ;negate if minus
    (jns) (db decns)
    (neg ax)
    (l decns)                   ; setup for loop
    (mov cs cx)                 ; DS = segment to holding string
    (mov cx ds)
    (call) (iw 0) (l dec.str.base); DI = current PC
    (pop di)
    (add iw di) (aw dec.str.off); DI = DI + offset to holding string
                                ; DS:DI = untagged to holding string
    (mov iw bx) (iw 10)         ; constant 10
    (xor cx cx)                 ; counter of string size
    (l decloop)                 ; loop: divide by 10; put remiander in string
    (xor dx dx)                 ; high word of number
    (inc cx)
    (dec di)
    (div bx)
    (add ib dl) #\0
    (mov dl (di b)) 
    (and ax ax)
    (jnz) (db decloop)
    (pop ax)
    (push ax)                    ; add sign to string
    (and ax ax)
    (jns) (db decpns)
    (dec di)
    (inc cx)
    (mov ib (di b)) #\-
    (l decpns)
    (mov iw ax) (iw #x4000)     ; print result
    (mov di dx)
    (mov iw bx) (iw 1)
    (int #x21)
;
    (pop ax)
;
    (pop ds)
    (pop di)
    (pop dx)
    (pop cx)
    (pop bx)
    (ret)
    "        "
    (dl dec.str.off dec.str.base) 
    
;****************************************************************************
    )