1052 lines
45 KiB
NASM
1052 lines
45 KiB
NASM
; =====> SENV.ASM
|
||
;***************************************
|
||
;* TIPC Scheme '84 Runtime Support *
|
||
;*Interpreter -- Environment Operations*
|
||
;* *
|
||
;* (C) Copyright 1985 by Texas *
|
||
;* Instruments Incorporated. *
|
||
;* All rights reserved. *
|
||
;* *
|
||
;* Date Written: 5 March 1985 *
|
||
;* Last Modification: 2 FEB 1987 *
|
||
;***************************************
|
||
;
|
||
; Modification history
|
||
;
|
||
; tc 2/10/87 fixed define so that it will define in
|
||
; to current environment if not already
|
||
; there.
|
||
|
||
|
||
|
||
include scheme.equ
|
||
include sinterp.mac
|
||
|
||
include sinterp.arg
|
||
include stackf.equ
|
||
|
||
DGROUP group data
|
||
data segment word public 'DATA'
|
||
assume DS:DGROUP
|
||
m_ld_en db "ld-env",0
|
||
m_st_en db "st-env",0
|
||
m_def_en db "define-env",0
|
||
m_en_par db "environment-parent",0
|
||
m_env_lu db "env-lu",0
|
||
m_ld_gl db "ld-global",0
|
||
m_defb db "define!",0
|
||
m_st_gl db "st-global",0
|
||
m_setgnv db "set-global-env!",0
|
||
; Note: the following three (3) definitions are order dependent
|
||
lcl_reg equ $ ; local "register"
|
||
lcl_disp dw 0
|
||
lcl_page dw 0
|
||
; End of order dependent definitions
|
||
data ends
|
||
|
||
PGROUP group prog
|
||
prog segment byte public 'PROG'
|
||
assume CS:PGROUP
|
||
|
||
s_env 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 ; All of the above, with "mov SP,BP" first
|
||
extrn src_err:near ; "source operand error" message display
|
||
extrn printf_c:near ; Error message print routine
|
||
extrn not_yet:near ; Feature not yet implemented
|
||
extrn sch_err:near ; Link to Scheme level debugger
|
||
|
||
; Entry point defined in "svars.asm"
|
||
extrn lookup:near
|
||
|
||
;************************************************************************
|
||
;* push environment PUSH-ENV list-of-symbols *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to "push" a new rib onto the *
|
||
;* current heap allocated environment. *
|
||
;************************************************************************
|
||
public push_env
|
||
push_env: lods byte ptr ES:[SI] ; load code block constant pointer
|
||
; allocate new environment object
|
||
mov BX,ENV_SIZE-BLK_OVHD ; load size of environment data object,
|
||
mov CX,ENVTYPE ; environment type code, and
|
||
mov DX,offset tmp_reg ; temporary register address
|
||
pushm <BX,CX,DX> ; push arguments to 'allocate_block'
|
||
C_call alloc_bl,<AX,SI>,Load_ES ; allocate new environment object
|
||
|
||
; fetch pointer to list-of-symbols
|
||
restore <AX,ES>
|
||
mov BX,AX
|
||
shl AX,1
|
||
add BX,AX ; BX <- constant number * 3
|
||
add BX,CB_dis ; add code block displacement to BX
|
||
mov AX,ES:[BX].cod_cdis ; load constant from code block
|
||
mov DL,ES:[BX].cod_cpag
|
||
|
||
; place previous env pointer in new one; update stack frame's env pointer
|
||
mov BX,tmp_page ; load pointer to new env object
|
||
mov DI,tmp_disp
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov SI,FP ; load current stack frame pointer
|
||
xchg BL,S_stack+[SI].sf_hpage ; exchange old/new env pointers
|
||
mov ES:[DI].env_ppag,BL
|
||
mov CX,DI
|
||
xchg CX,word ptr S_stack+[SI].sf_hdisp
|
||
mov ES:[DI].env_pdis,CX
|
||
|
||
; put list-of-symbols pointer into new environment data object
|
||
mov ES:[DI].env_npag,DL ; and store it
|
||
mov ES:[DI].env_ndis,AX
|
||
|
||
; set tm2_reg to nil (initial empty list of values)
|
||
mov byte ptr tm2_page,NIL_PAGE*2 ; set tmp_reg to nil
|
||
mov tm2_disp,NIL_DISP
|
||
|
||
; count number of symbols in the list-of-symbols
|
||
cmp DL,0 ; is list of symbols nil?
|
||
je psh_end ; if empty list, jump
|
||
mov ES:[DI].env_vpag,NIL_PAGE*2 ; make value list pointer in env
|
||
mov ES:[DI].env_vdis,NIL_DISP ; object nil to prevent GC problems
|
||
xor CX,CX ; zero the counter
|
||
xor BX,BX
|
||
mov BL,DL ; copy the list-of-symbols pointer
|
||
mov SI,AX ; into BX:SI
|
||
psh_enxt: inc CX ; increment list length counter
|
||
LoadPage ES,BX ; follow the cdr field of the linked list
|
||
;;; mov ES,pagetabl+[BX] ; follow the cdr field of the linked list
|
||
mov BL,ES:[SI].cdr_page
|
||
mov SI,ES:[SI].cdr
|
||
cmp BL,0 ; end of list?
|
||
jne psh_enxt
|
||
|
||
; set up parameters for call to cons
|
||
mov DX,offset nil_reg
|
||
mov AX,offset tm2_reg
|
||
pushm <DX,AX,AX>
|
||
mov AX,DS ; load ES for call to Lattice C routine
|
||
mov ES,AX
|
||
|
||
; create value list of nil pointers (linked through car field)
|
||
psh_cons: C_call cons,<CX> ; cons a nil value cell
|
||
restore <CX> ; reload counter
|
||
loop psh_cons ; decrement count, loop if not zero
|
||
add SP,WORDINCR*3 ; drop arguments off TIPC's stack
|
||
|
||
; store pointer to list of values into environment data object
|
||
mov BX,tmp_page ; reload environment object pointer (it
|
||
LoadPage ES,BX ; may have been moved during the consing
|
||
;;; mov ES,pagetabl+[BX] ; may have been moved during the consing
|
||
mov DI,tmp_disp ; of the nil values list)
|
||
psh_end: mov AL,byte ptr tm2_page ; store pointer to list-of-values
|
||
mov ES:[DI].env_vpag,AL ; into env data object
|
||
mov AX,tm2_disp
|
||
mov ES:[DI].env_vdis,AX
|
||
|
||
jmp next_SP ; return to interpreter
|
||
|
||
;************************************************************************
|
||
;* hash-environment HASH-ENV *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to return a hashed environment *
|
||
;* *
|
||
;************************************************************************
|
||
public hash_env
|
||
hash_env: lods byte ptr ES:[SI] ; load destination register number
|
||
; allocate new environment object
|
||
mov BX,(HT_SIZE*3)+BLK_OVHD ; size of hashed env
|
||
mov CX,ENVTYPE ; environment type code
|
||
mov DX,offset tmp_reg ; temporary register address
|
||
pushm <BX,CX,DX> ; push arguments to 'allocate_block'
|
||
C_call alloc_bl,<AX,SI>,Load_ES ; allocate new environment object
|
||
mov SP,BP
|
||
push tmp_disp ; push new environment's displacement
|
||
mov BX,tmp_page ; get page offset of new env.
|
||
shr BX,1 ; convert to number
|
||
push BX ; push new environment's page number
|
||
C_call zero_blk ; zero out the new environment
|
||
mov SP,BP
|
||
mov BX,tmp_page ; Now address the new environment
|
||
mov DI,tmp_disp
|
||
LoadPage ES,BX ; ES <= address of new environment
|
||
mov BX,FP ; get current stack frame pointer
|
||
mov AL,S_stack+[BX].sf_hpage ; get current env pointer from stack
|
||
mov ES:[DI].env_ppag,AL ; and store in new env object
|
||
mov AX,word ptr S_stack+[BX].sf_hdisp
|
||
mov ES:[DI].env_pdis,AX
|
||
restore <AX,SI,ES> ; restore saved regs
|
||
mov DI,AX ; DI <= destination register
|
||
mov BX,tmp_page ; get page number of new environment
|
||
mov byte ptr reg0_pag+[DI],BL ; and place in destination reg
|
||
mov BX,tmp_disp ; get disp of new environment
|
||
mov reg0_dis+[DI],BX ; and place in destination
|
||
jmp next
|
||
|
||
;************************************************************************
|
||
;* drop-environment DROP-ENV I(number to drop) *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to drop the most recently *
|
||
;* allocated rib from the current environment. *
|
||
;************************************************************************
|
||
public drop_env
|
||
drop_env: lods byte ptr ES:[SI] ; load drop count
|
||
save <SI> ; save the current location pointer
|
||
mov CX,AX ; copy drop count to CX
|
||
mov DI,FP ; load the current stack frame pointer
|
||
xor BX,BX
|
||
mov BL,S_stack+[DI].sf_hpage ; load environment pointer from
|
||
mov SI,word ptr S_stack+[DI].sf_hdisp ; the current stack frame
|
||
drop_lp: LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov BL,ES:[SI].env_ppag ; copy parent's pointer from environment
|
||
mov SI,ES:[SI].env_pdis
|
||
loop drop_lp
|
||
mov S_stack+[DI].sf_hpage,BL ; rib into the stack frame
|
||
mov word ptr S_stack+[DI].sf_hdisp,SI
|
||
jmp next_PC ; return to interpreter
|
||
|
||
;************************************************************************
|
||
;* Macro Support for load/store-environment *
|
||
;************************************************************************
|
||
ld_st macro direction,text
|
||
local x,y
|
||
lods word ptr ES:[SI] ; load operands
|
||
xor BH,BH
|
||
mov BL,AL ; copy destination register number
|
||
mov DI,BX ; into TIPC register DI and
|
||
add DI,offset reg0 ; compute its address
|
||
save <SI,DI> ; save location pointer, dest reg address
|
||
mov BL,AH ; copy constant number into
|
||
mov DI,BX ; TIPC register DI
|
||
shl BX,1
|
||
add DI,BX ; DI <- constant number * 3
|
||
add DI,CB_dis ; compute address of code block constant
|
||
xor BH,BH
|
||
mov BL,ES:[DI].cod_cpag ; load symbol's page number
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
|
||
jne x ; if not a symbol, error (jump)
|
||
; call "srch_all" to search the current environment
|
||
mov CX,BX ; copy symbol pointer into CX:DX
|
||
mov DX,ES:[DI].cod_cdis
|
||
mov SI,FP ; load current stack frame pointer
|
||
mov BL,S_stack+[SI].sf_hpage ; load current env pointer into
|
||
mov SI,word ptr S_stack+[SI].sf_hdisp ; BX:SI
|
||
call srch_all ; search environment for symbol
|
||
restore <DI> ; reload destination register address
|
||
cmp BL,0 ; was symbol found in environment?
|
||
je y ; if not found, error (jump)
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
IFIDN <direction>,<load>
|
||
; return value from cdr field of value cell returned by "srch_all"
|
||
mov AL,ES:[SI].cdr_page
|
||
mov byte ptr [DI].C_page,AL ; store value in destination register
|
||
mov AX,ES:[SI].cdr
|
||
mov [DI].C_disp,AX
|
||
ELSE
|
||
IFIDN <direction>,<store>
|
||
; store value into cdr field of returned value cell
|
||
mov AL,byte ptr [DI].C_page ; store value into cdr field
|
||
mov ES:[SI].cdr_page,AL ; of cell
|
||
mov AX,[DI].C_disp
|
||
mov ES:[SI].cdr,AX
|
||
ELSE
|
||
***error*** Invalid 'direction'
|
||
ENDIF
|
||
ENDIF
|
||
; return to the Scheme interpreter
|
||
jmp next_PC
|
||
; ***error-- operand is not a symbol***
|
||
x: lea BX,text ; load text for instruction's name
|
||
jmp src_err ; display "source operand error" message
|
||
; ***error-- symbol not found in environment***
|
||
y: corrpage CX
|
||
IFIDN <direction>,<load>
|
||
xor AX,AX ; signal current environment being used
|
||
pushm <DI,AX,DX,CX> ; push arguments for call
|
||
C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest);
|
||
ELSE
|
||
pushm <DX,CX> ; push arguments for call
|
||
C_call not_lexi,,Load_ES ; call: not_lexically_bound(pg,ds);
|
||
ENDIF
|
||
restore <SI> ; load next instruction's offset and
|
||
sub SI,3 ; back it up to retry the ld/st
|
||
jmp sch_err ; link to Scheme debugger
|
||
endm
|
||
|
||
;************************************************************************
|
||
;* Load From Environment LD-ENV R(dest),C(symbol) *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to load from the current *
|
||
;* environment. *
|
||
;************************************************************************
|
||
public ld_env
|
||
; load and process operands
|
||
ld_env: ld_st load,m_ld_en
|
||
|
||
;************************************************************************
|
||
;* Store Into Environment ST-ENV R(value),C(symbol) *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to store into the current *
|
||
;* environment. *
|
||
;************************************************************************
|
||
public st_env
|
||
; load and process operands
|
||
st_env: ld_st store,m_st_en
|
||
|
||
purge ld_st
|
||
|
||
;************************************************************************
|
||
;* AL AL AH *
|
||
;* Define in Environment DEFINE R(d=s1),R(s2),R(s3) *
|
||
;* s1=sym,s2=val,s3=env/nil *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to define a symbol in a given *
|
||
;* environment. This routine supports the MIT Scheme construct *
|
||
;* (set! (access sym env) value). In essence, the current env *
|
||
;* is searched for sym. If found, then its binding is modified *
|
||
;* to value. Otherwise, a new binding is added to the current *
|
||
;* environment. *
|
||
;************************************************************************
|
||
; ***error-- invalid operand for define***
|
||
def_en_x: mov BX,offset m_def_en ; load "def-env" text
|
||
jmp src_err ; display "invalid source operand" message
|
||
|
||
public def_env
|
||
def_env: lods byte ptr ES:[SI] ; load symbol operand
|
||
mov DI,AX ; copy symbol register number to
|
||
add DI,offset reg0 ; DI and compute the register's address
|
||
lods word ptr ES:[SI] ; load value/environment operands
|
||
save <SI,DI,AX> ; save loc ptr, dest reg addr, val/env opnds
|
||
; validate and load the symbol operand
|
||
mov BX,[DI].C_page ; fetch the symbol's page number
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; is first operand a symbol?
|
||
jne def_en_x ; if not a symbol, error (jump)
|
||
mov CX,BX ; place symbol pointer into CX:DX
|
||
mov DX,[DI].C_disp
|
||
; validate and load environment operand
|
||
mov BL,AH ; copy env register number to BX
|
||
mov SI,reg0_dis+[BX] ; load environment pointer into BX:SI
|
||
mov BL,byte ptr reg0_pag+[BX]
|
||
cmp byte ptr ptype+[BX],ENVTYPE*2 ; is it an envirnoment object?
|
||
je def_e_ok ; if an environment, jump
|
||
cmp BL,0 ; is it a nil pointer?
|
||
jne def_en_x ; if not nil, error (invalid operand; jump)
|
||
mov SI,FP ; load pointer to current stack frame
|
||
mov BL,S_stack+[SI].sf_hpage ; default environment to current
|
||
mov SI,word ptr S_stack+[SI].sf_hdisp ; environment
|
||
; search environment for the symbol
|
||
def_e_ok: pushm <BX,SI> ; save environment pointer on stack
|
||
call srch_all ; search all rib's
|
||
restore <AX> ; restore 2nd and 3rd operands
|
||
cmp BL,0 ; was symbol found?
|
||
je def_bind ; if not found, jump
|
||
LoadPage ES,BX ; load value cell page's paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; load value cell page's paragraph address
|
||
mov BL,AL ; copy value register number to BX
|
||
mov AL,byte ptr reg0_pag+[BX] ; set cdr of value cell to the
|
||
mov ES:[SI].cdr_page,AL ; contents of the value register
|
||
mov AX,reg0_dis+[BX]
|
||
mov ES:[SI].cdr,AX
|
||
jmp next_SP ; return to interpreter
|
||
|
||
; Symbol not found in environment -- bind it in given rib
|
||
def_bind: restore <DI> ; restore symbol register address
|
||
pop [BP].temp_reg.C_disp ; restore env pointer in local temp_reg
|
||
pop [BP].temp_reg.C_page
|
||
mov BL,AL ; compute value register address
|
||
add BX,offset reg0
|
||
lea SI,[BP].temp_reg ; load tmp_reg address
|
||
pushm <SI,BX,DI> ; push args to bind_it
|
||
call bind_it ; bind symbol in environment
|
||
jmp next_SP ; return to interpreter
|
||
|
||
;************************************************************************
|
||
;* Set Global Environment SET-GLOB-ENV! R(value) *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to initialize the Global *
|
||
;* Environment Register (GNV_reg). *
|
||
;************************************************************************
|
||
public set_gnv
|
||
set_gnv: lods byte ptr ES:[SI] ; load operand
|
||
mov DI,AX ; copy source register number to DI and
|
||
add DI,offset reg0 ; compute source/destination reg address
|
||
mov AX,[DI].C_disp ; load pointer to new global environment
|
||
mov BX,[DI].C_page
|
||
cmp byte ptr ptype+[BX],ENVTYPE*2 ;it's an environment, isn't it?
|
||
jne set_g_er ; if operand not env, error (jump)
|
||
xchg byte ptr GNV_pag,BL ; copy env pointer to GNV_reg
|
||
xchg GNV_dis,AX
|
||
mov byte ptr [DI].C_page,BL ; store previous value of GNV_reg
|
||
mov [DI].C_disp,AX ; into the destination register
|
||
jmp next ; return to interpreter
|
||
; ***error-- operand is not an environment object***
|
||
set_g_er: save <SI> ; save the location pointer
|
||
mov BX,offset m_setgnv ; load text for "set-global-env!"
|
||
jmp src_err ; display "source operand error" message
|
||
|
||
;************************************************************************
|
||
;* AL AH *
|
||
;* Load from Global Environment LD-GLOBAL R(d),C(s1) *
|
||
;* s1=symbol *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to retrieve values for symbols *
|
||
;* defined in the current global environment. *
|
||
;* *
|
||
;* Note: This instruction is an optimization of the LD-ENV operation. *
|
||
;* Here, the environment operand defaults to the current *
|
||
;* global environment, which is pointer to by GNV_reg. *
|
||
;************************************************************************
|
||
public ld_globl
|
||
ld_globl: lods word ptr ES:[SI] ; load operands
|
||
mov BL,AL ; copy the destintation register
|
||
mov DI,BX ; into TIPC register DI and compute
|
||
add DI,offset reg0 ; the destination register's address
|
||
save <SI,DI> ; save said, and the location pointer
|
||
; validate the symbol operand and load symbol pointer
|
||
mov BL,AH ; copy the constant number
|
||
mov SI,BX ; SI <- constant number * 3
|
||
shl SI,1
|
||
add SI,BX
|
||
add SI,CB_dis ; add in displacement of current code block
|
||
mov BL,ES:[SI].cod_cpag ; load symbol's page number
|
||
mov DX,ES:[SI].cod_cdis ; load symbol pointer into CX:DX
|
||
ld_gl_x: cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
|
||
jne ld_g_err ; if not a symbol, error (jump)
|
||
mov CX,BX
|
||
; load pointer to the global environment
|
||
mov BL,byte ptr GNV_pag
|
||
mov SI,GNV_dis
|
||
; search the global environment for the symbol-- test to see if found
|
||
pushm <CX,DX> ; save symbol pointer
|
||
call srch_all ; search global environment
|
||
restore <DI> ; reload destination register address
|
||
cmp BL,0 ; was symbol found?
|
||
je ld_g_nf ; if not found, error (jump)
|
||
; copy cdr field of value cell returned into the destination register
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov AL,ES:[SI].cdr_page ; copy cdr field of value cell
|
||
mov byte ptr [DI].C_page,AL ; into destination register
|
||
mov AX,ES:[SI].cdr
|
||
mov [DI].C_disp,AX
|
||
jmp next_SP ; return to interpreter
|
||
; ***error-- symbol operand wasn't a symbol pointer***
|
||
ld_g_err: mov BX,offset m_ld_gl ; load text for "ld-global"
|
||
jmp src_err ; display "invalid source operand" message
|
||
; ***error-- global symbol not found***
|
||
ld_g_nf: popm <DX,CX> ; restore symbol pointer
|
||
corrpage CX ; correct page number for call to C
|
||
mov AX,offset GNV_reg ; load address of global env register
|
||
pushm <DI,AX,DX,CX> ; push arguments for call
|
||
C_call sym_unde,,Load_ES ; call: sym_undefined(pg,ds,env,dest)
|
||
restore <SI> ; load next intstruction's offset and
|
||
sub SI,3 ; back up location pointer to retry load
|
||
jmp sch_err ; link to Scheme debugger
|
||
|
||
;************************************************************************
|
||
;* AL AH *
|
||
;* Load from Global Environment (reg operand) LD-GLOBAL-R R(d),R(s1) *
|
||
;* s1=symbol *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to retrieve values for symbols *
|
||
;* defined in the current global environment. *
|
||
;* *
|
||
;* Note: This instruction is an optimization of the LD-ENV operation. *
|
||
;* Here, the environment operand defaults to the current *
|
||
;* global environment, which is pointer to by GNV_reg. *
|
||
;************************************************************************
|
||
public ld_globr
|
||
ld_globr: lods word ptr ES:[SI] ; load operands
|
||
mov BL,AL ; copy the destintation register
|
||
mov DI,BX ; into TIPC register DI and compute
|
||
add DI,offset reg0 ; the destination register's address
|
||
save <SI,DI> ; save said, and the location pointer
|
||
; load symbol pointer
|
||
mov BL,AH ; copy the symbol's register number
|
||
mov DX,reg0_dis+[BX] ; load symbol's displacement
|
||
mov BL,byte ptr reg0_pag+[BX] ; load symbol's page number
|
||
jmp ld_gl_x ; continue process as ld-global
|
||
|
||
;************************************************************************
|
||
;* AL AH *
|
||
;* Define in Global Environment DEFINE! R(d=s1),C(s2) *
|
||
;* s1=value,s2=symbol *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to assign a variable in the *
|
||
;* current "global" environment. *
|
||
;* *
|
||
;* Note: This instruction is an optimization of the DEFINE-ENV *
|
||
;* operation. Here, the environment operand defaults to *
|
||
;* the current global environment, which is pointed to by *
|
||
;* GNV_reg. *
|
||
;************************************************************************
|
||
public define
|
||
define: lods word ptr ES:[SI] ; load operands
|
||
mov BL,AH ; copy constant number to BX
|
||
xor AH,AH
|
||
mov DI,AX ; copy value/destination register number
|
||
add DI,offset reg0 ; to DI and compute the register's address
|
||
save <SI,DI> ; save location pointer, dest reg address
|
||
; validate symbol operands and load it into CX:DX
|
||
mov SI,BX ; copy constant number into SI
|
||
shl SI,1
|
||
add SI,BX ; SI <- constant number * 3
|
||
add SI,CB_dis ; add starting offset of current code block
|
||
mov BL,ES:[SI].cod_cpag ; load symbol's page number
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
|
||
jne defb_err ; if not a symbol, error (jump)
|
||
mov CX,BX ; put symbol pointer into CX:DX
|
||
mov DX,ES:[SI].cod_cdis
|
||
pushm <CX,DX> ; save pointer to symbol
|
||
; load global environment pointer into BX:SI
|
||
mov BL,byte ptr GNV_pag
|
||
mov SI,GNV_dis
|
||
; search the global environment for the symbol-- test to see if found
|
||
call srch_env
|
||
cmp BL,0
|
||
je defb_new
|
||
; symbol was found-- set cdr of field returned to the value specified
|
||
restore <DI>
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov AL,byte ptr [DI].C_page
|
||
mov ES:[SI].cdr_page,AL
|
||
mov AX,[DI].C_disp
|
||
mov ES:[SI].cdr,AX
|
||
jmp next_SP ; return to interpreter
|
||
; symbol wasn't found-- create new binding in current global environment
|
||
defb_new: mov AX,SP ; get address of symbol
|
||
|
||
; In case you're wondering what just went on with the above instruction,
|
||
; the page and displacement of the symbol to be bound are residing in the
|
||
; correct order on the top of the stack. The "mov AX,SP" captures the
|
||
; address of said pointer so that it may be used as an argument to
|
||
; sym_bind, below.
|
||
|
||
mov BX,offset GNV_reg ; load GNV_reg address (contains env ptr)
|
||
pushm <BX,[BP].save_DI,AX> ; push sym,val,env register pointers
|
||
call bind_it ; create binding in global environment
|
||
jmp next_SP ; return to interpreter
|
||
; ***error-- symbol operand wasn't a symbol***
|
||
defb_err: mov BX,offset m_defb
|
||
jmp src_err
|
||
|
||
;************************************************************************
|
||
;* AL AH *
|
||
;* Define in Global Environment ST-GLOBAL R(d=s1),C(s2) *
|
||
;* s1=value,s2=symbol *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to assign a variable in the *
|
||
;* current "global" environment. *
|
||
;* *
|
||
;* Note: This instruction is an optimization of the ST-ENV *
|
||
;* operation. Here, the environment operand defaults to *
|
||
;* the current global environment, which is pointed to by *
|
||
;* GNV_reg. *
|
||
;************************************************************************
|
||
public st_globl
|
||
st_globl: lods word ptr ES:[SI] ; load operands
|
||
mov BL,AH ; copy constant number to BX
|
||
xor AH,AH
|
||
mov DI,AX ; copy value/destination register number
|
||
add DI,offset reg0 ; to DI and compute the register's address
|
||
save <SI,DI> ; save location pointer, dest reg address
|
||
; validate symbol operands and load it into CX:DX
|
||
mov SI,BX ; copy constant number into SI
|
||
shl SI,1
|
||
add SI,BX ; SI <- constant number * 3
|
||
add SI,CB_dis ; add starting offset of current code block
|
||
mov BL,ES:[SI].cod_cpag ; load symbol's page number
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; it is a symbol, isn't it?
|
||
jne st_gl_er ; if not a symbol, error (jump)
|
||
mov CX,BX ; put symbol pointer into CX:DX
|
||
mov DX,ES:[SI].cod_cdis
|
||
pushm <CX,DX> ; save pointer to symbol
|
||
; load global environment pointer into BX:SI
|
||
mov BL,byte ptr GNV_pag
|
||
mov SI,GNV_dis
|
||
; search the global environment for the symbol-- test to see if found
|
||
call srch_all
|
||
restore <DI>
|
||
cmp BL,0
|
||
je st_gl_nf
|
||
; symbol was found-- set cdr of field returned to the value specified
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov AL,byte ptr [DI].C_page
|
||
mov ES:[SI].cdr_page,AL
|
||
mov AX,[DI].C_disp
|
||
mov ES:[SI].cdr,AX
|
||
jmp next_SP ; return to interpreter
|
||
; symbol wasn't found-- inquire from user as to what to do
|
||
st_gl_nf: popm <DX,CX> ; restore pointer to symbol
|
||
corrpage CX ; adjust page number for C call
|
||
pushm <DI,DX,CX> ; push page, disp, value reg address
|
||
C_call not_glob,,load_ES ; resolve error situation
|
||
restore <SI> ; load next instruction's offset and back
|
||
sub SI,3 ; location pointer up to retry the store
|
||
jmp sch_err ; link to Scheme debugger
|
||
; ***error-- invalid operand to st-global***
|
||
st_gl_er: mov BX,offset m_st_gl
|
||
jmp src_err
|
||
|
||
;************************************************************************
|
||
;* Environment Predicate ENV? object *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to test for an environment *
|
||
;* data object. *
|
||
;************************************************************************
|
||
public env_p
|
||
env_p: lods byte ptr ES:[SI] ; load the operand
|
||
mov DI,AX ; and copy into TIPC register DI
|
||
mov BX,reg0_pag+[DI] ; load the operand's page number
|
||
cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment?
|
||
je env_t ; if an environment object, jump
|
||
; object not an env-- return a value of nil in the destination register
|
||
mov byte ptr reg0_pag+[DI],NIL_PAGE*2
|
||
mov reg0_dis+[DI],NIL_DISP*2
|
||
jmp next ; return to interpreter
|
||
; object is an env-- return a value of 't in the destination register
|
||
env_t: mov byte ptr reg0_pag+[DI],T_PAGE*2
|
||
mov reg0_dis+[DI],T_DISP*2
|
||
jmp next ; return to interpreter
|
||
|
||
;************************************************************************
|
||
;* Make Environment MK-ENV dest *
|
||
;* *
|
||
;* Purpose: Scheme interpreter support to return a pointer to the *
|
||
;* current environment. *
|
||
;************************************************************************
|
||
public mk_env
|
||
mk_env: lods byte ptr ES:[SI] ; load destination register number
|
||
mov DI,AX ; and put it in TIPC register DI
|
||
mov BX,FP ; load the current stack frame pointer
|
||
mov AL,S_stack+[BX].sf_hpage ; load current env pointer from stack
|
||
mov byte ptr reg0_pag+[DI],AL; and put in destination register
|
||
mov AX,word ptr S_stack+[BX].sf_hdisp
|
||
mov reg0_dis+[DI],AX
|
||
jmp next ; return to interpreter
|
||
|
||
;************************************************************************
|
||
;* Environment Parent ENV-PARENT env *
|
||
;* *
|
||
;* Purpose: Scheme interpreter return the "parent" of a given *
|
||
;* environment. *
|
||
;************************************************************************
|
||
public env_par
|
||
env_par: lods byte ptr ES:[SI] ; load the environment operand
|
||
save <SI> ; save the current location pointer
|
||
mov DI,AX ; copy operand register number to DI
|
||
mov BX,reg0_pag+[DI] ; load operand's page number
|
||
cmp byte ptr ptype+[BX],ENVTYPE*2 ; is operand an environment?
|
||
jne env_p_er ; if not an environment, error (jump)
|
||
mov SI,reg0_dis+[DI] ; load pointer to environment object
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov AL,ES:[SI].env_ppag ; load parent pointer from env object
|
||
mov byte ptr reg0_pag+[DI],AL ; and put in destination register
|
||
mov AX,ES:[SI].env_pdis
|
||
mov reg0_dis+[DI],AX
|
||
jmp next_PC ; return to interpreter
|
||
; ***error-- invalid operand***
|
||
env_p_er: lea BX,m_en_par ; load text addr for "environment-parent"
|
||
jmp src_err ; display "invalid source operand" message
|
||
|
||
;************************************************************************
|
||
;* Lookup In Environment ENV-LU R(d=s1),R(s2) *
|
||
;* s1=symbol,s2=env *
|
||
;************************************************************************
|
||
public env_lu
|
||
env_lu: lods word ptr ES:[SI] ; load operands
|
||
; fetch and validate first operand (symbol pointer)
|
||
xor BH,BH
|
||
mov BL,AL
|
||
mov DI,BX
|
||
add DI,offset reg0
|
||
save <SI,DI> ; save location pointer; dest reg address
|
||
mov CX,[DI].C_page ; copy symbol pointer into CX:DX
|
||
mov DX,[DI].C_disp
|
||
mov BX,CX ; test to make sure that first operand
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; is a symbol
|
||
jne env_lu_x ; if not a symbol, error (jump)
|
||
; fetch and validate second operand (environment pointer)
|
||
mov BL,AH ; copy env register number
|
||
mov SI,reg0_dis+[BX] ; copy environment pointer into BX:SI
|
||
mov BL,byte ptr reg0_pag+[BX]
|
||
cmp byte ptr ptype+[BX],ENVTYPE*2 ; it is an env, isn't it?
|
||
jne env_lu_x ; if operand not environment, error (jump)
|
||
; search the environment for the symbol
|
||
call srch_all ; search all ribs
|
||
; store result of search into destination register
|
||
restore <DI> ; reload the destination register address
|
||
mov byte ptr [DI].C_page,BL
|
||
mov [DI].C_disp,SI
|
||
jmp next_PC ; return to interpreter
|
||
; ***error-- invalid operand***
|
||
env_lu_x: mov BX,offset m_env_lu
|
||
jmp src_err
|
||
|
||
s_env endp
|
||
|
||
;************************************************************************
|
||
;* Local Support - Search Environment (all of it) *
|
||
;* *
|
||
;* Input Parameters: CX:DX - search symbol *
|
||
;* BX:SI - environment chain pointer *
|
||
;* *
|
||
;* Output Parameters: BX:SI - value cell for symbol *
|
||
;************************************************************************
|
||
srch_all proc near
|
||
pushm <BX,SI,CX,DX> ; save pointer to current rib
|
||
call srch_env ; search rib for desired symbol
|
||
cmp BX,0 ; was symbol found?
|
||
jne srch_ok ; if symbol found, jump
|
||
popm <DX,CX,SI,BX> ; restore pointer to current rib
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX] ; load pointer to parent rib
|
||
mov BL,ES:[SI].env_ppag
|
||
mov SI,ES:[SI].env_pdis
|
||
cmp BX,0 ; does parent rib exist?
|
||
jne srch_all ; if no parent, symbol not found (jump)
|
||
jmp short srch_nok
|
||
srch_ok: add SP,WORDINCR*4 ; dump env pointer off stack
|
||
srch_nok: ret ; return search result to caller
|
||
srch_all endp
|
||
|
||
;************************************************************************
|
||
;* Local Support - Search Environment (one rib) *
|
||
;* *
|
||
;* Input Parameters: CX:DX - search symbol *
|
||
;* BX:SI - environment chain pointer *
|
||
;* *
|
||
;* Output Parameters: BX:SI - value cell for symbol *
|
||
;************************************************************************
|
||
srch_env proc near
|
||
LoadPage ES,BX ; load paragraph address of env chain
|
||
;;; mov ES,pagetabl+[BX] ; load paragraph address of env chain
|
||
cmp ES:[SI].env_len,ENV_SIZE ; hash table or "rib"?
|
||
jne srch_ht ; if hash table, jump
|
||
pushm <BX,SI> ; save pointer to environment
|
||
;;;; pushm <ES,SI> ; save pointer to environment
|
||
mov AX,1 ; initialize counter
|
||
xor BX,BX
|
||
mov BL,ES:[SI].env_npag ; load pointer to list of symbols
|
||
mov SI,ES:[SI].env_ndis
|
||
srch_mor: cmp BL,0 ; more symbols in this rib?
|
||
je srch_nf ; if end of symbol list, jump
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
cmp DX,ES:[SI].car ; is symbol disp eq to this entry?
|
||
jne srch_nxt ; if no match, jump
|
||
cmp CL,ES:[SI].car_page ; is page number eq?
|
||
je srch_fnd ; if symbol's page number eq, jump
|
||
srch_nxt: inc AX ; increment symbol count
|
||
mov BL,ES:[SI].cdr_page ; follow cdr field of linked list
|
||
mov SI,ES:[SI].cdr
|
||
jmp short srch_mor ; loop
|
||
srch_fnd: mov CX,AX ; move counter symbol counter to CX
|
||
popm <SI,BX> ; recover pointer to environment chain
|
||
LoadPage ES,BX
|
||
;;;; popm <SI,ES> ; recover pointer to environment chain
|
||
mov BL,ES:[SI].env_vpag ; load pointer to value list
|
||
mov SI,ES:[SI].env_vdis
|
||
jmp short srch_f1
|
||
srch_lp: LoadPage ES,BX ; follow chain through car field of linked
|
||
;;; mov ES,pagetabl+[BX] ; follow chain through car field of linked
|
||
mov BL,ES:[SI].car_page ; list
|
||
mov SI,ES:[SI].car
|
||
srch_f1: loop srch_lp ; not value entry for symbol, loop (jump)
|
||
ret ; return to caller
|
||
; symbol not found-- return nil
|
||
srch_nf: add SP,WORDINCR*2 ; drop env pointer off stack
|
||
ret ; return to caller
|
||
;
|
||
; Hash Table Rib Format
|
||
;
|
||
srch_ht: pushm <BX,SI> ; save arguments to srch_env
|
||
mov lcl_page,CX ; store symbol pointer in tmp_reg
|
||
mov lcl_disp,DX
|
||
mov AX,offset lcl_reg ; load address of lcl_reg and push
|
||
push AX ; it as an argument to sym_hash
|
||
call sym_hash ; get the hash value for the symbol
|
||
add SP,WORDINCR ; drop the argument off the stack
|
||
cmp AX,HT_SIZE ; valid hash value returned?
|
||
jae srch_htx ; if not valid, error (jump)
|
||
; fetch symbol chain from indicated hash table bucket
|
||
popm <SI,BX> ; restore pointer to environment object
|
||
add SI,AX ; env-ptr += hash-value * 3
|
||
shl AX,1
|
||
add SI,AX
|
||
LoadPage ES,BX ; load environment page's paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; load environment page's paragraph address
|
||
mov BL,ES:[SI].env_npag ; load pointer to hash chain
|
||
cmp BL,0 ; is chain empty?
|
||
je srch_nfx ; if chain is empty, symbol not found (jump)
|
||
mov SI,ES:[SI].env_ndis
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
mov DX,lcl_page ; restore symbol pointer into DX:AX
|
||
mov AX,lcl_disp
|
||
call lookup ; search for symbol in linked list
|
||
mov SI,DI ; put pointer returned in BX:SI
|
||
ret ; return to caller
|
||
; ***error-- symbol operand wasn't a symbol***
|
||
srch_htx: add SP,WORDINCR*2 ; drop saved arguments off stack
|
||
xor BX,BX ; return a nil pointer
|
||
srch_nfx: xor SI,SI
|
||
ret
|
||
srch_env endp
|
||
|
||
;************************************************************************
|
||
;* Symbol Binding Routine *
|
||
;* *
|
||
;* Purpose: Lattice C callable routine to return the bind a value to *
|
||
;* a symbol in a given environment. *
|
||
;* *
|
||
;* Calling Sequence: sym_bind(symbol, value, environment) *
|
||
;* where symbol - register containing the symbol *
|
||
;* pointer *
|
||
;* value - register containing the value to *
|
||
;* be assigned *
|
||
;* environment - register containing a pointer to *
|
||
;* the environment in which the *
|
||
;* binding is to take place *
|
||
;************************************************************************
|
||
bind_arg struc
|
||
dw ? ; caller's BP
|
||
dw ? ; caller's ES
|
||
dw ? ; return address
|
||
bnd_sym dw ? ; address of symbol register
|
||
bnd_val dw ? ; address of value register
|
||
bnd_env dw ? ; address of environment register
|
||
bind_arg ends
|
||
|
||
public sym_bind
|
||
bind_it proc near
|
||
push ES ; save the caller's ES register
|
||
push BP ; save the caller's BP register
|
||
mov BP,SP ; establish addressability for local data
|
||
jmp sb_new ; bind symbol in current environment
|
||
|
||
sym_bind: push ES ; save the caller's ES register
|
||
push BP ; save the caller's BP register
|
||
mov BP,SP ; establish addressability for local data
|
||
|
||
; see if symbol is already present in the environment
|
||
mov BX,[BP].bnd_sym ; load address of symbol register
|
||
mov CX,[BX].C_page ; load symbol pointer into CX:DX
|
||
mov DX,[BX].C_disp
|
||
mov BX,[BP].bnd_env ; load address of environment register
|
||
mov SI,[BX].C_disp ; load environment pointer into BX:SI
|
||
mov BX,[BX].C_page
|
||
call srch_all ; search the environment for the symbol
|
||
cmp BL,0 ; was the symbol found in the environment?
|
||
je sb_new ; if symbol not found, jump
|
||
; store the value into the cdr field of the returned value cell
|
||
LoadPage ES,BX ; load value cell's paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address
|
||
mov BX,[BP].bnd_val ; load address of value register
|
||
mov AL,byte ptr [BX].C_page ; copy value from value register
|
||
mov ES:[SI].cdr_page,AL ; into the cdr field of the value cell
|
||
mov AX,[BX].C_disp
|
||
mov ES:[SI].cdr,AX
|
||
jmp sb_ret ; return to caller
|
||
|
||
; fetch pointer to environment-- decide format of said
|
||
sb_new: mov SI,[BP].bnd_env
|
||
mov BX,[SI].C_page
|
||
mov SI,[SI].C_disp
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX]
|
||
cmp ES:[SI].env_len,ENV_SIZE
|
||
jne sb_ht
|
||
;
|
||
; bind symbol to "rib" format environment
|
||
;
|
||
; cons(env[name], symbol, env[name])
|
||
mov AL,ES:[SI].env_npag ; copy name list chain from environment
|
||
mov byte ptr tmp_page,AL ; object to tmp_reg
|
||
mov AX,ES:[SI].env_ndis
|
||
mov tmp_disp,AX
|
||
mov AX,offset tmp_reg
|
||
pushm <AX,[BP].bnd_sym,AX> ; push arguments to "cons"
|
||
call cons ; cons symbol to front of name list
|
||
mov BX,[BP].bnd_env ; reload pointer to environment object
|
||
mov SI,[BX].C_disp ; (it may have been relocated during the
|
||
mov BX,[BX].C_page ; consing operation)
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX] ;
|
||
mov AL,byte ptr tmp_page ; update name list pointer in the
|
||
mov ES:[SI].env_npag,AL ; environment object
|
||
mov AX,tmp_disp
|
||
mov ES:[SI].env_ndis,AX
|
||
; cons(env[value], env[value], value)
|
||
mov AL,ES:[SI].env_vpag ; copy value list chain from environment
|
||
mov byte ptr tmp_page,AL ; object to tmp_reg
|
||
mov AX,ES:[SI].env_vdis
|
||
mov tmp_disp,AX
|
||
mov AX,offset tmp_reg
|
||
pushm <[BP].bnd_val,AX,AX> ; push arguments to "cons"
|
||
call cons ; cons value to front of value list
|
||
mov BX,[BP].bnd_env ; reload pointer to environment object
|
||
mov SI,[BX].C_disp ; (it may have been relocated during the
|
||
mov BX,[BX].C_page ; consing operation)
|
||
LoadPage ES,BX
|
||
;;; mov ES,pagetabl+[BX] ;
|
||
mov AL,byte ptr tmp_page ; update value list pointer in the
|
||
mov ES:[SI].env_vpag,AL ; environment object
|
||
mov AX,tmp_disp
|
||
mov ES:[SI].env_vdis,AX
|
||
jmp sb_ret ; return to caller
|
||
;
|
||
; bind symbol to "hash table" format environment
|
||
;
|
||
sb_ht:
|
||
; cons(tmp_reg, symbol, value)
|
||
mov AX,offset tmp_reg ; load address of tmp_reg
|
||
mov BX,offset nil_reg ; load address of nil_reg
|
||
; Note: we're pushing the arguments for both calls to "cons" in the
|
||
; following statement
|
||
pushm <BX,AX,AX,[BP].bnd_val,[BP].bnd_sym,AX> ; push args to cons
|
||
call cons
|
||
add SP,3*WORDINCR ; drop the top three arguments from the stack
|
||
; cons(tmp_reg, tmp_reg, nil_reg)
|
||
call cons
|
||
; obtain hash value for the symbol
|
||
push [BP].bnd_sym
|
||
call sym_hash
|
||
mov BX,AX ; multiply hash value by 3
|
||
shl AX,1
|
||
add BX,AX
|
||
mov SI,[BP].bnd_env ; load pointer to environment object
|
||
add BX,[SI].C_disp ; (which may have been moved during
|
||
mov SI,[SI].C_page ; the consing operations)
|
||
LoadPage ES,SI
|
||
;;; mov ES,pagetabl+[SI]
|
||
mov AX,tmp_page ; load pointer to second list cell
|
||
mov SI,AX
|
||
xchg AL,ES:[BX].env_npag ; swap list header in environment hash
|
||
mov DX,tmp_disp ; table with the pointer to the second
|
||
mov DI,DX ; list cell
|
||
xchg DX,ES:[BX].env_ndis
|
||
LoadPage ES,SI ; load pointer to second list cell
|
||
;;; mov ES,pagetabl+[SI] ; load pointer to second list cell
|
||
mov ES:[DI].cdr_page,AL ; update entry in environment hash table
|
||
mov ES:[DI].cdr,DX
|
||
|
||
; return to calling procedure
|
||
sb_ret: mov SP,BP ; clean up the TIPC's stack
|
||
pop BP ; restore caller's BP
|
||
pop ES ; restore caller's ES, too
|
||
ret ; return to caller
|
||
bind_it endp
|
||
|
||
;************************************************************************
|
||
;* Symbol Lookup Routine *
|
||
;* *
|
||
;* Purpose: Lattice C callable routine to return the value bound to *
|
||
;* a symbol in a given environment. *
|
||
;* *
|
||
;* Calling Sequence: sym_bind(symbol, environment) *
|
||
;* where symbol - register containing the symbol *
|
||
;* pointer *
|
||
;* environment - register containing a pointer to *
|
||
;* the environment to be searched *
|
||
;************************************************************************
|
||
look_arg struc
|
||
dw ? ; caller's BP
|
||
dw ? ; caller's ES
|
||
dw ? ; return address
|
||
look_sym dw ? ; address of symbol register
|
||
look_env dw ? ; address of environment register
|
||
look_arg ends
|
||
|
||
public sym_look
|
||
sym_look proc near
|
||
push ES ; save the caller's ES register
|
||
push BP ; save the caller's BP register
|
||
mov BP,SP ; establish addressability for local data
|
||
|
||
; see if symbol is already present in the environment
|
||
mov BX,[BP].look_sym ; load address of symbol register
|
||
mov CX,[BX].C_page ; load symbol pointer into CX:DX
|
||
mov DX,[BX].C_disp
|
||
mov BX,[BP].look_env ; load address of environment register
|
||
mov SI,[BX].C_disp ; load environment pointer into BX:SI
|
||
mov BX,[BX].C_page
|
||
call srch_all ; search the environment for the symbol
|
||
xor AX,AX ; set result to false, in case search failed
|
||
cmp BL,0 ; was the symbol found in the environment?
|
||
je look_ret ; if symbol not found, jump
|
||
; return the value in the cdr field in the argument register
|
||
LoadPage ES,BX ; load value cell's paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; load value cell's paragraph address
|
||
mov BX,[BP].look_sym ; load address of register
|
||
mov AL,ES:[SI].cdr_page ; copy current binding into the
|
||
mov byte ptr [BX].C_page,AL ; argument register
|
||
mov AX,ES:[SI].cdr
|
||
mov [BX].C_disp,AX
|
||
mov AX,1 ; set result to "TRUE"
|
||
; return to calling procedure
|
||
look_ret: pop BP ; restore caller's BP
|
||
pop ES ; restore caller's ES, too
|
||
ret ; return to caller
|
||
sym_look endp
|
||
|
||
;************************************************************************
|
||
;* Symbol Hashing Routine *
|
||
;* *
|
||
;* Purpose: Lattice C callable routine to return the hash value for *
|
||
;* a given symbol. *
|
||
;* *
|
||
;* Calling Sequence: hash = sym_hash(reg) *
|
||
;* reg - register containing symbol pointer *
|
||
;* hash - the hash value (if page/disp don't point *
|
||
;* to a symbol, -1 is returned) *
|
||
;* *
|
||
;* Methods Used: The hash value is computed by summing the characters *
|
||
;* of the symbol and returning the remainder on division *
|
||
;* by the length of the hash table (HT_SIZE). *
|
||
;* *
|
||
;* Note: This routine must return the same hash value as the routine *
|
||
;* "hash" in SUPPORT.C. If the hashing algorithm is *
|
||
;* changed, it must be changed in both routines. *
|
||
;************************************************************************
|
||
sh_args struc
|
||
dw ? ; caller's BP
|
||
dw ? ; return address
|
||
sh_reg dw ? ; symbol pointer register address
|
||
sh_args ends
|
||
|
||
public sym_hash
|
||
sym_hash proc near
|
||
push BP ; save caller's BP
|
||
mov BP,SP
|
||
; Fetch pointer to symbol-- make sure object is a symbol
|
||
mov DI,[BP].sh_reg ; load register address
|
||
mov BX,[DI].C_page ; load symbol's page number
|
||
cmp byte ptr ptype+[BX],SYMTYPE*2 ; is object a symbol?
|
||
jne sh_error ; if not a symbol, error (jump)
|
||
push ES ; save caller's ES
|
||
LoadPage ES,BX ; load symbol page's paragraph address
|
||
;;; mov ES,pagetabl+[BX] ; load symbol page's paragraph address
|
||
mov SI,[DI].C_disp ; load symbol's displacement
|
||
; Fetch hash value from symbol object
|
||
xor AH,AH ; clear high order byte of AX
|
||
mov AL,ES:[SI].sym_hkey ; fetch hash key
|
||
; Return value in TIPC register AX
|
||
pop ES ; restore caller's ES
|
||
sh_ret: pop BP ; restore caller's BP
|
||
ret ; return
|
||
; ***error-- input argument wasn't a symbol pointer***
|
||
sh_error: mov AX,-1 ; return a hash value of -1
|
||
jmp short sh_ret ; return invalid hash value
|
||
sym_hash endp
|
||
|
||
prog ends
|
||
end
|
||
|