pcs/svars.asm

958 lines
40 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.

; =====> SVARS.ASM
;****************************************
;* TIPC Scheme '84 Runtime Support *
;* Interpreter -- Variable Operations *
;* *
;* (C) Copyright 1984, 1985, 1988 *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 July 1984 *
;* Modification History: *
;* ?? 10/22/85 - ?? *
;* rb 2/ 5/88 - MEMV, ASSV use EQV's *
;* definition of number equality *
;* (which is "=", *not* "equal"). *
;* *
;****************************************
include scheme.equ
include sinterp.mac
include sinterp.arg
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_fluid db "LD-FLUID",0
m_setfl db "SET-FLUID!",0
m_set_gl db "SET!-GLOBAL",0
m_fl_p db "FLUID-BOUND?",0
m_ve_al db "MAKE-VECTOR",0
m_vec_s db "VECTOR-SIZE",0
m_vecf db "VECTOR-FILL!",0
m_mkvt_a dw m_ve_al ; address of "MAKE-VECTOR"
m_one dw 1 ; a constant "one" (1)
m_three dw 3 ; a constant "three" (3)
m_toobig dw VECTOR_SIZE_LIMIT_ERROR ; numeric error code
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
var_int proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; mov SP,BP before next_PC
extrn src_err:near ; "source operand error" message display
extrn sch_err:near ; Link to Scheme debugger
;************************************************************************
;* Macro support for global/fluid variable lookup *
;************************************************************************
load macro environ,err_msg,reg_p
local x,y
lods word ptr ES:[SI] ; load dest reg, constant number
save <SI> ; save current location pointer
mov BL,AL ; copy destination register number
mov DI,BX ; into TIPC register DI
mov BL,AH ; isolate constant number
IFIDN <reg_p>,<REG>
mov SI,reg0_pag+[BX] ; load page number from symbol operand reg
mov AX,reg0_dis+[BX] ; likewise for the displacement
ELSE
mov AX,BX ; BX <- constant number * 3
shl AX,1
add BX,AX
add BX,CB_dis ; add offset for start of code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; load symbol's page number
mov SI,AX
mov AX,ES:[BX].cod_cdis ; load symbol's displacement
ENDIF
cmp byte ptr ptype+[SI],SYMTYPE*2 ; reg hold a symbol pointer?
jne y ; if not, jump to error handler
push DI ; save register number
mov DX,SI ; copy symbol's page number into DX
mov DI,environ&_pag ; load fluid environment pointer
mov SI,environ&_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; load paragraph address for env. header
mov BX,DI ; BX <= page number
call lookup ; search the environment for symbol
cmp BX,0 ; symbol found?
pop BX ; restore register number
je x ; if symbol not found, jump
mov AX,ES:[DI].cdr ; load symbol's value pointer
mov reg0_dis+[BX],AX ; and store into register
mov AL,ES:[DI].cdr_page
mov byte ptr reg0_pag+[BX],AL
jmp next_PC
; symbol not found-- return '***unbound***
x: mov CX,offset environ&_reg ; load address of environment reg
corrpage DX ; adjust page number for call to C routine
add BX,offset reg0 ; compute address of destintatin register
pushm <BX,CX,AX,DX> ; push page, displacement, env, dest reg
C_call sym_unde,,Load_ES ; call: symbol_undefined(pg,ds,env,dest)
;***x: mov reg0_dis+[BX],UN_DISP
;*** mov byte ptr reg0_pag+[BX],UN_PAGE*2
restore <SI> ; load next instruction's offset and
sub SI,3 ; back up PC to retry fluid load
jmp sch_err ; Link to Scheme debugger
; error-- register doesn't contain a symbol
y: lea BX,err_msg
jmp src_err ; display error message
endm
;************************************************************************
;* AL AH *
;* Fluid lookup FLUID dest,const *
;* *
;* Purpose: Interpreter support for fluid variable lookup *
;************************************************************************
public ld_fluid
ld_fluid: load FNV,m_fluid,CONST
;************************************************************************
;* AL AH *
;* Fluid lookup-register operand FLUID-R dest,sym *
;* *
;* Purpose: Interpreter support for fluid variable lookup *
;************************************************************************
public ld_fl_r
ld_fl_r: load FNV,m_fluid,REG
purge load
;************************************************************************
;* AL AH *
;* set-fluid! ST-FLUID src,const *
;* *
;* Purpose: Interpreter support for fluid assignment. *
;************************************************************************
public st_fluid
st_fluid: lods word ptr ES:[SI] ; load source reg and constant number
save <SI> ; save current value of location pointer
push AX ; save symbol/value register numbers
mov BL,AH
mov AX,BX ; BX <- constant number * 3
shl AX,1
add BX,AX
add BX,CB_dis ; add in starting offset of code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; load pointer to search symbol
mov DI,AX
cmp byte ptr ptype+[DI],SYMTYPE*2 ; really a symbol?
jne setfl_er ; if not, jump
mov DX,DI ; copy symbol's page number
mov AX,ES:[BX].cod_cdis ; load symbol's displacement
mov DI,FNV_pag ; load pointer to fluid environment
mov SI,FNV_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
mov BX,DI ; Page number
call lookup ; search fluid environment for symbol
cmp BX,0 ; symbol found in fluid environment?
je setfl_nf ; if not, error (jump)
pop AX ; restore operands
mov BL,AL ; copy source register number
mov AL,byte ptr reg0_pag+[BX] ; set cdr of fluid var entry
mov ES:[DI].cdr_page,AL ; to value in register
mov AX,reg0_dis+[BX]
mov ES:[DI].cdr,AX
jmp next_PC ; return to interpreter
; error-- symbol register doesn't contain a symbol pointer
setfl_er: mov BX,offset m_setfl ; load error message text
jmp src_err ; jump to "source error" routine
; error-- symbol not fluidly bound
setfl_nf: pop CX ; restore instruction's operands
xor CH,CH ; clear high order byte (constant number)
add CX,offset reg0 ; compute address of source register
corrpage DX ; convert page number to C's notation
pushm <CX,AX,DX> ; push arguments for error call
C_call not_flui,,Load_ES ; call error routine
restore <SI> ; back up location pointer to retry
sub SI,3 ; the set-fluid! operation
jmp sch_err ; link to Scheme debugger
; fluid-bound? FLUID? reg
public fluid_p
fluid_p: lods byte ptr ES:[SI] ; load the register number for test
save <SI> ; save the current location pointer
mov BX,AX ; copy register number of symbol
mov AX,reg0_dis+[BX]
mov DX,reg0_pag+[BX]
mov DI,DX
cmp byte ptr ptype+[DI],SYMTYPE*2 ; symbol pointer?
jne fl_p_er ; if not, error (jump)
mov DI,FNV_pag
mov SI,FNV_dis
;;; LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
push BX
mov BX,DI ; Page number
call lookup
cmp BX,0
pop BX
je fl_p_nf
; symbol is fluidly bound-- return 't
mov AL,T_PAGE*2
mov byte ptr reg0_pag+[BX],AL
mov AX,T_DISP
mov reg0_dis+[BX],AX
jmp next_PC
; symbol not in fluid environment-- return 'nil
fl_p_nf: xor AX,AX
mov byte ptr reg0_pag+[BX],AL
mov reg0_dis+[BX],AX
jmp next_PC
; error-- operand of (fluid-bound? obj) is not a symbol
fl_p_er: lea BX,m_fl_p
jmp src_err ; display error message
;************************************************************************
;* AL AH *
;* Bind fluid variable BIND-FL const,src *
;* *
;* Purpose: Interpreter support for binding (creating and defining) *
;* fluid variables *
;* *
;* Note: At entry to this routine, ES is set to point to the beginning *
;* of the page containing the current code block. *
;************************************************************************
public bind_fl
bind_fl: lods word ptr ES:[SI] ; load src register, constant number
mov BL,AH ; copy the source register number
lea DI,reg0+[BX] ; and compute its address
; tmp_reg <- symbol
mov BL,AL ; BX <- constant number * 3
mov AX,BX
shl AX,1
add BX,AX
add BX,CB_dis ; add displacement of current code block
xor AX,AX
mov AL,ES:[BX].cod_cpag ; copy the symbol pointer into the
mov tmp_page,AX ; temporary register
mov AX,ES:[BX].cod_cdis
mov tmp_disp,AX
; cons(tmp_reg, tmp_reg, value)
mov AX,offset tmp_reg ; load address of temporary register
pushm <DI,AX,AX> ; push arguments to "cons"
C_call cons,<SI>,Load_ES ; create (cons symbol value)
; cons(FNV, tmp_reg, FNV)
mov AX,offset tmp_reg ; load address of temporary register
mov BX,offset FNV_reg ; load addr of fluid environment register
pushm <BX,AX,BX> ; push arguments to "cons"
C_call cons ; create (cons (cons symbol value) FNV)
jmp next_SP ; return to interpreter
;************************************************************************
;* Unbind fluid variable UNBIND-FL const *
;* *
;* Purpose: Interpreter support for unbinding (deleting) fluid *
;* variables *
;* *
;* Description: The fluid environment is maintained as an a-list, so *
;* dropping fluids consists of cdr-ing down the list for *
;* the required number of elements. *
;************************************************************************
public unbind_f
unbind_f: lods byte ptr ES:[SI] ; load the count of fluids to drop
mov DX,ES ; save code block's paragraph address
mov CX,AX ; copy the drop count into CX
mov BL,byte ptr FNV_pag ; load the fluid environment pointer
mov DI,FNV_dis
unb_fl: LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load entry's paragraph address
mov BL,ES:[DI].cdr_page ; load cdr field of entry
mov DI,ES:[DI].cdr
loop unb_fl ; continue cdr'ing for desired count
mov byte ptr FNV_pag,BL ; re-define the fluid environment
mov FNV_dis,DI ; register
mov ES,DX ; restore code block paragraph address
jmp next ; return to interpreter
;************************************************************************
;* Allocate vector VEC-ALLOCATE dest *
;* *
;* Purpose: Interpreter support for the allocation of vector data *
;* objects. *
;* *
;* Note: Vectors are set to zero after they are allocated to insure *
;* that all entries are valid Scheme pointers. Zeroing a *
;* vector effectively sets all the entries to nil. *
;* If an array were not initialized, the garbage collector *
;* would interpret any leftover data as pointers, and *
;* might cause the Scheme Virtual Machine to go off the *
;* deep end. *
;************************************************************************
public vec_allo
vec_allo: lods byte ptr ES:[SI] ; load destination register number
save <SI> ; save the location pointer
mov BX,AX ; and copy it to TIPC register BX
add BX,offset reg0
cmp byte ptr [BX].C_page,SPECFIX*2 ; is size a fixnum?
jne ve_al_er ; if not, error (jump)
mov AX,[BX].C_disp ; load immediate value from register
shl AX,1 ; and sign extend it
sar AX,1
cmp AX,0 ; value positive?
jl ve_al_er ; if not, error (jump)
cmp AX,10921 ; check against maximum vector size
ja v_toobig ; if too many elements, error (jump)
mov CX,AX ; AX <- AX * 3 (multiply number of
shl AX,1 ; elements by size of pointer)
add AX,CX
mov CX,VECTTYPE ; load type of block to allocate
pushm <AX,CX,BX> ; push arguments
C_call alloc_bl,,Load_ES ; call: alloc_block(&reg, type, size)
pop BX ; recover address of reg holding vector ptr
mov AX,[BX].C_page ; fetch page number from destination reg
corrpage AX ; correct for C callable routine
pushm <[BX].C_disp,AX> ; push page and displacement
C_call zero_blk ; call: zero_blk(page, disp)
jmp next_SP ; return to interpreter
; ***Error-- invalid source operand for vec-alloc***
ve_al_er: mov SI,[BX].C_page ; load operand's page number
cmp byte ptr ptype+[SI],BIGTYPE*2 ; is it a bignum?
je v_toobig ; if so, print "vector too big" message
lea BX,m_ve_al ; otherwise, print "source operand"
jmp src_err ; error message
; ***Error-- vector too large***
v_toobig: restore <SI>
sub SI,2
pushm <SI,m_mkvt_a>
C_call disassem,,Load_ES
pushm <tmp_adr,m_toobig,m_one>
C_call set_nume
jmp sch_err
;************************************************************************
;* Vector size VECTOR-SIZE dest *
;* *
;* Purpose: Interpreter support for the vector-size function to return *
;* the number of elements in a vector data object. *
;* *
;* Description: The number of elements in a vector data object is *
;* determined by dividing the number of bytes (obtained *
;* from the block header of the vector data object) by the *
;* number of bytes in a pointer (3), and subtracting the *
;* overhead of the block header (3 bytes). *
;************************************************************************
public vec_size
vec_size: lods byte ptr ES:[SI] ; load destination register number
mov BX,AX ; and copy into TIPC register BX
save <SI> ; save the location pointer
mov SI,reg0_pag+[BX] ; load page number field of register
cmp ptype+[SI],VECTTYPE*2 ; is object a vector?
jne vec_s_er ; if not, error (jump)
mov DI,reg0_dis+[BX] ; load displacement of vector
LoadPage ES,SI
;;; mov ES,pagetabl+[SI] ; load vector's page paragraph address
mov AX,ES:[DI].vec_len ; load size of object (in bytes),
xor DX,DX ; extend to double word,
mov CX,3 ; load divisor of three,
idiv CX ; divide no. bytes by pointer size
dec AX ; subtract off block overhead
mov reg0_dis+[BX],AX ; store number of elements
mov byte ptr reg0_pag+[BX],SPECFIX*2 ; set tag=fixnum
jmp next_PC ; return to interpreter
; ***error-- operand doesn't point to a vector data object***
vec_s_er: lea BX,m_vec_s
jmp src_err ; display error message
;************************************************************************
;* AL AH *
;* vector fill vec-fill vect,val*
;* *
;* Purpose: Scheme intepreter support for the vector-fill operation *
;************************************************************************
public vec_fill
vec_fill: lods word ptr ES:[SI] ; load operands
save <SI> ; save location pointer
xor BX,BX
mov BL,AL ; copy number of register containing vector
mov DI,reg0_dis+[BX] ; load vector pointer
mov BL,byte ptr reg0_pag+[BX]
cmp byte ptr ptype+[BX],VECTTYPE*2 ; is it really a vector?
jne vecf_err ; if not, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load page address of vector's page
mov BL,AH ; copy pointer to fill value
mov AX,reg0_dis+[BX] ; load value to fill array
mov DL,byte ptr reg0_pag+[BX]
mov CX,ES:[DI].vec_len ; load vector length (in bytes) and
sub CX,BLK_OVHD ; subtract off overhead for block header
jle vecf_fin ; if zero length vector, we're done
vecf_lp: mov ES:[DI].vec_page,DL ; store value into current element
mov ES:[DI].vec_disp,AX ; of vector
add DI,PTRSIZE ; increment pointer into vector
sub CX,PTRSIZE ; decrement array size
jg vecf_lp ; if more elements to define, loop (jump)
vecf_fin: jmp next_PC ; return to Scheme interpreter
vecf_err: lea BX,m_vecf
jmp src_err
;************************************************************************
;* AL AH *
;* (memq obj,list) MEMQ dest,src*
;* *
;* Purpose: Scheme interpreter support for the memq primitive *
;************************************************************************
; Support for SHIFT-BREAK-- restart operation
memq_sb: push m_three ; indicate instruction length = 3
C_call restart ; link to Scheme debugger
public memq
memq: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL ; compute the destination register
memq_x: lea DI,reg0+[BX] ; address in TIPC register DI
mov AL,byte ptr [DI].C_page ; copy search object pointer
mov DX,[DI].C_disp ; into AL,DX (page, disp, respectively)
mov BL,AH ; copy pointer to search list
mov SI,reg0_dis+[BX] ; load contents of "list" register
mov BL,byte ptr reg0_pag+[BX]
jmp memq_go
memq_nxt: cmp byte ptr s_break,0 ; has shift-break been depressed?
jne memq_sb ; if interrupt, jump
mov BL,ES:[SI].cdr_page ; load cdr field and continue
mov SI,ES:[SI].cdr ; search
memq_go: cmp BL,0 ; nil pointer?
je memq_f ; if so, return nil (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell?
jne memq_f ; if not, return nil (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell
cmp DX,ES:[SI].car ; does displacement field of car match obj?
jne memq_nxt ; if not, test next element in list (jump)
cmp AL,ES:[SI].car_page ; does page field of car match obj?
jne memq_nxt ; if not, test next element in list (jump)
; match found-- return pointer to current list cell
mov byte ptr [DI].C_page,BL ; set destination register to point
mov [DI].C_disp,SI ; to current list cell
jmp next_PC ; return to interpreter
; no match-- return 'nil
memq_f: xor AX,AX ; put null value into destination register
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (memv key,list) MEMV dest,src *
;* key, list *
;* *
;* Purpose: Scheme interpreter support for the memv primitive *
;************************************************************************
memv_sb: jmp memq_sb ; shift-break support-- link to debugger
public memv
memv: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL ; compute the destination register
mov DI,reg0_pag+[BX] ; load page number of search object
; The following 3 lines are sufficient for MEMV if EQV doesn't require
; an = test for numbers and only checks types instead. All the remaining
; code for MEMV is to handle =.
; test attrib+[DI],FLONUMS+BIGNUMS+STRINGS
; jz memv_x ; unless one of above types, use "memq"
; jmp short memv_y ; otherwise, use full "member" test
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS
jz memv_x ; unless one of above types, use "memq"
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS
jz memv_y ; for strings do "member" test
; key is a number
lea DI,reg0[BX] ; DI=address of VM reg containing key
mov BL,AH
lea SI,reg0[BX] ; SI=address of VM reg containing list
push [SI].C_page ; tempsave "list" VM reg
push [SI].C_disp
jmp short memv_nxt
memv_x: jmp memq_x ; these damn short relative jumps!!
memv_y: jmp member_x
; this list element didn't match, go to the next element
memv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed?
jne memv_sb ; yes, do break
mov BX,[SI].C_disp ; cdr our way down list
mov AL,ES:[BX].cdr_page
mov AH,0
mov [SI].C_page,AX
mov AX,ES:[BX].cdr
mov [SI].C_disp,AX
; loop over each element in the list
memv_nxt: mov BX,[SI].C_page
cmp BX,NIL_PAGE ; at end of list?
je memv_f ; yes, jump
cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons?
jne memv_f ; no, jump
LoadPage ES,BX ; get cons into memory
mov BX,[SI].C_disp ; ES:BX=address of cons cell
mov BL,ES:[BX].car_page
mov BH,0
test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is list elt numeric?
jz memv_more ; no, jump
; key and list element are both numeric
mov tmp_reg.C_page,BX
mov BX,[SI].C_disp
mov BX,ES:[BX].car
mov tmp_reg.C_disp,BX
lea BX,tmp_reg
; begin comparison of key and list element
cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum?
jne memv_float ; no, jump
cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum?
jne memv_float ; no, jump
; both key and list element are fixnums
mov AX,[BX] ; AX=list elt
mov DX,[DI] ; DX=key
shl AX,1
shl DX,1
cmp AX,DX ; same number?
jne memv_more ; no, jump
; we have a match, copy list object-pointer to VM register containing key
memv_t: mov AX,[SI].C_disp
mov [DI].C_disp,AX
mov AX,[SI].C_page
mov [DI].C_page,AX
jmp short memv_f1
; we have no match, copy '() to VM register containing key
memv_f: xor AX,AX
mov [DI].C_page,AX
mov [DI].C_disp,AX
memv_f1: pop [SI].C_disp ; restore original contents "list" VM reg
pop [SI].C_page
jmp next_PC ; return to interpreter
; key and list element are not both fixnums, do = operation
memv_float: mov AX,EQ_OP
pushm <ES,DI,SI> ; save our state around C call
pushm <BX,DI,AX> ; list elt, key, operation
C_call arith2,,Load_ES ; do =
popm <SI,SI,SI> ; get C args off stack
popm <SI,DI,ES> ; restore our state
cmp AX,0 ; AX negative means "error"
jge memv_flo2 ; nope
jmp sch_err ; yes, go to error handler
memv_flo2: jg memv_t ; AX positive means "true"
jmp memv_more ; no match, go to next list element
;************************************************************************
;* AL AH *
;* (member key,list) MEMBER dest,src *
;* key, list *
;* *
;* Purpose: Scheme interpreter support for the member primitive *
;************************************************************************
memb_sb: jmp memq_sb ; shift-break support-- link to debugger
public member
member: lods word ptr ES:[SI] ; load operands
save <SI> ; save the current location pointer
mov BL,AL
mov DI,reg0_pag+[BX] ; load search object's page number
test attrib+[DI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS
jz member_x ; if not one of these, use "equal?" compare
jmp memq_x ; otherwise, use "memq" test
member_x: lea DI,reg0+[BX] ; address in TIPC register DI
mov CL,byte ptr [DI].C_page ; load pointer to object in CL:DX
mov DX,[DI].C_disp
mov BL,CL
mov CH,byte ptr ptype+[BX] ; load type code of search object
mov BL,AH ; copy pointer to search list
mov SI,reg0_dis+[BX] ; load contents of "list" register
mov BL,byte ptr reg0_pag+[BX]
jmp memb_go
memb_mor: mov AX,BX
mov BL,ES:[SI].car_page
cmp CH,byte ptr ptype+[BX]
jne memb_nxt
pushm <AX,CX,DX,SI> ; save registers across call
xor AX,AX
mov AL,ES:[SI].car_page
mov [BP].temp_reg.C_page,AX ; temp_reg <- (car list)
mov AX,ES:[SI].car
mov [BP].temp_reg.C_disp,AX
lea BX,[BP].temp_reg ; load address of temporary register
pushm <BX,DI> ; push arguments
C_call sequal_p,,Load_ES ; call: sequal_p(&dest,&src)
pop DI ; retrieve destination register address
add SP,WORDINCR ; dump other arguments from stack
popm <SI,DX,CX,BX> ; restore registers
LoadPage ES,BX ; restore page paragraph address
cmp AX,0 ; were values equal?
jne memb_fnd ; if so, jump
memb_nxt: cmp s_break,0 ; has shift-break key been depressed?
jne memb_sb ; if interrupt, jump
mov BL,ES:[SI].cdr_page ; load cdr field and continue
mov SI,ES:[SI].cdr ; search
memb_go: cmp BL,0 ; nil pointer?
je memb_f ; if so, return nil (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; "list" object a list cell?
jne memb_f ; if not, return nil (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of list cell
cmp DX,ES:[SI].car ; does displacement field of car match obj?
jne memb_mor ; if not, test next element in list (jump)
cmp CL,ES:[SI].car_page ; does page field of car match obj?
jne memb_mor ; if not, test next element in list (jump)
; "eq" match found-- return pointer to current list cell
memb_fnd: mov byte ptr [DI].C_page,BL ; set destination register to point
mov [DI].C_disp,SI ; to current list cell
jmp next_PC ; return to interpreter
; no match-- return 'nil
memb_f: xor AX,AX ; put null value into destination register
mov byte ptr [DI].C_page,AL
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (assq obj,list) ASSQ obj,list*
;* *
;* Purpose: Scheme interpreter support for the assq primitive *
;************************************************************************
public assq
assq: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
assq_go: mov BL,AH ; copy the list register number
mov SI,reg0_pag+[BX]
cmp ptype+[SI],LISTTYPE*2 ; is second operand a list?
jne assq_err ; if not, error(?) (jump)
LoadPage ES,SI
mov DI,SI ; Save page number
;;; mov ES,pagetabl+[SI] ; load list page's paragraph address
mov SI,reg0_dis+[BX] ; load pointer to list operand
mov BL,AL ; load object register number
mov DX,reg0_pag+[BX] ; load pointer to search object
mov AX,reg0_dis+[BX]
push BX ; save destination register number
mov BX,DI ; Pass the page number
call lookup ; search list for eq? comparison of obj
pop SI ; restore destination register number
mov byte ptr reg0_pag+[SI],BL ; store result of search in
mov reg0_dis+[SI],DI ; the destination register
jmp next_PC ; return to interpreter
; ***second operand is not a list-- return nil***
assq_err: mov BL,AL ; copy destination register number
xor AX,AX
mov byte ptr reg0_pag+[BX],AL ; store nil into destination
mov reg0_dis+[BX],AX ; register
jmp next_PC ; return to interpreter
;************************************************************************
;* AL AH *
;* (assv key,alist) ASSV key,alist *
;* *
;* Purpose: Scheme interpreter support for the assv primitive *
;************************************************************************
assv_sb: jmp memq_sb ; shift-break support-- link to debugger
public assv
assv: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
mov BL,AL ; get number of VM register containing key
mov DI,reg0_pag+[BX] ; load key's page number
; The following 3 lines are sufficient for ASSV if EQV doesn't require
; an = test for numbers and only checks types instead. All the remaining
; code for ASSV is to handle =.
; test attrib+[SI],FLONUMS+BIGNUMS+STRINGS ; one of these?
; jz assq_go ; if not one of above, use assq (jump)
; jmp short assoc_go ; if one of the above, use assoc
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS+STRINGS
jz assv_x ; unless one of above types, use "assq"
test attrib[DI],FIXNUMS+FLONUMS+BIGNUMS
jz assv_y ; for strings do "assoc" test
; key is a number
lea DI,reg0[BX] ; DI=address of VM reg containing key
mov BL,AH
lea SI,reg0[BX] ; SI=address of VM reg containing list
push [SI].C_page ; tempsave "alist" VM reg
push [SI].C_disp
jmp short assv_nxt
assv_x: jmp assq_go ; these damn short relative jumps!!
assv_y: jmp assoc_go
; this list element didn't match, go to the next element
assv_more: cmp s_break,0 ; shift-break (IBM: control-break) pressed?
jne assv_sb ; yes, do break
mov BX,[SI].C_page
LoadPage ES,BX ; get toplevel cons back into memory
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell
mov AL,ES:[BX].cdr_page ; cdr down the alist
mov AH,0
mov [SI].C_page,AX
mov AX,ES:[BX].cdr
mov [SI].C_disp,AX
; loop over each element in the list
assv_nxt: mov BX,[SI].C_page
cmp BX,NIL_PAGE ; at end of list?
je assv_f ; yes, jump
cmp byte ptr ptype[BX],LISTTYPE*2 ; looking at a cons?
jne assv_f ; no, jump
LoadPage ES,BX ; get toplevel cons into memory
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons cell
push BX ; tempsave it
mov BL,ES:[BX].car_page
mov BH,0
cmp byte ptr ptype[BX],LISTTYPE*2 ; is car of toplevel cons also a cons?
je assv_down ; yes, jump
assv_pop: pop BX ; normalize stack
assv_more1: jmp assv_more ; look at next toplevel cons
assv_down: mov DX,BX
pop BX ; (ES:BX=address of toplevel cons again)
mov BX,ES:[BX].car ; DX:BX=object ptr to 2nd level cons
LoadPage ES,DX ; ES:BX=address of 2nd level cons cell
push BX ; tempsave it
mov BL,ES:[BX].car_page
mov BH,0
test attrib[BX],FIXNUMS+FLONUMS+BIGNUMS ; is its car numeric?
jz assv_pop ; no, jump
mov tmp_reg.C_page,BX ; yes, move car ptr into tmp_reg
pop BX ; (ES:BX=address of 2nd level cons again)
mov BX,ES:[BX].car
mov tmp_reg.C_disp,BX
lea BX,tmp_reg ; BX=address of tmp_reg
; begin comparison of key and list element
cmp byte ptr [DI].C_page,SPECFIX*2 ; is key a fixnum?
jne assv_float ; no, jump
cmp byte ptr [BX].C_page,SPECFIX*2 ; is list elt a fixnum?
jne assv_float ; no, jump
; both key and list element are fixnums
mov AX,[BX] ; AX=list elt
mov DX,[DI] ; DX=key
shl AX,1
shl DX,1
cmp AX,DX ; same number?
jne assv_more1 ; no, jump
jmp short assv_t
; we have no match, copy '() to VM register containing key
assv_f: xor AX,AX
mov [DI].C_page,AX
mov [DI].C_disp,AX
assv_f1: pop [SI].C_disp ; restore original contents "alist" VM reg
pop [SI].C_page
jmp next_PC ; return to interpreter
; we have a match, copy list object-pointer to VM register containing key
assv_t: mov BX,[SI].C_page
LoadPage ES,BX
mov BX,[SI].C_disp ; ES:BX=address of toplevel cons
mov AX,ES:[BX].car ; move car of this cons to dest. register
mov [DI].C_disp,AX
mov AL,ES:[BX].car_page
mov AH,0
mov [DI].C_page,AX
jmp assv_f1 ; return to interpreter
; key and list element are not both fixnums, do = operation
assv_float: mov AX,EQ_OP
pushm <ES,DI,SI> ; save our state around C call
pushm <BX,DI,AX> ; list elt, key, operation
C_call arith2,,Load_ES ; do =
popm <SI,SI,SI> ; get C args off stack
popm <SI,DI,ES> ; restore our state
cmp AX,0 ; AX negative means "error"
jge assv_flo2 ; nope
jmp sch_err ; yes, go to error handler
assv_flo2: jg assv_t ; AX positive means "true"
jmp assv_more ; no match, go to next list element
;************************************************************************
;* AL AH *
;* (assoc obj,list) ASSOC obj,list*
;* *
;* Purpose: Scheme interpreter support for the assoc primitive *
;* *
;* Register Usage: DX - address of destination register *
;* ES:SI - pointer to current list cell *
;************************************************************************
public assoc
assoc: lods word ptr ES:[SI] ; load operands
save <SI> ; save the location pointer
mov BL,AL ; copy search object's register number
mov SI,reg0_pag+[BX] ; load search object's page number
test attrib+[SI],FIXNUMS+SYMBOLS+CONTINU+CLOSURE+PORTS+CODE+CHARS
jz assoc_go
jmp assq_go ; if one of the above, use assq (jump)
assoc_go: mov DX,BX ; copy obj's reg number into TIPC reg DX
add DX,offset reg0 ; compute address of search obj register
mov BL,AH ; copy list register number
mov SI,reg0_dis+[BX] ; load displacement pointer of "list"
mov BL,byte ptr reg0_pag+[BX] ; load page number of "list"
assoc_lp: cmp BL,0 ; end of list? (nil pointer?)
je assoc_nf ; if end of list, jump
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is list operand a list?
jne assoc_er ; if not, error(?) (jump)
LoadPage ES,BX
mov AX,BX ;****** SAVE PAGE *********
;;; mov ES,pagetabl+[BX] ; load list page's paragraph address
mov BL,ES:[SI].car_page ; load page number of car
cmp byte ptr ptype+[BX],LISTTYPE*2 ; does car point to list cell?
jne assoc_nl ; if not a list cell, jump
mov DI,ES:[SI].car ; load displacement pointer of car field
pushm <AX,SI> ;****** REALLY SAVE PAGE****
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
xor AX,AX
mov AL,ES:[DI].car_page ; copy car field into tmp_reg
mov tmp_page,AX
mov AX,ES:[DI].car
mov tmp_disp,AX
mov AX,offset tmp_reg
pushm <DX,AX> ; push arguments to call
C_call sequal_p,,Load_ES ; compare equality of the two pointers
add SP,WORDINCR ; dump tmp_reg address
pop DX ; restore obj/dest register address
popm <SI,BX> ; restore ES,SI registers
LoadPage ES,BX ;********** Restore Para Address *****
cmp AX,0 ; were pointers equal?
jne assoc_t ; if equal, jump
assoc_nl: xor BX,BX ; clear high order byte of BX
mov BL,ES:[SI].cdr_page ; follow cdr field
mov SI,ES:[SI].cdr
cmp byte ptr s_break,0 ; has the shift-break key been depressed?
je assoc_lp ; if no shift-break, loop
jmp memq_sb ; if interrupt, jump to debugger support
; pointers "equal"-- return pointer to car field of current list cell
assoc_t: mov DI,DX ; copy destination register address to DI
mov AL,ES:[SI].car_page ; return cdr field of list cell
mov byte ptr [DI].C_page,AL
mov AX,ES:[SI].car
mov [DI].C_disp,AX
jmp next_PC ; return to interpreter
; end of search, or error detected-- return nil
assoc_er:
assoc_nf: mov DI,DX ; copy destination register address to DI
mov byte ptr [DI].C_page,NIL_PAGE*2 ; store nil pointer into
mov [DI].C_disp,NIL_DISP ; destination register
jmp next_PC ; return to interpreter
var_int endp
;************************************************************************
;* Lookup Symbol is Assoc List *
;* *
;* Purpose: To search a linked list for a given pointer *
;* *
;* Description: The list to be searched has the following format: *
;* *
;* +--------+--------+ +--------+-------+ *
;* +-->|symbol->|value ->| +-->|symbol->|value->| *
;* | +--------+--------+ | +--------+-------+ *
;* | | *
;* +---+----+--------+ +---+----+--------+ *
;* | o | o----+----...----->| o | (nil) | *
;* +--------+--------+ +--------+--------+ *
;* *
;* The symbol portion of the list entries are compared against the *
;* search symbol for an identical match. When found, a pointer to *
;* the matched symbol's symbol-value entry is returned. If the *
;* symbol is not found, a value of nil is returned. *
;* *
;* Registers upon entry: AX - search symbol's displacement *
;* BX - page number of list to search *
;* DL - search symbol's page number *
;* SI - displacement within page number *
;* of list to search *
;* *
;* Registers on exit: BL - page number of cell whose car is the *
;* search symbol, or zero if not found *
;* DI - displacement of list cell found, or nil *
;* ES:[DI] - points to cell found *
;************************************************************************
public lookup
lookup proc near
lookloop:
mov CX,BX ; Save Page number
LoadPage ES,BX ; Load Paragraph address of page
mov BL,ES:[SI].car_page ; load car of next list cell in the list
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is car a list cell?
mov DI,ES:[SI].car
jne look_err ; if not a list cell, jump
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load paragraph address of its page
cmp AX,ES:[DI].car ; does car's disp match search symbol's?
jne look_nf ; if not, keep searching (jump)
cmp DL,ES:[DI].car_page ; does car's page match search symbol's?
je look_fnd ; if so, we've got a match (jump)
; no match-- continue through linked list
look_nf: mov BX,CX ; restore page number
LoadPage ES,BX
mov BL,ES:[SI].cdr_page ; load the cdr field
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is cdr another list cell?
jne look_err ; if not, error(?)
mov SI,ES:[SI].cdr
cmp BX,0 ; is cdr nil?
jne lookloop ; if not, branch
xor DI,DI ; make BX:DI nil
look_fnd: ret ; return pointer to caller
;
look_err: xor BX,BX ; create a nil pointer to return
xor SI,SI
ret
lookup endp
;************************************************************************
;* C-callable Fluid Variable Lookup *
;* *
;* Purpose: To retrieve the fluid binding for a variable. *
;* *
;* Calling Sequence: stat = fluid_lookup(&reg) *
;* where &reg - address of the register containing *
;* the symbol to be looked up. *
;* On exit, "reg" contains the *
;* current binding for the symbol, *
;* if found. *
;* stat - search status: TRUE=symbol found *
;* FALSE=symbol not found *
;* *
;* Note: If the call to "lookup" doesn't find the desired symbol, it *
;* will return a nil pointer. It is correct to always *
;* return the cdr of the pointer "lookup" returns, since *
;* the cdr of nil is itself nil-- a valid value. *
;************************************************************************
fl_lk_ar struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; return address
fl_lk_rg dw ? ; register address
fl_lk_ar ends
public fluid_lo
fluid_lo proc near
push ES ; save caller's ES
push BP ; and BP
mov BP,SP
; load pointer to search symbol in DL:AX
mov BX,[BP].fl_lk_rg ; load register address
mov AX,[BX].C_disp
mov DL,byte ptr [BX].C_page
; load pointer to search list (fluid environment) in ES:[SI]
mov BX,FNV_pag
mov SI,FNV_dis
;;; LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
; search the fluid environment for the symbol
call lookup
; store "cdr" of returned cell into register
mov SI,[BP].fl_lk_rg
mov AL,ES:[DI].cdr_page
mov byte ptr [SI].C_page,AL
mov AX,ES:[DI].cdr
mov [SI].C_disp,AX
; set return code (BX=0 if symbol not found) and return
mov AX,BX
pop BP ; restore caller's BP
pop ES ; and ES
ret ; return to caller
fluid_lo endp
prog ends
end