;--------------------------------------------------------------------------
;  scheme primitive loader  %load
;  loads files  or  Code Vector Objects
;  relocates code and resolves all unresoled externals (links)
;  (%load arg)    arg=string  then load file string
;                 arg=CVO     then load CVO
;--------------------------------------------------------------------------
   ((l load.begin)
    (cmp iw ax) (iw 1)       ; do we have 1 arg?
    (jz) (db load.1arg)
    (mov ib dl) 1
    (int #x90)
    
    (l load.1arg)
    (mov sp bp)
    (ss:) (lds (dw bp w) ax) (iw 0); DS:AX = arg1 
    (cmp ib ah) #x20               ; check for string
    (jz) (db load.file)
    (cmp ib ah) #x6c               ; check for code vector object
    (jz) (db load.cvo)
    (mov ib dl) 220
    (int #x90)
;------------------ load code vector ----------------
    (l load.cvo)
    (cmp ib al) #x0c  ; check for aligned CVO
    (jz) 3
    (jmp) (dw load.cvo.err)

;    (call) (dw ps.con)  ;******************
;    (ss 254)
    
    (mov ds ax)       ; DS = segment to 1st byte in CVO
    (inc ax)
    (mov ax ds)
    (jmp) (dw load.relocate.cvo)
;------------------ load from file ------------------
    (l load.file)
    (xor ah ah)     ; DS:DX = untagged file string ending with 0
    (mov ax dx)
    (add ib dx) 4
    
;     (mov ax bx)               ; bx=offset to string ************
;     (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)                ; *********************************

; open file
    (mov iw ax) (iw #x3d40)
    (int #x21)
    (jae) (db open.ok)
    (jmp) (dw load.open.err)
    (l open.ok)
; get size of file
    (mov ax bp)              ; BP = file handle
    (mov iw ax) (iw #x4202)
    (mov bp bx)
    (xor cx cx)
    (xor dx dx)
    (int #x21)               ; DX:AX = size of file
    (and dx dx)
    (jz) (db size.ok)
    (jmp) (dw load.size.err)
    (l size.ok)
    (mov ax di)              ; DI = size of file
    (mov iw ax) (iw #x4200)  ; reset file pointer to beginning
    (mov bp bx)
    (xor cx cx)
    (xor dx dx)
    (int #x21)
;------------ allocate space to hold file ------------
    (mov iw bx) (iw #x0800)
    (push di)           ; push  file size as fixnum
    (push bx)
    (push bp)           ; push  DOS handle as fixnum
    (push bx)
    (mov di ax)         ; round up file size to next para
    (add iw ax) (iw 15)
    (mov ib cl) 4
    (shr cl ax)
    (push ax)           ; push  space size in paras
    (push bx)
    
    (inc ax)            ; add1 for para alignment
    (xor bp bp)              ; BP = 0  (frame pointer)  return not collectible
    (xor di di)              ; CP = 0000:0000  CP not collectible
    (mov di es)
    (int #x96)          ; space check & GC   ES:DI = alloc pointer
    
    (mov es bx)         ; BX:DI = para aligned ES:DI
    (and di di)
    (jz) (db load.align)
    (xor di di)
    (inc bx)
    (l load.align)
    
    (pop ax)            ; pop  AX = space size
    (pop ax)
    (mov bx ds)         ; DS = segment of space beginning
    (add ax bx)         ; add space size to ES:DI
    (mov bx es)
    
    (int #x97)          ; update alloc ptr

;    (call) (dw ps.con)  ;******************
;    (ss ".")
    
    (pop bp)            ; pop  BP = DOS handle
    (pop bp)
    (pop di)            ; pop  DI = file size
    (pop di)
;-----------------  read in the file -------------------
    (xor dx dx)         ; DS:DX = untagged to allocated space
    (mov iw ax) (iw #x3f00)
    (mov bp bx)
    (mov di cx)
    (int #x21)
    (jae) 3
    (jmp) (dw load.read.err)
;Close File
    (mov iw ax) (IW #x3E00)
    (mov BP BX)
    (int #x21)
;---------------------------------------------------
; relocate objects pointed to by DS
; DS:0000 must point to a box.
; The box must contain a LCO pointer
;---------------------------------------------------
;  (()
    (l load.relocate.cvo)
    (xor si si)       ; SI = 0   will be number of unresolved
    (xor di di)       ; DI = 0
    (mov ds dx)       ; DX = segment for relocating
    (mov dx es)       ; ES:DI = untagged to box
    (push es)         ; push  tagged box pointer
    (mov iw ax) (iw #x1000)
    (push ax)

    (call) (dw relocate)

    (mov si ax)       ; AX = number of paras needed for unresolved's
    (add ax ax)       ; 2 paras per (even though only 5 longs are needed)
    (xor bp bp)              ; BP = 0  (frame pointer)  return not collectible
    (xor di di)              ; CP = 0000:0000  CP not collectible
    (mov di es)
    (int #x96)        ; check space & GC
    
    (pop ax)      ; pop  ES = segment of loaded objects
    (pop es)
;---------------------------------------------------
;  resolve externals in loaded object at ES:0000
;---------------------------------------------------
    (xor di di)
    (push es)                ; ES:DI=untagged pointer to object
    (call) (dw resolve)
    (pop es)
;---------------------------------------------------
;  call lambda code object pointed to by ES:0000 
;---------------------------------------------------
    (xor di di)
    (es:) (lds (di w) bx)    ; DS:BX = LCO pointer (box @ front of loaded obj)
    (cmp ib bh) #x2c         ; check for LCO
    (jz) 3
    (jmp) (dw load.obj.err)
    (xor bh bh)
    (xor bp bp)              ; BP = 0  (frame pointer)  return not collectible
    (xor di di)              ; CP = 0000:0000  CP not collectible
    (mov di es)
    (callf (bx db w)) 4      ; call LCO (returns closure)
;---------------------------------------------------
;  call closure
;---------------------------------------------------
    (mov sp bp)              ; current BP (FP)
    (push ds)                ; push closure to call
    (push ax)
    (mov iw dx) (iw 1)       ; 1 current arg
    (xor ax ax)              ; 0 args
    (int #x93)               ; tail call closure
;
;  %load errors
;
    (l load.open.err)
    (mov sp bp)
    (call) (dw ps.con)
    (ss 13 10 "ERROR: can not open load file ")
    (ss:) (lds (dw bp w) ax) (iw 0); DS:AX = arg1 
    (int #x95)
    (mov ib dl) 220
    (int #x90)

    (l load.size.err)
    (call) (dw ps.con)
    (ss 13 10 "ERROR: load file too big" 13 10)
    (mov ib dl) 220
    (int #x90)

    (l load.read.err)
    (call) (dw ps.con)
    (ss 13 10 "ERROR: problem reading load file" 13 10)
    (mov ib dl) 220
    (int #x90)

    (l load.cvo.err)
    (call) (dw ps.con)
    (ss 13 10 "ERROR: CVO not aligned" 13 10)
    (mov ib dl) 255
    (int #x90)

    (l load.obj.err)
    (call) (dw ps.con)
    (ss 13 10 "ERROR: bad loaded object" 13 10)
    (mov ib dl) 220
    (int #x90)
;--------------------------------------------------------------------------
;  relocate object @ untagged ES:DI to segment DX  
;  recursive decent relocater adjust segment values of pointers 
;  GCnote: SI should be zero on entry
;          SI counts the number of unresolved objects
;--------------------------------------------------------------------------
    (l relocate)
    (es:) (lds (di w) bx) ; get object @ ES:DI put into DS:BX
    (mov bx ax)           ; put type in AX
    (and ib ah) #xf0
    (cmp ib ah) #x10      ; fixed length object
    (jz) (db relocate.fix)
    (and ah ah)           ; if atomic then do nothing & return
    (jnz) (db relocate.test.simple)
    (ret)
;
;  test for simple objects
; 
    (l relocate.test.simple)
    (mov bx ax)
    (cmp ib ah) #x20  ; string
    (jz) (db relocate.simple)
    (cmp ib ah) #x24  ; unresolved
    (jz) (db relocate.simple.count)
    (cmp ib ah) #x64  ; BCO-unresolved
    (jz) (db relocate.simple.count)
    (cmp ib ah) #x21  ; bignum
    (jz) (db relocate.simple)
    (cmp ib ah) #x25  ; real
    (jnz) (db relocate.complex)
;
; relocate simple objects
;
    (l relocate.simple.count)
    (inc si)
    (l relocate.simple)
    (mov ds ax)       ; adjust segment @ ES:DI to be DS+DX
    (add dx ax)
    (es:) (mov ax (di db w)) 2
    (ret)
;
;  relocate fixed length objects
;
    (l relocate.fix)
    (mov bx ax)       ; put length of fixed size object in cx
    (and ib ah) 3
    (inc ah)
    (mov ah cl)
    (xor ch ch)
    (mov ds ax)       ; adjust segment @ ES:DI to be DS+DX
    (add dx ax)
    (es:) (mov ax (di db w)) 2
    (mov ax es)       ; make new ES:DI = untagged DS+DX:BX
    (xor bh bh)
    (mov bx di)
    (jmp) (dw relocate.loop)
;
; test for variable length objects 
;
    (l relocate.complex)
    (mov bx ax)
    (cmp ib ah) #x2c  ; lambda code object
    (jz) (db relocate.code)
    (cmp ib ah) #x28  ; body code object
    (jz) (db relocate.code)
    (cmp ib ah) #x22  ; vector
    (jz) (db relocate.vector)
    (cmp ib ah) #x26  ; closure
    (jz) (db relocate.closure)
    (call) (dw ps.con)
    (ss "bad object in load file changed to #f" 13 10)
    (xor ax ax)                    ; store #f @ ES:DI
    (es:) (mov ax (di w)) 
    (es:) (mov ax (di db w)) 2
    (ret)
;
    (l relocate.vector)
    (mov ds ax)                ; adjust segment @ ES:DI to be DS+DX
    (add dx ax)
    (es:) (mov ax (di db w)) 2
    (mov ax es)                ; make new ES:DI = untagged DS+DX:BX
    (xor bh bh)
    (mov bx di)
    (es:) (mov (di db w) cx) 2 ; put vector length in cx
    (add ib di) 4              ; adjust pointer to first cell of vector
    (jmp) (dw relocate.loop)
;
    (l relocate.code)
    (mov ds ax)                ; adjust segment @ ES:DI to be DS+DX
    (add dx ax)
    (es:) (mov ax (di db w)) 2
    (mov ax es)                ; make new ES:DI = untagged DS+DX:BX
    (xor bh bh)
    (mov bx di)
    (es:) (add dx (di db w)) 6  ; adjust segement for lambda-code address
    (es:) (mov (di db w) cx) 10 ; put extern length in cx
    (add ib di) 12              ; adjust pointer to first cell of vector
    (jmp) (dw relocate.loop)
;
    (l relocate.closure)
    (mov ds ax)                ; adjust segment @ ES:DI to be DS+DX
    (add dx ax)
    (es:) (mov ax (di db w)) 2
    (mov ax es)                ; make new ES:DI = untagged DS+DX:BX
    (xor bh bh)
    (mov bx di)
    (es:) (add dx (di db w)) 6  ; adjust segement for body-code address
    (es:) (mov (di db w) cx) 2  ; put non-local lex length in cx
    (sub ib cx) 2
    (add ib di) 8               ; adjust pointer to first cell of vector
    (jmp) (dw relocate.loop)
;
; relocate loop for object untagged ES:DI with CX cells
;
    (l relocate.loop) 
    (and cx cx)
    (jz) (db relocate.ret)     ; 0 objects then return
    (dec cx)
    (jz) (db relocate.one)     ; 1 object then tail call relocate
;
    (l relocate.next)          ; 2 or more then call each except last, then jmp
    (push cx)
    (push es)
    (push di)
    (call) (dw relocate)
    (pop di)
    (pop es)
    (pop cx)
    (add ib di) 4
    (loop) (db relocate.next)
;
    (l relocate.one)
    (jmp) (dw relocate)
;
    (l relocate.ret)
    (ret)
;--------------------------------------------------------------------------
;  RESOLVE externals in untagged object ES:DI  (link)
;  resolver replaces all unresolved objects with global symbol
;  GCnote: GC is needed if new symbols overflow heap
;--------------------------------------------------------------------------
;  (()
    (l resolve)
    (es:) (lds (di w) bx) ; get object @ ES:DI put into DS:BX
    (mov bx ax)           ; put type in AX
    (and ib ah) #xf0
    (cmp ib ah) #x10      ; fixed length object
    (jz) (db resolve.fix)
    (and ah ah)           ; if atomic then do nothing & return
    (jz) (db resolve.ret)
    (mov bx ax)
    (and ib ah) #xef      ; 0 header bit
    (cmp ib ah) #x20      ; string
    (jz) (db resolve.ret)
    (cmp ib ah) #x21      ; bignum
    (jz) (db resolve.ret)
    (cmp ib ah) #x25      ; real
    (jnz) (db resolve.complex)
    (l resolve.ret)
    (ret)
;
;  resolve fixed length objects
;
    (l resolve.fix)
    (mov bx ax)       ; put length of fixed size object in cx
    (and ib ah) 3
    (inc ah)
    (mov ah cl)
    (xor ch ch)
;
    (mov ds ax)       ; make new ES:DI = untagged DS:BX
    (mov ax es)
    (xor bh bh)
    (mov bx di)
    (jmp) (dw resolve.loop)
;
; test for variable length objects 
;
    (l resolve.complex)
    (mov bx ax)
    (and ib ah) #xef  ; zero header bit
    (cmp ib ah) #x24  ; unresolved
    (jz) (db resolve.un)
    (cmp ib ah) #x64  ; unresolved BCO
    (jnz) 3           ; skip jmp
    (jmp) (dw resolve.bco.un)
    (cmp ib ah) #x2c  ; lambda code object
    (jz) (db resolve.code)
    (cmp ib ah) #x28  ; body code object
    (jz) (db resolve.code)
    (cmp ib ah) #x22  ; vector
    (jz) (db resolve.vector)
    (cmp ib ah) #x26  ; closure
    (jz) (db resolve.closure)
    (call) (dw ps.con)
    (ss "bad object in resolve object" 13 10)
    (ret)
;
;  resolve UNRESOLVED object pointed to by ES:DI
;  contents of pointed to by DS:BX
;
    (l resolve.un)
    (xor bh bh)        ; DS:BX untagged pointer to unresolved
    (mov iw (bx w)) (iw #x3000) ;change unresolved header to string header 
    (mov bx ax)
    (mov ib ah) #x20   ; DS:AX string tagged pointer to unresolved
    (int #x91)         ; string->symbol
    (cld)              ; store symbol @ ES:DI
    (stos.w)
    (mov ds ax)
    (stos.w)
    (ret)
;
; resolve vector
;
    (l resolve.vector)
    (mov ds ax)                ; make new ES:DI = untagged DS:BX
    (mov ax es)
    (xor bh bh)
    (mov bx di)
    (es:) (mov (di db w) cx) 2 ; put vector length in cx
    (add ib di) 4              ; adjust pointer to first cell of vector
    (jmp) (dw resolve.loop)
;
; resolve body/lambda code object
;
    (l resolve.code)
    (mov ds ax)                ; make new ES:DI = untagged DS:BX
    (mov ax es)
    (xor bh bh)
    (mov bx di)
    (es:) (mov (di db w) cx) 10 ; put extern length in cx
    (add ib di) 12              ; adjust pointer to first cell of externs
    (jmp) (dw resolve.loop)
;
; resolve closure
;
    (l resolve.closure)
    (mov ds ax)                ; make new ES:DI = untagged DS:BX
    (mov ax es)
    (xor bh bh)
    (mov bx di)
    (es:) (mov (di db w) cx) 2  ; put non-local lex length in cx
    (sub ib cx) 2
    (add ib di) 8               ; adjust pointer to first cell of non-local
    (jmp) (dw resolve.loop)
;
; resolve loop for object untagged ES:DI with CX cells
;
    (l resolve.loop) 
    (and cx cx)
    (jz) (db resolve.ret2)     ; 0 objects then return
    (dec cx)
    (jz) (db resolve.one)     ; 1 object then jmp
;
    (l resolve.next)       ; 2 or more then call each except last, then jmp
    (push cx)
    (mov iw cx) (iw #x0800)
    (push cx)
    (push es)
    (push di)
    (call) (dw resolve)
    (pop di)
    (pop es)
    (pop cx)
    (pop cx)
    (add ib di) 4
    (loop) (db resolve.next)
;
    (l resolve.one)
    (jmp) (dw resolve)
;    
    (l resolve.ret2)
    (ret)
;
;   resolve BCO-UNRESOLVED object pointed to by ES:DI
;   contents of pointed to by DS:BX
;
    (l resolve.bco.un)
    (xor bh bh)        ; DS:BX untagged pointer to unresolved
    (mov iw (bx w)) (iw #x3000) ;change unresolved header to string header 
    (mov bx ax)
    (mov ib ah) #x20   ; DS:AX string tagged pointer to unresolved
    (int #x91)         ; string->symbol
    (mov ax bx)        ; check contents of symbol for Body Code Object
    (xor bh bh)
    (mov (bx w) cx)
    (cmp ib ch) #x28
    (je) (db resolve.bco)
    (mov ax bx)
    (call) (dw ps.con)
    (ss "ERROR: BCO-unresolved does not contain BCO: ")
    (mov bx ax)
    (int #x95)
    (mov ib dl) 220
    (int #x90)

    (l resolve.bco)
    (lds (bx w) ax)    ; DS:AX = contents of symbols
    (cld)              ; store symbol @ ES:DI
    (stos.w)
    (mov ds ax)
    (stos.w)
    (ret)

;-----------------------------------------------------------------------------
; print scheme string following call and continue after string 
; bashes ax  (note: Scheme string ends with 0)
;-----------------------------------------------------------------------------
    (l ps.con)
    (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)
    (ret)

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