;							=====> 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