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