conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/xli.asm

1371 lines
44 KiB
NASM
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; =====> XLI.ASM
; PC Scheme External Language Interface (XLI)
; (c) 1987,1988 by Texas Instruments Incorporated -- all rights reserved
; Author: Bob Beal
; History:
; rb 3/20/87 - original
; rb 2/ 2/88 - check XLI ID;
; added external-program error return
;
page 84,120
name PCSXLI
title PC Scheme External Language Interface
include scheme.equ
include xli.equ
include xli.ref
include xli.mac
subttl Group and Constant definitions
page
pgroup group prog
xgroup group progx
dgroup group data
subttl Data segment definitions
page
data segment para public 'DATA'
assume ds:dgroup
public load_table,work_area,active_exe ;??? for debugging
; Various tables
load_table dw N_EXE dup (0) ;PSP addresses (segment)
fb_table dd N_EXE dup (0) ;file block addresses (offset,segment)
pb_table dd N_EXE dup (0) ;parm block addresses (offset,segment)
state_table state N_EXE dup (<>) ;child's regs at point it called us
status_table label word ;records .EXE state (MSBy) and index (LSBy)
x = 0
rept N_EXE
dw x
x = x+1
endm
; Parameter block for EXEC function request
zero equ $ ;a constant zero
exec_pblock dw 0 ;env@ (use Scheme's)
dw zero,seg zero ;cmd line@ (don't care)
dd -1 ;FCB@'s (don't care)
dd -1
; Working storage (during a given call to the external routine)
align 16,data
work_area label word ;for dealing with PCS data values
exe_name label byte ;a filename from XLI's control file
db PAD_SIZE*N_ARGS dup (0) ;during xesc, non-strings go here
; other information required during an xesc call
work_info xesc_struc <> ;general info
swap_table swap_struc N_ARGS dup (<>) ;records swap state for each XCALL arg
exe_name1 dw offset exe_name ;pointer into exe_name to filename.extension
;(i.e. points past directory prefix)
bid_name dw 0 ;pointer into exe_name; used for bidding child
; the child currently active or being loaded
active_exe dw 0 ;(same format as status table)
; system .EXE information
sysflag db 0 ;0=user .EXE; 1=system .EXE
;look for system .EXE's only in pcs-sysdir
pcs_exe db 'newtrig.exe',0 ;PCS system .EXE files
pcs_exe_len equ $-pcs_exe
; State (context) information
; child's registers upon calling PCS
save_ax dw 0 ;actually, we ignore ax..di entries
save_bx dw 0
save_cx dw 0
save_dx dw 0
save_si dw 0
save_di dw 0
save_ds dw 0
save_es dw 0
save_ss dw 0
save_sp dw 0
save_bp dw 0
; our registers upon calling child
pcs_state state <> ;our state at point of calling child
; the SP just after the indirect call through "gate";
; error recovery is done with:
; mov SP,gate_SP
; ret
; which returns to the instruction following the indirect call
gate_SP dw 0
data ends
subttl Code segment: load_all
page
; external variables
extrn ctl_file:word,pcs_sysd:word
extrn regs:word
; external routines
extrn alloc_fl:near,int2long:near,long2int:near,alloc_bl:near
extrn getbase:near
progx segment para public 'PROGX'
assume cs:xgroup,ds:dgroup,es:dgroup,ss:dgroup
public %xli_gate
public load_all,load_exe,bid_child,c2p_handler,c2p_terminate
public xesc1,unload_all,find_open_spot,table_search
public do_floarg,do_fixarg,do_bigarg,do_strarg
public do_floval,do_intval,do_TFval,do_strval
public unload_exe,unload_all,update_swap_table
; This routine is called when PCS first comes up. External programs are
; loaded first (by this file) and then the Scheme heap is allocated (initmem).
; Any errors encountered are ignored. If we run of memory, initmem
; should see it too and notify smain to abort.
load_all proc
; First copy into exe_name buffer the pcs-sysdir name.
cld
push ds ;make ES=DS
pop es
mov di,pcs_sysd
mov cx,64 ;max length of pathname
mov al,0
repne scasb ;look for eos character (=0)
jcxz la_5 ;jump if none
dec di
la_5: mov cx,di
sub cx,pcs_sysd ;get length of pcs-sysdir
;without eos character
mov si,pcs_sysd
mov di,offset exe_name
rep movsb ;copy pcs-sysdir name (- eos)
;into exe_name buffer
mov al,'\' ;append \ onto pcs-sysdir name
dec di
cmp [di],al ;is '\' last char of pcs-sysdir?
je la_7 ;yes; write it over itself
inc di ;no; move past end, then write
la_7: stosb
mov exe_name1,di ;exe_name1 points to next
;open position in exe_name
; load system .EXE files
mov bx,ctl_file
cmp byte ptr [bx],'-' ;suppress loading system .EXE's?
jne sysload ;no
inc ctl_file ;yes, move past marker
jmp short userload ;and skip loading system .EXE's
sysload: mov si,offset pcs_exe ;get first system .EXE name
mov di,exe_name1
mov cx,pcs_exe_len
rep movsb ;copy into buffer after
;pcs-sysdir name
mov sysflag,1 ;set sysflag
call load_exe ;load the file
; open XLI control file
userload: mov sysflag,0
dos_fr FR_OPEN,,,ctl_file,ds
mov bx,ax ;put handle in BX
jnc next_file ;jump if no open errors
jmp close1 ;can't open file, exit
; read in next filename off the control file and append it to
; the pcs-sysdir name
next_file: mov dx,exe_name1 ;init buffer @
next_char: dos_fr FR_READ,bx,1,dx,ds ;read 1 character
jnc la_10 ;jump if no error, else
;suddenly can't read control
;file, close it and exit
close: dos_fr FR_CLOSE,bx
close1: ret
la_10: cmp ax,0 ;at eof?
jz close ;yes, jump
; we've read a character
mov si,dx
cmp byte ptr [si],' ' ;blank?
je next_char ;yes, skip it
cmp byte ptr [si],0Dh ;carriage return?
je got_file ;yes, jump
cmp byte ptr [si],' ' ;control char?
jl next_char ;yes, skip it
inc dx ;point to next buffer position
jmp next_char
; we've read a complete filename, go load it
got_file: mov byte ptr [si],0 ;form ASCIIZ string
call load_exe ;bid it
jnc next_file ;jump if no errors
cmp ax,0 ;any open slots?
je close ;no, jump
cmp ax,2 ;file found?
je next_file ;no, jump
cmp ax,8 ;ran out of memory?
jne next_file ;no, jump; ignorable error
jmp close ;yes
load_all endp
; Given exe_name, this routine loads the child into any available open slot.
; On exit:
; success: carry clear
; failure: carry set
; AX = 0 : no open slots
; AX <> 0 : EXEC failure code
load_exe proc
push ax
push bx
; if we succeed, state=EXE_NONE
call find_open_spot ;this sets active_exe
mov ax,0
jc le_exit ;no open slots
; set state=EXE_TSR for time between EXEC and TSR
load_index itself
mov bh,EXE_TSR
mov active_exe,bx
cmp sysflag,1 ;loading system .EXE?
je le_5 ;yes, look only in pcs-sysdir
mov ax,exe_name1 ;try current directory first
mov bid_name,ax
call bid_child
jnc le_10 ;bid succeeded, jump
le_5: mov ax,offset exe_name ;try again with pcs-sysdir prefix
mov bid_name,ax
call bid_child
jc le_exit ;bid failed, jump
; child is ready, set state=EXE_NORM
le_10: load_index itself
mov bh,EXE_NORM
mov ax,bx
load_index status_table
mov status_table[bx],ax
clc
le_exit: pop bx
pop ax
ret
load_exe endp
;le_err: cmp ax,0
; je le_exit ;it's not up, just exit
; cmp ax,8
; jne fail1
; mov ax,XLI_ERR_NO_MEMORY
; jmp xli_err_exit
;fail1: cmp ax,2
; jne fail2
; mov ax,XLI_ERR_NO_SUCH_FILE
; jmp xli_err_exit
;fail2: mov ax,XLI_ERR_BAD_EXEC
; jmp xli_err_exit
;le_err1: cmp xli_up,0 ;can't do usual error handling if
; ;system's not up yet
; je le_exit ;it's not up, just exit
; mov ax,XLI_ERR_NO_AVAILABLE_SLOTS
; jmp xli_err_exit
; Given a filename in "exe_name", initialize it under XLI.
; The EXEC status is returned.
; Assume AX..DI,ES are destroyed; DS,SS,SP,BP are preserved.
bid_child proc
push ds ;save parent's state
push bp
save_parent
mov cs:stk_seg,ss
mov cs:stk_offset,sp
dos_fr FR_EXEC,<offset exec_pblock>,,bid_name,ds,ds
; The following are external entry points accessible by the child.
biddbg: jmp tsr_done ; --- THE BIG 4 --- (not for child's use)
jmp c2p_handler ; --- THE BIG 4 --- for XCALL's
jmp c2p_terminate ; --- THE BIG 4 --- for child termination
tsr_done: cli
mov ss,cs:stk_seg
mov sp,cs:stk_offset
sti
pop bp
pop ds
ret
stk_seg dw 0 ;bootstrap parent's state after EXEC
stk_offset dw 0 ;from here
bid_child endp
subttl Code segment: Child->parent handler
page
; On entry to this routine PCS is executing in the child's environment.
; The relevant stack entries at this point are:
; SS:SP (top) -> IP ;child's far return address
; CS
; length ;child's length; for TSR
; PSP@ ;child's PSP@
; //// ;(the rest of the stack)
c2p_handler label near
resume_parent
load_index itself
cmp bh,EXE_NORM ;normal call from child?
jne c2_10 ;no, jump; could be TSR
jmp normal ;yes, jump--rejoin xesc
c2_err: mov ax,XLI_ERR_SYNC_ERR
jmp xli_err_exit
c2_10: cmp bh,EXE_TSR ;first call from child? (before TSR)
jne c2_err ;no, jump
load_index state_table
lea bx,state_table[bx]
mov es,[bx].st_ss
mov bp,[bx].st_sp ;ES:BP is child's SS:SP
mov ax,es:[bp].cs_psp ;get child's PSP off its stack
load_index load_table
mov load_table[bx],ax ;save it
push ds ;-----> DS set to child's PSP
mov ds,ax
mov ax,ds:fb_ptr ;get file block @
mov cx,ds:fb_ptr+2
mov dx,ds:env_ptr ;get env block @ (seg addr)
pop ds ;<-----
load_index fb_table
mov word ptr fb_table[bx],ax ;save it
mov word ptr fb_table+2[bx],cx
push es ;tempsave child's SS:SP on stack
push bp
mov bp,ax
mov es,cx ;ES:BP is file block @
mov ax,es:[bp].fb_pb
mov cx,es:[bp].fb_pb+2 ;get parm block @
load_index pb_table
mov word ptr pb_table[bx],ax ;save it
mov word ptr pb_table+2[bx],cx
test word ptr es:[bp].fb_flags,FB_KEEPENV
;keep child's env block?
jnz c2_20 ;yes, jump
dos_fr FR_RELMEM,,,,,dx ;no, release it for child
c2_20: pop bp
pop es
mov dx,es:[bp].cs_len ;get child's length off its stack
; we're ready to TSR the child
dos_fr FR_TSR,,,dx
; we don't drop through -----------------------------------------
subttl Code segment: Child termination
page
; After the child has performed its wrapup, it calls this routine
; to deallocate its memory and make its spot in the load table available.
c2p_terminate label near
mov ax,dgroup ;we needn't save child's context now
mov ds,ax
restore_parent
load_index load_table ;release the child
dos_fr FR_RELMEM,,,,,load_table[bx]
jc ct_err
load_index itself ;mark its spot as available
xor bh,bh
mov ax,bx
load_index status_table
mov status_table[bx],ax
jmp normal1 ;rejoin unload_exe
ct_err: mov ax,XLI_ERR_RELMEM
jmp xli_err_exit
subttl Code segment: xesc
page
; This is the handler for the "%xesc" opcode.
;
; On entry:
; AX = length of xesc call (= inst length - 1)
; ES:SI = pointer to bytecode containing the (reg# x 4) of
; the %xesc name string
; On exit:
; normal: the VM reg that contained the name string on entry
; will contain the page:offset of the return value;
; there may be side effects in strings that were arguments to %xesc
; BX = 0 (no errors)
; error: BX = error#
xesc proc near
xesc1: cld
sub ax,2 ;adjust to #args *to %xesc*
;(len, name are not args)
mov work_info.xs_nargs,ax ;save actual #args
; Get from register# (actually, reg x 4) to lookup string.
lods byte ptr es:[si]
mov bl,al
xor bh,bh ;BX is reg# x 4 of name string
mov work_info.xs_pc,si ;save bytecode@
mov work_info.xs_pc+2,es
mov work_info.xs_rvreg,bx ;save reg# x 4;
;return value goes here
lea bx,regs[bx] ;reg# x 4 -> VM reg @
mov si,[bx].C_page
cmp ptype[si],STRTYPE*2 ;is it a string?
je xesc_5 ;yes, jump
cmp ptype[si],SYMTYPE*2 ;is it a symbol?
je xesc_3 ;yes, jump
mov ax,XLI_ERR_NAME_BAD_TYPE ;error: name not string, symbol
jmp xesc_err_exit
xesc_3: %LoadPage es,si ;page# in SI -> para# in ES
mov bp,[bx].C_disp ;ES:BP is symbol object @
mov ax,es:[bp].sym_len ;get symbol object length
sub ax,sym_ovhd ;subtract symbol's overhead
add bp,sym_ovhd ;skip past overhead
jmp short xesc_9
xesc_5: %LoadPage es,si ;page# in SI -> para# in ES
mov bp,[bx].C_disp ;ES:BP is string object @
mov ax,es:[bp].str_len ;get string object length
cmp ax,0 ;is it positive?
jge xesc_8 ;yes, jump; normal string
add ax,str_ovhd*2 ;no, assume short string
;rather than really long string
;and make positive
xesc_8: sub ax,str_ovhd ;subtract string's overhead
add bp,str_ovhd ;skip past overhead
xesc_9: mov work_area.srch_slen,ax ;save length of string data
mov work_area.srch_sptr,bp ;save address of string data
mov work_area.srch_sptr+2,es
; Look for a match.
call table_search ;is there a match?
;(sets active_exe if so)
jnc xesc_10 ;yes, jump
mov bx,work_info.xs_rvreg ;get the name
lea bx,regs[bx]
mov ax,XLI_ERR_NO_SUCH_NAME ;error: no such name loaded
jmp xesc_ext_err_exit ;use alternate error point
;so name gets printed with
;error message
xesc_10: mov dx,ax ;tempsave selector
; There was a match.
; Collect the info we'll need to guide us thru xesc call.
load_index fb_table
mov bp,word ptr fb_table[bx]
mov es,word ptr fb_table+2[bx] ;ES:BP is file block @
mov ax,es:[bp].fb_id ;XLI ID
cmp ax,XLI_ID
je xesc_15
mov ax,XLI_ERR_BAD_VERSION
jmp xesc_err_exit
xesc_15: mov ax,es:[bp].fb_flags ;flags
mov work_info.xs_flags,ax
load_index pb_table
mov bp,word ptr pb_table[bx]
mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @
mov work_info.xs_pb_segment,es ;parm block's segment address
lea ax,es:[bp].pb_rv
mov work_info.xs_rvptr,ax
mov work_info.xs_rvptr+2,es ;return value's address
mov es:[bp].pb_rv,0 ;zero out return value
mov es:[bp].pb_rv+2,0
mov es:[bp].pb_rv+4,0
mov es:[bp].pb_rv+6,0
mov es:[bp].pb_rvtype,SWI_TF ;set ret value's type to T/F
mov es:[bp].pb_ss,0 ;zero out special service
add ax,8
mov work_info.xs_args,ax ;first arg's address
mov work_info.xs_args+2,es
mov work_info.xs_local,offset work_area ;work area address
mov work_info.xs_local+2,seg work_area
; Begin initializing child's parameter block.
mov es:[bp].pb_select,dx ;store selector into parm block
mov work_info.xs_select,dx
; Move the xesc arguments to their places for the xesc call.
; mov cx,work_info.xs_nargs ;CX is #args
;xesc_20: cmp cx,0 ;any left?
; jcxz xesc_50 ;no, jump
mov cx,0 ;CX is current arg#
xesc_20: cmp cx,work_info.xs_nargs ;any left?
je xesc_50 ;no, jump
push cx ;tempsave current arg#
mov si,work_info.xs_pc
mov es,work_info.xs_pc+2 ;ES:SI is bytecode@
lods byte ptr es:[si]
mov work_info.xs_pc,si ;save next bytecode @
mov bl,al
xor bh,bh ;BX is reg# x 4
; Put the reg# and current arg @ into swap table
mov ax,bx
xchg bx,cx ;BX is current arg#
shl bx,1
shl bx,1 ;make index into swap table
mov word ptr swap_table[bx].sw_reg,ax ;save VM reg# x 4
mov ax,work_info.xs_args
mov word ptr swap_table[bx].sw_offset,ax ;save arg@
mov bx,cx ;restore reg# x 4
; Dispatch on argument type
lea bx,regs[bx] ;BX is VM reg @
mov di,[bx].C_page ;get its page#
mov di,ptype[di] ;and its type
; push cx
call cs:word ptr do_arg[di] ;handle one type of object
add work_info.xs_local,PAD_SIZE ;incr XLI-local ptr
;(maintain alignment)
pop cx ;restore current arg#
; dec cx
inc cx
jmp xesc_20
; Everything's ready. Call the child.
xesc_50: call update_swap_table
call_child 1
; We're back with a return value--unless it's a special service call.
normal: cld
load_index pb_table
mov bp,word ptr pb_table[bx]
mov es,word ptr pb_table+2[bx] ;ES:BP is parm block @
cmp es:[bp].pb_ss,0 ;any special services?
je xesc_60 ;no, jump
call ssr ;do special service and
jmp xesc_50 ;return immediately back
;across the interface
; Now we're really back with the return value
xesc_60: mov di,es:[bp].pb_rvtype
mov work_area.xs_rvtype,di ;return value's type
cmp di,RV_ERR ;external-pgm error return?
jne xesc_65 ;no, jump
mov bp,work_info.xs_rvptr
mov es,work_info.xs_rvptr+2 ;ES:BP points to return value
;(external-pgm error message)
call cs:word ptr do_val[SWI_STR*2] ;build string
mov bx,work_info.xs_rvreg
lea bx,regs[bx] ;BX=addr of reg with error string
mov ax,XLI_ERR_EXTERNAL_ERROR ;AX=XLI error code
jmp short xesc_ext_err_exit
xesc_65: cmp di,N_RV ;return value out of range?
jb xesc_70 ;no, jump
mov ax,XLI_ERR_VALUE_BAD_TYPE
jmp xesc_err_exit
xesc_70: shl di,1
mov bp,work_info.xs_rvptr
mov es,work_info.xs_rvptr+2 ;ES:BP point to return value
call cs:word ptr do_val[di] ;handle one type of return value
lea bx,nil_reg ;CX says "nil irritant"
mov ax,0 ;BX=0 says no errors
ret
; This file's error exit processing. Reset the stack so that we return
; immediately to the gate. BX should be set with an error code before
; jumping here.
xli_err_exit:
xesc_err_exit: ;AX contains error#
lea bx,nil_reg ;BX is "nil irritant"
; Another exit label. This allows both AX (XLI error code) and BX
; (the address of the VM register with the "irritant") to be set beforehand.
xli_ext_err_exit:
xesc_ext_err_exit:
mov sp,gate_sp ;return to gate
ret
;; Jump tables
; indexed by argument type (standard PCS type tag)
do_arg dw do_lstarg ;0=list (#f only)
dw do_fixarg ;1=fixnum
dw do_floarg ;2=flonum
dw do_bigarg ;3=bignum
dw do_symarg ;4=symbol (#t only)
dw do_strarg ;5=string
dw do_errarg ;6 the rest we don't care about
dw do_errarg ;7
dw do_errarg ;8
dw do_errarg ;9
dw do_errarg ;10
dw do_errarg ;11
dw do_errarg ;12
dw do_errarg ;13
dw do_errarg ;14
dw do_errarg ;15
; indexed by value type (SW-INT return types)
do_val dw do_intval ;0=integer
dw do_TFval ;1=true/false
dw do_strval ;2=string
dw do_floval ;3=flonum
xesc endp
subttl Code segment: Copy arguments into place for child
page
; On entry to all the argument handler routines:
; BX = pointer to VM reg with page:offset of Scheme object
do_floarg proc near
mov si,[bx].C_page ;get object's page#
%LoadPage es,si ;swap it in
mov si,[bx].C_disp ;ES:SI is Scheme object @
test work_info.xs_flags,FB_NEAR ;near flag on?
jz do_flo10 ;no, jump
; Set up destination address
; near
mov cx,work_info.xs_args ;dest is in child
mov dx,work_info.xs_args+2
mov work_info.xs_dest,cx
mov work_info.xs_dest+2,dx
jmp short do_flo20
; far
do_flo10: mov cx,work_info.xs_local ;dest is in XLI-local area
mov dx,work_info.xs_local+2
mov work_info.xs_dest,cx
mov work_info.xs_dest+2,dx
; Copy the flonum data
do_flo20: inc si ;incr past tag
mov di,work_info.xs_dest
push ds ;tempsave DS around copy
push es
mov es,work_info.xs_dest+2 ;ES:DI points to dest
pop ds ;DS:SI is Scheme object @
mov cx,8
rep movsb
pop ds ;restore our DS
test work_info.xs_flags,FB_NEAR ;near flag on?
jz do_flo30 ;no, jump
; Copy pointer to data
; near (no copy needed--data is in child's space)
mov cx,8 ;incr arg@ past copied data
jmp short do_flo32
; far (pointer in child points to data in XLI space)
do_flo30: sub di,8 ;back up dest @
mov cx,di
mov dx,es
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP points to arg position
mov es:[bp],cx
mov es:[bp]+2,dx ;copy pointer there
; Increment arg pointer by an appropriate amount.
mov cx,4 ;incr arg@ past copied ptr
do_flo32: test work_info.xs_flags,FB_PAD ;pad flag on?
jz do_flo35 ;no, skip
mov cx,PAD_SIZE
do_flo35: add work_info.xs_args,cx
do_flo40: ret
do_floarg endp
do_bigarg proc near
mov si,[bx].C_page ;get object's page#
%LoadPage es,si ;swap it in
mov si,[bx].C_disp ;ES:SI is Scheme object @
; Stage the conversion to longint in XLI space.
mov bp,sp
push bx ;push VM reg@
push work_info.xs_local ;push local buffer@
mov work_info.C_fn,offset pgroup:int2long
call far ptr far_C
mov sp,bp
cmp ax,0 ;did bignum convert OK?
je do_big5 ;yes, jump
mov ax,XLI_ERR_BIG_TO_32_BITS ;error: bignum too big
;to become longint
jmp xesc_err_exit
do_big5: test work_info.xs_flags,FB_NEAR ;near flag on?
jz do_big20 ;no, jump
; near (copy longint to child's space)
mov bp,work_info.xs_local
mov es,work_info.xs_local+2 ;ES:BP points to XLI-local longint
mov ax,es:[bp] ;move longint to regs
mov dx,es:[bp]+2
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP points to dest
mov es:[bp],ax ;copy LSBy to child
mov cx,2
test work_info.xs_flags,FB_INT ;is 16-bit integer flag on?
jz do_big15 ;no, jump
; is the longint small enough for an int?
cmp dx,0 ;DX should be either
;all 0's or all 1's
je do_big32 ;we can safely truncate
xor dx,0FFFFh ;complement DX
cmp dx,0 ;try again
je do_big32 ;we can safely truncate
mov ax,XLI_ERR_BIG_TO_16_BITS ;error: bignum too big
;to become int
jmp xesc_err_exit
do_big15: mov es:[bp]+2,dx ;copy MSBy to child
mov cx,4
jmp short do_big32
; far (pointer in child points to data in XLI-local space)
do_big20: mov ax,work_info.xs_local ;move ptr to longint to regs
mov dx,work_info.xs_local+2
; Copy either the longint or a pointer to it.
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP points to dest
mov es:[bp],ax ;copy to child
mov es:[bp]+2,dx
mov cx,4 ;incr arg@ past longint
;or pointer to longint
; Increment arg pointer by an appropriate amount.
do_big32: test work_info.xs_flags,FB_PAD ;pad flag on?
jz do_big35 ;no, skip
mov cx,PAD_SIZE
do_big35: add work_info.xs_args,cx
do_big40: ret
do_bigarg endp
do_fixarg proc near
; Stage the conversion to int in XLI space
mov ax,[bx].C_disp ;get the fixnum data
shl ax,1 ;deal with sign bit
sar ax,1 ;AX is 16-bit signed int
; True and false are treated as the numbers 1 and 0, respectively.
; Boolean-argument processing merges into integer processing at this point.
do_log: cwd ;DX:AX is 32-bit signed int
; Copy the int data to the proper place
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP points to dest
test work_info.xs_flags,FB_NEAR ;near flag on?
jz do_fix20 ;no, jump
; near (copy int to child's space)
mov es:[bp],ax ;copy int to child
mov cx,2 ;incr arg@ past int
test work_info.xs_flags,FB_INT ;is 16-bit integer flag on?
jnz do_fix30 ;yes, jump
mov es:[bp]+2,dx ;no, copy high order 16 bits
mov cx,4 ;incr arg@ past longint
jmp short do_fix30
; far (pointer in child points to data in XLI-local space)
do_fix20: mov bx,work_info.xs_local
mov [bx],ax
mov [bx]+2,dx
mov ax,work_info.xs_local ;move far ptr to int
;or longint to child
mov cx,work_info.xs_local+2
mov es:[bp],ax
mov es:[bp]+2,cx
mov cx,4 ;incr arg@ past ptr to int
; Increment arg pointer by an appropriate amount
do_fix30: test work_info.xs_flags,FB_PAD ;pad flag on?
jz do_fix35 ;no, skip
mov cx,PAD_SIZE
do_fix35: add work_info.xs_args,cx
do_fix40: ret
do_fixarg endp
do_lstarg proc near ;looking for false only
cmp [bx].C_page,NIL_PAGE*2
jne do_xxerr
mov ax,0
jmp do_log
do_lstarg endp
do_xxerr: jmp do_errarg ;conditional jumps
;are too short
do_symarg proc near ;looking for true only
cmp [bx].C_page,T_PAGE*2
jne do_xxerr
cmp [bx].C_disp,T_DISP
jne do_xxerr
mov ax,1
jmp do_log
do_symarg endp
do_strarg proc near
mov si,[bx].C_page
%LoadPage es,si ;load string into memory
mov si,[bx].C_disp ;ES:SI is Scheme object @
test work_info.xs_flags,FB_NEAR ;near flag on?
jz do_str10 ;no, jump
; near (can't copy string because we don't have its address--
; put nil address into parm block)
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP is arg @
mov word ptr es:[bp],0
mov cx,2
jmp short do_str60
; far (we can copy the string's address, but need to check
; on earlier strings' swap status)
do_str10:
mov ax,si
add ax,STR_OVHD
mov dx,es ;DX:AX is string data @
mov bp,work_info.xs_args
mov es,work_info.xs_args+2 ;ES:BP is arg @
mov es:[bp],ax
mov es:[bp]+2,dx
mov cx,4
; Increment arg pointer by an appropriate amount
do_str60: test work_info.xs_flags,FB_PAD ;padding on?
jz do_str65 ;no, jump
mov cx,PAD_SIZE
do_str65: add work_info.xs_args,cx
ret
do_strarg endp
do_errarg proc near
mov ax,XLI_ERR_ARGN_BAD_TYPE
jmp xesc_err_exit
do_errarg endp
subttl Code segment: Copy return value back into Scheme
page
; On entry to all the value handler routines:
; ES:BP = pointer to return value
do_floval proc near
test work_info.xs_flags,FB_NEAR ;is near flag on?
jnz do_flv10 ;yes, jump
; far
mov ax,es:[bp] ;get ptr to number
mov dx,es:[bp]+2
mov bp,ax
mov es,dx ;ES:BP points to number
; near
do_flv10: mov dx,es:[bp]+6 ;get double in registers
mov cx,es:[bp]+4
mov bx,es:[bp]+2
mov ax,es:[bp]
mov bp,sp ;get BP set for C call
push dx ;push double
push cx
push bx
push ax
mov bx,work_info.xs_rvreg ;push return value VM reg@
lea bx,regs[bx]
; lea bx,reg1 ;temporary
push bx
mov work_info.C_fn,offset pgroup:alloc_fl
call far ptr far_C ;C double -> PCS flonum
mov sp,bp ;pop C args
ret
do_floval endp
do_TFval proc near
mov cx,0
mov ax,es:[bp] ;get value
or ax,es:[bp]+2 ;all bytes must = 0 to be nil
or ax,es:[bp]+4
or ax,es:[bp]+6
jz do_TF10 ;yes (false object)
mov ax,T_DISP ;no (true object)
mov cx,T_PAGE*2
do_TF10:
mov bx,work_info.xs_rvreg ;push return value VM reg@
lea bx,regs[bx]
; lea bx,reg1 ;temporary
mov [bx].C_disp,ax
mov [bx].C_page,cx
ret
do_TFval endp
do_intval proc near
test work_info.xs_flags,FB_NEAR ;near flag on?
jnz do_int10 ;yes, jump
; far
mov ax,es:[bp] ;get ptr to number
mov dx,es:[bp]+2
mov bp,ax
mov es,dx ;ES:BP points to number
; near
do_int10: mov ax,es:[bp] ;get number
mov dx,es:[bp]+2
test work_info.xs_flags,FB_INT ;16-bit integer flag on?
jz do_int20 ;no, jump
cwd ;yes, propagate sign
do_int20: mov bp,sp ;get BP set for C call
push dx ;push longint
push ax
mov bx,work_info.xs_rvreg ;push return value VM reg@
lea bx,regs[bx]
; lea bx,reg1 ;temporary
push bx
mov work_info.C_fn,offset pgroup:long2int
call far ptr far_C ;C longint -> PCS integer
;(bignum or fixnum)
mov sp,bp ;pop C args
ret
do_intval endp
do_strval proc near
; allocate the space for the return value string object
mov di,2 ;DI=offset of length in
;return value field (near)
test work_info.xs_flags,FB_NEAR ;is near flag on?
jnz do_stv10 ;yes, jump
mov di,4 ;different offset for far
do_stv10: mov cx,es:[bp][di] ;get string's length
mov bx,16380 ;BX is max string length
cmp cx,bx ;is CX short enough?
jbe do_stv15 ;yes, jump
mov cx,bx ;no, truncate at max
do_stv15: push cx ;tempsave length
mov bp,sp ;get BP set for C call
push cx ;push length
mov ax,STRTYPE
push ax ;push type
mov bx,work_info.xs_rvreg
lea bx,regs[bx]
push bx ;push return value VM reg @
mov work_info.C_fn,offset pgroup:alloc_bl
call far ptr far_C ;allocate string object;
;"alloc_block" takes care
;of overhead matters
mov sp,bp ;pop C args
pop cx ;restore length
mov bx,work_info.xs_rvreg
lea bx,regs[bx] ;BX is return value VM reg @
mov di,[bx].C_disp
mov es,[bx].C_page
%LoadPage es,es ;ES:DI is dest object @
add di,3 ;skip past string's overhead
; copy string data into string object
push es ;tempsave ES
mov si,work_info.xs_rvptr
mov es,work_info.xs_rvptr+2 ;ES:SI points to return value
;field in parameter block
mov ax,es:[si]
mov dx,work_info.xs_pb_segment ;DX:AX is src string @ (near)
test work_info.xs_flags,FB_NEAR ;is near flag on?
jnz do_stv50 ;yes, jump
mov dx,es:[si]+2 ;DX:AX is src string @ (far)
do_stv50: pop es ;restore ES
push ds ;tempsave our DS
mov si,ax ;ES:DI is dest string @
mov ds,dx ;DS:SI is src string @
rep movsb ;copy string
pop ds ;restore our DS
ret
do_strval endp
do_errval proc near
mov ax,XLI_ERR_VALUE_BAD_TYPE
jmp xesc_err_exit
do_errval endp
subttl Code segment: Special Services
page
; On entry, ES:BP is parm block pointer.
ssr proc near
mov bx,es:[bp].pb_ss ;get dispatch number
cmp bx,SS_SWAP
je ss1
jne ss_exit ;note we don't fall thru
ss_normal_exit:
load_index pb_table
mov bp,word ptr pb_table[bx]
mov es,word ptr pb_table[bx]+2
mov es:[bp].pb_ss,0 ;clear ss field for normal exit
ss_exit: ret
; the conditional jumps can't jump far enough, hence this table
ss1: jmp ssr_swap
; "Swap" special service
ssr_swap: mov bx,es:[bp].pb_ss_args ;get arg#
mov cx,es:[bp].pb_ss_args+2 ;get dest. length
shl bx,1
shl bx,1
push bx ;tempsave index into swap table
test work_info.xs_flags,FB_NEAR ;is near flag on?
jnz ss_10 ;yes, jump
;
; Far -------------------
;
; ss_args+0: swap table index corr. to arg# (already in BX)
;
; ss returns:
; in ss_args+0: true length of string
; in pb args: far @ to string
;
mov bx,word ptr swap_table[bx].sw_reg ;BX is reg# x 4
lea bx,regs[bx] ;BX is reg@
mov si,[bx].C_page ;get object's page#
%LoadPage es,si ;load object into memory
mov si,[bx].C_disp ;ES:SI is string object @
inc si ;skip over tag
mov ax,es:[si] ;get string's length
inc si ;skip over length
inc si
cmp ax,0 ;a short string?
jge ss_5 ;no, jump
add ax,str_ovhd*2 ;yes
ss_5: sub ax,str_ovhd ;subtract off overhead
mov di,es ;DI:SI is string data @
mov es,work_info.xs_pb_segment ;ES:BP is parameter block @
mov es:[bp].pb_ss_args,ax ;put string length in ss_args
pop bx ;restore swap table index
mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's
;location in parameter block
mov es:[bp],si ;put far @ in parm block
mov es:[bp]+2,di
jmp ss_normal_exit
;
; Near -------------------
;
; ss_args+0: swap table index corr. to arg# (already in BX)
; +2: length (already in CX)
; +4: near ptr
;
; ss returns:
; in ss_args+0: length used in copying
; in pb args: near @ to string
;
ss_10: mov ax,es:[bp].pb_ss_args+4 ;get dest @
mov work_info.xs_dest,ax
mov ax,work_info.xs_pb_segment
mov work_info.xs_dest+2,ax
mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 corr. to arg
lea bx,regs[bx] ;BX is reg@
mov si,[bx].C_page
%LoadPage es,si ;load object into memory
mov si,[bx].C_disp ;ES:SI is string object @
inc si ;skip over tag
mov ax,es:[si] ;get string's length
inc si ;skip over length
inc si
cmp ax,0 ;a short string?
jge ss_15 ;no, jump
add ax,str_ovhd*2 ;yes
ss_15: sub ax,str_ovhd ;subtract off overhead
cmp ax,cx ;string len >= buffer len?
jae ss_20 ;yes, jump
mov cx,ax ;CX is #chars to copy
ss_20: push ds ;tempsave our DS
push es
mov di,work_info.xs_dest
mov es,work_info.xs_dest+2 ;ES:DI is dest @
pop ds ;DS:SI is src @
rep movsb ;copy string
pop ds ;restore our DS
load_index pb_table
mov bp,word ptr pb_table[bx]
mov es,word ptr pb_table[bx]+2 ;ES:BP is parm block @
mov es:[bp].pb_ss_args,ax ;put #chars copied in ss_args
pop bx ;restore swap table index
mov bp,word ptr swap_table[bx].sw_offset ;ES:BP points to this arg's
;location in parameter block
mov ax,work_info.xs_dest
mov es:[bp],ax ;put near @ in parm block
jmp ss_normal_exit
ssr endp
subttl Code segment: update_swap_table
page
update_swap_table proc near
; for small models, PCS may indeed be swapping, but we don't care, as data
; is copied to the external program on its first reference and
; remains always available to the program since the pointer in the parm block
; points into the program's own space, not PCS's
test work_info.xs_flags,FB_NEAR ;is near flag on?
jnz ust_exit ;yes, exit
mov cx,0 ;CX is argument counter
ust_10: cmp cx,work_info.xs_nargs
jge ust_exit
mov bx,cx
shl bx,1
shl bx,1 ;BX is swap table index
push bx ;tempsave index
mov bx,word ptr swap_table[bx].sw_reg ;get reg# x 4 of argument
lea bx,regs[bx] ;BX is reg@
mov di,[bx].C_page ;get object's page#
mov di,ptype[di] ;then its type
cmp di,STRTYPE*2 ;is it a string?
je ust_40 ;yes, jump
pop bx ;no, discard index
ust_30: inc cx ;incr to next argument
jmp ust_10
ust_40: mov ax,[bx].C_page ;get page#
mov bp,sp ;set up BP for calling C
push ax ;push page#
mov work_info.C_fn,offset pgroup:getbase ;this routine's not in
;C but does use its calling
;conventions
call far ptr far_C
mov sp,bp ;pop C args
pop bx ;restore swap table index
; If carry is clear, the argument is in memory already.
; The address in the parm block should be OK since an object
; coming into memory has its address updated at the time of the
; swap. Swapping does not cause a GC, so GC's shouldn't relocate
; an address. That leaves zeroing the addresses of objects
; that were swapped out.
jnc ust_30 ;object's in memory, jump
; Carry set means object is swapped out. Zero the argument's
; pointer in the parm block.
mov bp,word ptr swap_table[bx].sw_offset
mov es,work_info.xs_pb_segment ;ES:BP points to this arg's
;location in the parm block
mov word ptr es:[bp],0 ;zero offset part of pointer
mov word ptr es:[bp]+2,0 ;zero segment part of pointer
jmp ust_30
;
ust_exit: ret
update_swap_table endp
subttl Code segment: unload_exe
page
; Given active_exe, release it from memory and make its spot available again.
unload_exe proc near
load_index state_table
mov es,word ptr state_table[bx].st_ss
mov bp,word ptr state_table[bx].st_sp ;ES:BP is child's SS:SP
mov es:[bp].cs_psp,0 ;set PSP@ to 0, our signal
;to child to wrap things up
call_child 2 ;call child one last time
normal1: ret
unload_exe endp
subttl Code segment: unload_all
page
; This routine is called during PCS termination. It notifies each
; child to do any wrapup, then the child will do its final call to us,
; where we release it.
unload_all proc near
mov active_exe,0
ua_10: cmp active_exe,N_EXE ;looked at all entries?
je ua_exit ;yes, jump
load_index status_table
mov bx,status_table[bx]
cmp bh,EXE_NONE ;is slot empty?
jne ua_20 ;no, jump
ua_15: inc active_exe ;incr to next entry
jmp ua_10
ua_20: call unload_exe ;deallocate entry
jmp ua_15
ua_exit: ret
unload_all endp
subttl Code segment: table_search
page
; We need to find a matching string. From it we'll know
; which child has it and what value it maps to.
; On entrance:
; work_area.srch_sptr is the seg:offset of the Scheme string (data proper)
; work_area.slen is the string's length
; On exit:
; if success: AX = selector value
; active_exe = xxnnh, where n is the child
; carry clear
; if fail: carry set
; AX..DI,ES,BP are destroyed.
table_search proc near
cld ;to be safe
mov work_area.srch_exe,0
ts_10: cmp work_area.srch_exe,N_EXE ;looked at them all?
jne ts_15 ;no, jump
; No child had a match. Return with carry set.
stc
jmp ts_exit
ts_15: mov bx,work_area.srch_exe
mov active_exe,bx
load_index status_table
mov ax,status_table[bx]
cmp ah,0 ;is this an open spot?
jne ts_20 ;no, jump
ts_next: inc work_area.srch_exe ;increment to next spot
jmp short ts_10
; We have a loaded file. Figure out where its lookup table is.
ts_20: load_index fb_table
mov bp,word ptr fb_table[bx]
mov es,word ptr fb_table+2[bx] ;ES:BP is file block @
mov ax,es:[bp].fb_lut
mov dx,es:[bp].fb_lut+2
mov di,ax
mov es,dx ;ES:DI is lookup table @
mov ah,0 ;AH will be selector value
mov al,'/' ;AL is name delimiter
; Find the next name in the lookup table.
ts_30: cmp byte ptr es:[di],al ;looking at last delimiter?
je ts_next ;yes, jump
mov si,di ;SI points at current name
mov cx,0FFh
repne scasb ;look for name delimiter
jcxz ts_next ;jump, should've found it by now
mov dx,di ;DI, DX point at next name
mov cx,di
sub cx,si
dec cx ;CX is length of name in table
cmp work_area.srch_slen,cx ;are lengths equal?
jne ts_40 ;no, jump
; We matched lengths. See if the strings themselves match.
mov di,si ;get current name @ back in DI
push ds ;tempsave our DS
mov si,work_area.srch_sptr
mov ds,work_area.srch_sptr+2 ;DS:SI is Scheme string @
repe cmpsb
pop ds ;restore our DS
je ts_match ;jump if match
; The current table name didn't match.
ts_40: inc ah ;increment selector value
mov di,dx ;restore next name @ to DI
jmp ts_30
; We matched. Active_exe has child#, replace it with the corr. status value.
; Calculate the selector value (0-based) of the name and return it in AX.
; Clear carry.
ts_match: mov al,ah
xor ah,ah
load_index status_table
mov bx,status_table[bx]
mov active_exe,bx
clc
ts_exit: ret
table_search endp
subttl Code segment: find_open_spot
page
; Find an open spot in the load_table. Clear carry and set the LSBy of
; active_exe with the child# if we succeeded, else set carry.
find_open_spot proc near
push bx
push cx
mov cx,N_EXE
mov bx,0
fi_loop: cmp byte ptr status_table[bx]+1,EXE_NONE
je fi_found
inc bx
inc bx
dec cx
cmp cx,0
jne fi_loop
stc ;set carry if no available entries
jmp short fi_exit
fi_found: mov bx,N_EXE
sub bx,cx
mov active_exe,bx
clc ;an open entry: clear carry, set active_exe
fi_exit: pop cx
pop bx
ret
find_open_spot endp
subttl Far/near linkage to XLI
page
; Near linkage
; All other routines in this file are accessed through this one.
; On entry, BX contains an index into a jump table of routines to execute.
%xli_gate proc far
shl bx,1 ;get index on word boundary
mov gate_sp,sp
sub gate_sp,2
; We adjusted the SP for the return address which the call in the next
; instruction will put on the stack.
; Error recovery by nested routines is done by restoring this SP value and
; then returning, which will bring them back to just after the call.
call cs:gate[bx]
ret
; jump table
gate dw load_all,xesc,unload_all
%xli_gate endp
subttl Debugging XLI from PCS
page
; If PCS is run under DEBUG, executing (%xli-debug <0 or 1>) will
; execute the following code, which either installs an INT 3 (=1) or NOPs (=0).
; When INT 3 is executed, DEBUG is called. This provides a way for
; writers of external routines to get a hook at execution time into
; their code for debugging. Also, the value returned in AX is the PROGX offset
; of the jumps accessed from the external program.
; Registers destroyed: AX
%xlidbg proc far
or ax,ax
jz dbgoff
mov al,cs:dbgint ;install INT 3 instruction
mov xlidbg1,al
mov al,cs:dbgint+1
mov xlidbg1+1,al
jmp short dbgexit
dbgoff: mov al,cs:dbgnop ;install 2 NOP instructions
mov xlidbg1,al
mov xlidbg1+1,al
dbgexit: mov ax,offset biddbg ;return address of jump table
;following EXEC of child
ret
; data for above routine
dbgint label byte
int 3 ;INT 3 instruction
dbgnop label byte
nop ;NOP instruction
%xlidbg endp
progx ends
; Far linkage *to* XLI
prog segment byte public 'PROG'
assume cs:pgroup
public xli_init,xli_xesc,xli_term
; We preserve DS,ES,BP. AX..DI are destroyed.
xli_init proc near
mov bx,0
xli_10: push bp ;we use ES:BP a lot
push es
call %xli_gate ;cross over into PROGX segment
pop es
pop bp
ret
xli_xesc: mov bx,1
jmp xli_10
xli_term: mov bx,2
jmp xli_10
xli_init endp
; Far linkage *from* XLI
; (all the memory allocation routines are written in C).
; The caller of this should have set BP from SP before pushing the C args,
; then restore SP from BP afterwards to remove them from the stack.
; We don't preserve ES across the call.
far_C proc far
push ds ;C likes ES=DS
pop es
pop work_info.C_retadr ;get far @ off stack so C sees its args
pop work_info.C_retadr+2
call [work_info.C_fn]
push work_info.C_retadr+2
push work_info.C_retadr
ret ;C returns with return value in AX..DX
far_C endp
; Far linkage to XLI debug hook
; stack:
; saved BP
; return address (near call)
; arg (0=turn off, 1=turn on debug)
; AX,BX returns PROGX offset of the jump table following the EXEC of the child.
; This should be the same offset value as in the DOS terminate address vector
; in the child's PSP.
public xlidbg
xlidbg proc near
push bp
mov bp,sp ;after this instruction, stack matches comments
mov ax,[bp]+4
call %xlidbg
pop bp
ret
xlidbg endp
prog ends
end

Reference in New Issue View Git Blame Copy Permalink