;***************************************************************************** ; Scheme 8088 640K 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) ; 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 (starts as half way) ; FFE0 new semi-space end ; 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.new.base.seg #xffe6) (el gc.new.end.seg #xffe2) (el gc.top.stack #xffdc) ;point past last collected stack object ;--------------------------------------------------------------------------- ; start of collector code ;--------------------------------------------------------------------------- (mov sp ax) ; check for misaligned stack (and iw ax) (iw 3) (jz) (db gc.setup) (call) (dw gc.pcon) (ss "GC: misaligned stack") (mov ib dl) 255 (jmp) (dw gc.error) ;------------------------------------------------- ; setup for Garbage Collection ;------------------------------------------------- (l gc.setup) ; ; switch current pointers with new & set alloc to new ; ; (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) ; (xor dx dx) ; (int #x10) ; (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) ; (mov iw ax) (iw #x0200) ; restore cursor position ; (xor bx bx) ; (mov cx dx) ; (int #x10) (mov ss ax) (mov ax ds) (mov (dw w) bx) (aw gc.new.base.seg) ; transpose semi-space bases (mov (dw w) ax) (aw gc.cur.base.seg) (mov bx (dw w)) (aw gc.cur.base.seg) (mov ax (dw w)) (aw gc.new.base.seg) (mov (dw w) dx) (aw gc.new.end.seg) ; transpose semi-space segments (mov (dw w) ax) (aw gc.cur.end.seg) (mov dx (dw w)) (aw gc.cur.end.seg) (mov ax (dw w)) (aw gc.new.end.seg) (mov bx (dw w)) (aw gc.alloc.seg) ; ************************* (xor ax ax) (mov ax (dw w)) (aw gc.alloc.off) (mov bx es) ; ES:DI = new allocation pointer (xor di di) ; (push es) ;******************** zero new space ; (push di) ; (ss:) (mov (dw w) cx) (aw gc.new.end.seg) ; CX = space size in paras ; (ss:) (sub (dw w) cx) (aw gc.new.base.seg) ; (l gc.cl.loop) ; (xor ax ax) ; (xor di di) ; (cld) ; (stos.w) (stos.w) (stos.w) (stos.w) ; (stos.w) (stos.w) (stos.w) (stos.w) ; (mov es ax) ; (inc ax) ; (mov ax es) ; (loop) (db gc.cl.loop) ; (pop di) ; (pop es) ;------------------------------------------------------ ; 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) (l gc.stack.loop) (mov bp ds) (cmp iw bp) (aw gc.top.stack) (jnz) 3 (jmp) (dw gc.sweep) (ss:) (lds (bp db w) ax) 0 ; DS:AX = arg off stack (cmp ib ah) #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 ax (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 (call) (dw gc.copy.obj) ; DS:AX = typed closure object ; (call) (dw hex.ds.ax) ;***** (int #x95) ;****** (xor ah ah) ; update closure offset & segment (ss:) (mov ax (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) cx) 8 ; DS:CX = 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 (call) (dw gc.copy.obj) ; (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 ; DS:SI sweep pointer ES:DI allocation pointer ;------------------------------------------------------ ; (() (l gc.sweep) ; DS:SI = base of new semi-space ; (call) (dw gc.pcon) (ss "GC.SWEEP") (ss:) (lds (dw w) si) (aw gc.cur.base.off) (l gc.sweep.loop) (cmp iw si) (iw #x0010) ; update DS:SI so SI is 0000-000F (jb) (db gc.sweep.test) (mov si ax) (mov ib cl) 4 (shr cl ax) (mov ds dx) (add dx ax) (mov ax ds) (and iw si) (iw #x000f) (l gc.sweep.test) ; (call) (dw hex.ds.si) ; (call) (dw gc.pcon) (ss " SP.") ; (mov si ax) (mov ib ah) #x08 (int #x95) ; (push ds) ; debug print object ************* ; (push si) ; (mov (si w) ax) ; (and ib ah) #xf0 ; (cmp ib ah) #x30 ; (jnz) (db gc.sw.p.s) ; (mov si ax) ; (mov (si w) bx) ; (mov bh ah) ; (and ib ah) #xef ; (jmps) (db gc.sw.p.c) ; (l gc.sw.p.s) ; (lds (si w) ax) ; (l gc.sw.p.c) ; (int #x95) ; (pop si) ; (pop ds) (cmp si di) ; if sweep pointer = allocation pointer then end (jnz) (db gc.sweep.ck) (mov ds ax) (mov es bx) (cmp ax bx) (jnz) (db gc.sweep.ck) (jmp) (dw gc.end) (l gc.sweep.ck) (mov (si w) bx) ; BX = object type & offset (mov bx 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 bh) #x0f ; check for stack triple in a continuation (jz) (db gc.sweep.3) (and bh bh) (jns) (db gc.sweep.simple) (call) (dw gc.pcon) (ss "gc.sweep: forwarded object found") (mov ib dl) 255 (jmp) (dw gc.error) ; ; simple object ; (l gc.sweep.simple) (push ds) (push si) (lds (si w) ax) (call) (dw gc.copy.obj) (mov ds dx) ; DX:AX = copied object (pop si) (pop ds) (mov ax (si db w)) 0 (mov dx (si db w)) 2 (add ib si) 4 (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 (push ds) (push si) ; ; closure not colectible if = 0 ; (lds (si db w) bx) 4 ; DS:BX = closure address (mov ds ax) (or bx ax) (jnz) (db gc.sw.copy.clos) (pop si) (pop ds) (jmps) (db gc.sw.ret.ck) (l gc.sw.copy.clos) (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) (pop si) (pop ds) (jmp) (dw gc.error) (l gc.sw.clos.ok) (mov bl al) ; AL = offset (and ib ah) #x6f ; clear type header bit & foward bit (call) (dw gc.copy.obj) ; DS:AX = typed closure object ; (int #x95) ;****** (mov ds dx) (xor ah ah) ; update closure offset & segment (pop si) (pop ds) (mov ax (si db w)) 4 (mov dx (si db w)) 6 ; ; return address not collectible if FP = 0 ; (l gc.sw.ret.ck) (mov (si db w) ax) 2 ; AX = frame pointer (and ax ax) ; if FP=0 then return address is not (jz) (db gc.sw.noret) ; a collectable object (push ds) (push si) (lds (si db w) cx) 8 ; DS:CX = 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) (pop si) (pop ds) (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 (call) (dw gc.copy.obj) ; (int #x95) ;******* (mov ds dx) (pop si) (pop ds) (mov dx (si db w)) 10 ; update return segment only ; (offset does not change) (l gc.sw.noret) (add ib si) 12 (jmp) (dw gc.sweep.loop) ; ; variable length object ; (l gc.sweep.var) (mov bx 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.copy.obj: bad var size") (mov ib dl) 255 (jmp) (dw gc.error) (l gc.sweep.long) ; skip header on long sized objects (mov bx ax) (cmp ib ah) #x36 (jz) (db gc.sweep.closure) (add ib si) 4 (jmp) (dw gc.sweep.loop) (l gc.sweep.closure) (push ds) (push si) (mov (si db w) ds) 6 ; DS = LCO code pointer segment (mov iw ax) (iw #x2c00) ; DS:AX = LCO pointer (offset always 0) (call) (dw gc.copy.obj) ; (int #x95) (mov ds ax) ; AX = copied code object segment (pop si) (pop ds) (mov ax (si db w)) 6 ; update code pointer segment (add ib si) 8 ; skip header & code pointer (jmp) (dw gc.sweep.loop) (l gc.sweep.word) (mov (si db w) ax) 2 ; AX = size of word sized object (add iw ax) (iw 3) ; AX = size + 2 (for header) + 1 (round up) (shr ax) ; AX = long size (add ax ax) ; AX = AX * 4 change long size to byte size (add ax ax) (add ax si) ; DS:SI points past object (jmp) (dw gc.sweep.loop) (l gc.sweep.byte) (mov (si db w) ax) 2 ; AX = size of non-code byte sized object (add iw ax) (iw 7) ; AX = size + 4 (for header) + 3 (round up) (cmp ib bh) #x30 ; check for string (jnz) (db gc.sweep.bns) (inc ax) ; add 1 for extra zero on strings (l gc.sweep.bns) (shr ax) ; AX = long size (shr ax) (add ax ax) ; AX = AX * 4 change long size to byte size (add ax ax) (mov ax bp) ; BP = long size of byte sized object (mov bx 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) (add bp si) ; DS:SI points past object (jmp) (dw gc.sweep.loop) (l gc.sweep.code) (and si si) ; 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) (l gc.sw.code) (mov ds (si db w)) 6 ; update segment of closure section pointer (mov (si db w) cx) 10 ; CX = number of externs (add ib si) 12 ; DS:SI points to first extern (and cx cx) (jz) (db gc.sw.code.end) (l gc.sw.code.loop) (push cx) (push ds) (push si) (lds (si w) ax) ; DS:AX = extern (call) (dw gc.copy.obj) ; (int #x95) (mov ds dx) ; DX:AX = copied object (pop si) (pop ds) (pop cx) (mov ax (si db w)) 0 (mov dx (si db w)) 2 (add ib si) 4 (dec cx) (jnz) (db gc.sw.code.loop) (l gc.sw.code.end) (mov bp si) ; DS:SI points past end (jmp) (dw gc.sweep.loop) ;------------------------------------------------------ ; copy object DS:AX to new semi-space @ ES:DI ; return new object in DS:AX ;------------------------------------------------------ ; (() (l gc.copy.obj) (push bp) (mov ax bx) ; BX = type & current offset (and ib ah) #xf0 ; check for simple object (jnz) (db gc.ck1) (mov bx 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 bx ax) (int #x95) (jmp) (dw gc.copy.end) (l gc.ck1) (and ib al) #xf3 ; check for align object (jz) (db gc.ck1.aligned) ; (call) (dw gc.pcon) (ss " GC.MAO:") ;***************** ; (mov bx ax) (int #x95) ; (jmp) (dw gc.error) ;******************************** (l gc.ck1.aligned) (mov ds cx) ; check object for outside semi-space (ss:) (cmp (dw w) cx) (aw gc.begin.seg) (jae) (db gc.ck2) ; if outside then return object (mov bx ax) ; (call) (dw gc.pcon) (ss " O.") (mov bx ax) (int #x95) (jmp) (dw gc.copy.end) (l gc.ck2) (mov bx ax) ; check for forwarded object (xor ah ah) (mov ax si) ; DS:SI = untagged to object (mov ax bp) ; DS:BP = 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 (mov bh ah) ; replace forward type with actual type (and ah ah) (jns) (db gc.copy.fok) (call) (dw gc.pcon) (ss "gc.copy: forwarded object returning foward") (jmp) (dw gc.error) (l gc.copy.fok) ; (int #x95) (jmp) (dw gc.copy.end) ; ; check type of complex object ; (l gc.ck3) (mov bx 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 bh) #x64 ; unresolved BCO (jz) (db gc.copy.var) (cmp ib bh) #x6c (jz) (db gc.copy.cvo) (l gc.copy.ge) (call) (dw gc.pcon) (ss "GC.copy.obj: bad object group") (mov bx ax) (int #x95) (jmp) (dw gc.error) ; ; copy fixed sized object: box, pair, symbol, port ; (l gc.copy.fix) (mov di dx) ; DX = type & new offset (mov bh dh) (xor cx cx) ; CX = 2 * object size (mov bh cl) (and ib cl) 3 (inc cx) (add cx cx) (cld) (movs.w cx) ; copy object (jmp) (dw gc.copy.up) ; ; copy Code Vector Object ; (l gc.copy.cvo) (xor ax ax) ; store 3 #f's (mov iw cx) (iw 6) (cld) (stos.w cx) (mov iw di) (iw #x000c) ; align ES:DI to 000C (jmps) (db gc.para.ok) ; ; copy variable sized object ; (l gc.copy.var) (mov bx ax) ; check for paragraph bounded object (and ib ah) #x08 (jz) (db gc.para.ok) (and di di) ; check ES:DI for paragraph (jz) (db gc.para.ok) (xor ax ax) ; store 3 #f's (mov iw cx) (iw 6) (cld) (stos.w cx) (xor di di) ; paragraph align ES:DI (mov es ax) (inc ax) (mov ax es) ; ; check variable sized object DS:BX with header @DS:SI & @DS:BP ; (l gc.para.ok) (mov di dx) ; DX = type & new offset (mov bh dh) (mov (si w) ax) ; AX = object header (xor ib ah) #x10 ; invert header bit (cmp ah bh) ; check header type AH to object type BH (jz) (db gc.var.ok) (cmp ib ah) #x20 ; check for unresolved/BCOun to string mismatch ***** (jnz) (db gc.mismatch) (cmp ib bh) #x24 (jz) (db gc.var.ok) (cmp ib bh) #x64 (jz) (db gc.var.ok) (l gc.mismatch) (call) (dw gc.pcon) (ss "GC.copy.obj: pointer/object mismatch") (mov bh dl) (jmp) (dw gc.error) (l gc.var.ok) (mov (si db w) cx) 2 ; CX = size of object (mov bx 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) (l gc.var.byte) (add iw cx) (iw 7) ; AX = size + 4 (for header) + 3 (round up) (mov (si w) ax) ; AX = object header (cmp ib ah) #x30 ; check for string (jnz) (db gc.var.bns) (inc cx) ; add 1 for extra zero on strings (l gc.var.bns) (shr cx) (shr cx) (add cx cx) ; CX = CX * 2 change long size to word size (jmps) (db gc.var.copy) (l gc.var.word) (add ib cx) 3 ; CX = size + 2 (for header) + 1 (round up) (shr cx) ; CX = long size (add cx cx) ; CX = CX * 2 change long size to word size (jmps) (db gc.var.copy) (l gc.var.long) (inc cx) ; add 1 for header (add cx cx) ; CX = size * 2 (size in words) (l gc.var.copy) ; copy object @ DS:SI to ES:DI sized by CX words (cld) (movs.w cx) ; copy object ; ; update alloc pointer & forward object ; (l gc.copy.up) (mov dx ax) ; forward object offset (or ib ah) #x80 (ds:) (mov ax (bp db w)) 0 (ds:) (mov es (bp db w)) 2 ; forward object segment (mov di bx) ; BX = unadjusted alloc offset (and iw di) (iw #x000f) ; DI = adjusted alloc offset (mov es ax) (mov ax ds) ; DS = object new segment (mov ib cl) 4 (shr cl bx) ; divide alloc offset by 16 (add bx ax) ; add to alloc segment (mov ax es) ; ES = adjusted alloc segment (mov dx ax) ; AX = object type & new offset ; (call) (dw gc.pcon) (ss " C.") ; (mov dx ax) (int #x95) (l gc.copy.end) (pop bp) (ret) ;-------------------------------------------------------------- ; return from GC ;-------------------------------------------------------------- (l gc.end) (ss:) (mov es (dw w)) (aw gc.alloc.seg) ; update allocation pointer (ss:) (mov di (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) (call) (dw gc.pcon) (ss 13 10 "GC: FATAL ERROR" 13 10) (int3) (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) ;**************************************************************************** )