;							=====> SSTRING.ASM
;************************************************************************
;*     		     TIPC Scheme  Runtime Support    			*
;*   		   Interpreter -- String Operations  			*
;*				       					*
;*    	(C) Copyright 1985 by Texas Instruments Incorporated.       	*
;*	  		All rights reserved.	       			*
;*				       					*
;* Date Written:  18 January 1985      					*
;* Last Modification:		       					*
;*  4/27/88 (tc) - removed case conversion from characters in the range *
;*		   of 128 through 167 (see locases, hicases, collate).  *
;*		   Our previous assumptions did not work for some inter-*
;*		   national character sets.				*
;************************************************************************
	  include scheme.equ
	  include sinterp.mac

	  include sinterp.arg

DGROUP	  group   data
data	  segment word public 'DATA'
	  assume  DS:DGROUP

;     Local data definitions
m_ch_eq   db	  "CHAR=?",0
m_ceq_ci  db	  "CHAR-CI=?",0
m_ch_lt   db	  "CHAR<?",0
m_chl_ci  db	  "CHAR-CI<?",0
m_ch_up   db	  "CHAR-UPCASE",0
m_ch_dwn  db	  "CHAR-DOWNCASE",0
m_mk_str  db	  "MAKE-STRING",0
m_st_fl   db	  "FILL-STRING!",0
m_st_ref  db	  "STRING-REF",0
m_st_set  db	  "STRING-SET!",0
m_one	  dw	  1		   ; a constant "one" (1)
m_two	  dw	  2		   ; a constant "two" (2)
m_soff	  dw	  STRING_OFFSET_ERROR ; error code

;     Case tables (for characters between 40h and 0bfh)
	  public  locases,hicases,collate

locases   db	  000,001,002,003,004,005,006,007
	  db	  008,009,010,011,012,013,014,015
	  db	  016,017,018,019,020,021,022,023
	  db	  024,025,026,027,028,029,030,031
	  db	  " ","!",'"',"#","$","%","&","'"
	  db	  "(",")","*","+",",","-",".","/"
	  db	  "0","1","2","3","4","5","6","7"
	  db	  "8","9",":",";","<","=",">","?"

	  db	  "@","a","b","c","d","e","f","g"
	  db	  "h","i","j","k","l","m","n","o"
	  db	  "p","q","r","s","t","u","v","w"
	  db	  "x","y","z","[","\","]","^","_"
	  db	  "`","a","b","c","d","e","f","g"
	  db	  "h","i","j","k","l","m","n","o"
	  db	  "p","q","r","s","t","u","v","w"
	  db	  "x","y","z","{","|","}","~",127
						  ; C   ..  '   ^   ..  `   o   c
						  ; '   u   e   a   a   a   a   '
	  db	  128,129,130,131,132,133,134,135 ;135,129,130,131,132,133,134,135
						  ; ^   ..  `   ..  ^   `   ..  o
						  ; e   e   e   i   i   i   A   A
	  db	  136,137,138,139,140,141,142,143 ;136,137,138,139,140,141,132,134
						  ; '           ^   ..  `   ^   `
						  ; E   ae  AE  o   o   o   u   u
	  db	  144,145,146,147,148,149,150,151 ;130,145,145,147,148,149,150,151
						  ; ..  ..  ..
						  ; y   O   U   (currency symbols)
	  db	  152,153,154,155,156,157,158,159 ;152,148,129,155,156,157,158,159
						  ; '   '   '   '   ~   ~
						  ; a   i   o   u   n   N
	  db	  160,161,162,163,164,165,166,167 ;160,161,162,163,164,164,166,167
	  db	  168,169,170,171,172,173,174,175
	  db	  176,177,178,179,180,181,182,183
	  db	  184,185,186,187,188,189,190,191

	  db	  192,193,194,195,196,197,198,199
	  db	  200,201,202,203,204,205,206,207
	  db	  208,209,210,211,212,213,214,215
	  db	  216,217,218,219,220,221,222,223
;		      beta
	  db	  224,225,226,227,228,229,230,231
	  db	  232,233,234,235,236,237,238,239
	  db	  240,241,242,243,244,245,246,247
	  db	  248,249,250,251,252,253,254,255

hicases   db	  000,001,002,003,004,005,006,007
	  db	  008,009,010,011,012,013,014,015
	  db	  016,017,018,019,020,021,022,023
	  db	  024,025,026,027,028,029,030,031
	  db	  " ","!",'"',"#","$","%","&","'"
	  db	  "(",")","*","+",",","-",".","/"
	  db	  "0","1","2","3","4","5","6","7"
	  db	  "8","9",":",";","<","=",">","?"

	  db	  "@","A","B","C","D","E","F","G"
	  db	  "H","I","J","K","L","M","N","O"
	  db	  "P","Q","R","S","T","U","V","W"
	  db	  "X","Y","Z","[","\","]","^","_"
	  db	  "`","A","B","C","D","E","F","G"
	  db	  "H","I","J","K","L","M","N","O"
	  db	  "P","Q","R","S","T","U","V","W"
	  db	  "X","Y","Z","{","|","}","~",127
						  ; C   ..  '   ^   ..  `   o   c
						  ; '   u   e   a   a   a   a   '
	  db	  128,129,130,131,132,133,134,135 ;128,154,144,"A",142,"A",143,128
						  ; ^   ..  `   ..  ^   `   ..  o
						  ; e   e   e   i   i   i   A   A
	  db	  136,137,138,139,140,141,142,143 ;"E","E","E","I","I","I",142,143
						  ; '           ^   ..  `   ^   `
						  ; E   ae  AE  o   o   o   u   u
	  db	  144,145,146,147,148,149,150,151 ;144,146,146,"O",153,"O","U","U"
		  				  ;..  ..  ..
		   				  ; y   O   U   (currency symbols)
	  db	  152,153,154,155,156,157,158,159 ;"Y",153,154,155,156,157,158,159
		   				  ; '   '   '   '   ~   ~
		   				  ; a   i   o   u   n   N
	  db	  160,161,162,163,164,165,166,167 ;"A","I","O","U",165,165,166,167
	  db	  168,169,170,171,172,173,174,175
	  db	  176,177,178,179,180,181,182,183
	  db	  184,185,186,187,188,189,190,191

	  db	  192,193,194,195,196,197,198,199
	  db	  200,201,202,203,204,205,206,207
	  db	  208,209,210,211,212,213,214,215
	  db	  216,217,218,219,220,221,222,223
;		      beta
	  db	  224,225,226,227,228,229,230,231
	  db	  232,233,234,235,236,237,238,239
	  db	  240,241,242,243,244,245,246,247
	  db	  248,249,250,251,252,253,254,255

collate   db	  000,001,002,003,004,005,006,007
	  db	  008,009,010,011,012,013,014,015
	  db	  016,017,018,019,020,021,022,023
	  db	  024,025,026,027,028,029,030,031
	  db	  " ","!",'"',"#","$","%","&","'"
	  db	  "(",")","*","+",",","-",".","/"
	  db	  "0","1","2","3","4","5","6","7"
	  db	  "8","9",":",";","<","=",">","?"

	  db	  "@","A","B","C","D","E","F","G"
	  db	  "H","I","J","K","L","M","N","O"
	  db	  "P","Q","R","S","T","U","V","W"
	  db	  "X","Y","Z","[","\","]","^","_"
	  db	  "`","a","b","c","d","e","f","g"
	  db	  "h","i","j","k","l","m","n","o"
	  db	  "p","q","r","s","t","u","v","w"
	  db	  "x","y","z","{","|","}","~",127
		   				  ; C   ..  '   ^   ..  `   o   c
		   				  ; '   u   e   a   a   a   a   '
	  db	  128,129,130,131,132,133,134,135 ;"C","u","e","a","a","a","a","c"
		   				  ; ^   ..  `   ..  ^   `   ..  o
		   				  ; e   e   e   i   i   i   A   A
	  db	  136,137,138,139,140,141,142,143 ;"e","e","e","i","i","i","A","A"
		   				  ; '           ^   ..  `   ^   `
		   				  ; E   ae  AE  o   o   o   u   u
	  db	  144,145,146,147,148,149,150,151 ;"E","a","A","o","o","o","u","u"
		   				  ; ..  ..  ..
		   				  ;y   O   U   (currency symbols)
	  db	  152,153,154,155,156,157,158,159 ;"y","O","U","$","$","$","$","$"
				   		  ; '   '   '   '   ~   ~
		   				  ; a   i   o   u   n   N
	  db	  160,161,162,163,164,165,166,177 ;"a","i","o","u","n","N",166,167
	  db	  168,169,170,171,172,173,174,175 ;"?",169,170,171,172,"!",'"','"'
	  db	  176,177,178,179,180,181,182,183
	  db	  184,185,186,187,188,189,190,191

	  db	  192,193,194,195,196,197,198,199
	  db	  200,201,202,203,204,205,206,207
	  db	  208,209,210,211,212,213,214,215
	  db	  216,217,218,219,220,221,222,223
;		      beta
	  db	  224,"s",226,227,228,229,230,231
	  db	  232,233,234,235,236,237,238,239
	  db	  240,241,242,243,244,245,246,247
	  db	  248,249,250,251,252,253,254,255

data	  ends


PGROUP	  group   prog
prog	  segment byte public 'PROG'
	  assume  CS:PGROUP

str_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 print routine
	  extrn   sch_err:near	   ; link to Scheme debugger

char_cmp  macro   comparison,case,operation
	  local   w,x,y,z
	  lods	  word ptr ES:[SI] ; load operands
	  xor	  BX,BX
	  mov	  BL,AL 	   ; copy the destination=source1 register
	  mov	  DI,BX 	   ;  number, copy into DI, and compute
	  add	  DI,offset reg0   ;  the register's address
	  mov	  BL,AH 	   ; copy the source2 register number
	  mov	  AL,byte ptr reg0_pag+[BX] ; load tag of src2 operand
	  cmp	  AL,SPECCHAR*2    ; is source2 a character?
	  jne	  z		   ; if not, error (jump)
	  cmp	  AL,byte ptr [DI].C_page ; is source1 a character?
	  jne	  z		   ; if not, error (jump)
IFIDN	  <case>,<CI>
	  mov	  AL,byte ptr reg0_dis+[BX] ; move character value of source2
	  mov	  BX,offset locases  ; Fetch lower-case equivalents
	  xlat
	  mov	  AH,AL 	   ; Save equivalent in AH
	  mov	  AL,byte ptr[DI].C_disp    ; move char value of source1
	  xlat			   ; Fetch lower-case eqivalent
ELSE
	  mov	  AL,byte ptr [DI].C_disp   ; Fetch characters
	  mov	  AH,byte ptr reg0_dis+[BX]
ENDIF
	  mov	  BX,offset collate ; Get collation values of chars
	  xlat
	  xchg	  AL,AH
	  xlat
	  cmp	  AH,AL 	   ; Compare
	  j&comparison	  y	   ; jump, if test is satisfied
	  xor	  AX,AX 	   ; place 'nil in destination
	  mov	  byte ptr [DI].C_page,AL ;  register
	  mov	  [DI].C_disp,AX
	  jmp	  next		   ; return to interpreter
y:	  mov	  byte ptr [DI].C_page,T_PAGE*2 ; place 't in
	  mov	  [DI].C_disp,T_DISP ;	destination register
	  jmp	  next		   ; return to interpreter
;     ***error-- one (or both) operands aren't characters***
z:	  mov	  AX,offset operation
IFIDN	  <operation>,<m_ch_eq>
error_2:  add	  BX,offset reg0   ; compute address of source 2
	  pushm	  <BX,DI,m_two,AX> ; push source 2, source 1, operation name
	  C_call  set_src_,<SI>,Load_ES ; call:  set_source_error
	  jmp	  sch_err	   ; link to Scheme debugger
ELSE
	  jmp	  error_2
ENDIF
	  endm


;************************************************************************
;*							       AL   AH	*
;* (char-= char1 char2) 			  char-=       dest,src *
;*									*
;* Purpose:  Scheme interpreter support for comparing the equality of	*
;*		character data objects. 				*
;*									*
;* Description:  The tags (page numbers) or the objects are compared	*
;*		for equality.  If they are not equal, at least one of	*
;*		the operands is not a character, and an error is	*
;*		signaled.  If they are equal, a second check to make	*
;*		sure both are characters is performed.			*
;*									*
;*		After validating the tag fields, the displacement fields*
;*		are compared for equality.  If they are identical, the	*
;*		characters are equal and 't is returned in the destina- *
;*		tion register.	If not equal, 'nil is returned in the   *
;*		destination register.					*
;************************************************************************
	  public  ch_eq_p
ch_eq_p:  char_cmp e,CS,m_ch_eq

;************************************************************************
;*							       AL   AH	*
;* (char-equal? char1 char2)			char-eq?       dest,src *
;*									*
;* Purpose:  Scheme interpreter support for comparing the equality of	*
;*		character data objects ignoring case.			*
;*									*
;* Description:  The tags (page numbers) or the objects are compared	*
;*		for equality.  If they are not equal, at least one of	*
;*		the operands is not a character, and an error is	*
;*		signaled.  If they are equal, a second check to make	*
;*		sure both are characters is performed.			*
;*									*
;*		The displacements of both operands are loaded and	*
;*		mapped to uppercase.  They are then compared for	*
;*		equality.  If equal, 't is returned in the destination  *
;*		registers.  Otherwise, 'nil is returned.                *
;************************************************************************
	  public  ch_eq_ci
ch_eq_ci: char_cmp e,CI,m_ceq_ci

;************************************************************************
;*							       AL   AH	*
;* (char-<char1 char2)				char-<	       dest,src *
;************************************************************************
	  public  ch_lt_p
ch_lt_p:  char_cmp b,CS,m_ch_lt

;************************************************************************
;*							       AL   AH	*
;* (char-less? char1 char2)			char-less?     dest,src *
;************************************************************************
	  public  ch_lt_ci
ch_lt_ci: char_cmp b,CI,m_chl_ci

	  purge   char_cmp

ch_case   macro   direction,name
	  local   y
	  lods	  byte ptr ES:[SI]
	  mov	  DI,AX
	  add	  DI,offset reg0
	  cmp	  byte ptr [DI].C_page,SPECCHAR*2 ; is input char?
	  jne	  y		   ; if not a character, error (jump)
	  mov	  AL,byte ptr [DI].C_disp  ; Put char in AL
IFIDN	  <direction>,<UP>
	  mov	  BX,offset hicases
ELSE
IFIDN	  <direction>,<DOWN>
	  mov	  BX,offset locases
ELSE
	  ***error***	Invalid: direction
ENDIF
ENDIF
	  xlat			    ; Fetch alternate case
	  mov	  byte ptr [DI].C_disp,AL ;  and store into dest register
	  jmp	  next
;     ***error-- invalid source operand***
y:	  mov	  AX,offset name   ; load the instruction's name text
IFIDN	  <direction>,<UP>
error_1:  pushm	  <DI,m_one,AX>    ; push operand, operand count, instr. name
	  C_call  set_src_,<SI>,Load_ES ; call set_source_error
	  jmp	  sch_err	   ; link to Scheme debugger
ELSE
	  jmp	  error_1	   ; jump to error routine
ENDIF
	  endm

;************************************************************************
;*							       AL	*
;* (char-upcase char)				char-upcase    dest	*
;*									*
;* Purpose:  Scheme interpreter support for conversion of characters	*
;*		to uppercase						*
;************************************************************************
	  public  ch_up
ch_up:	  ch_case UP,m_ch_up

;************************************************************************
;*							       AL	*
;* (char-downcase char) 			char-downcase  dest	*
;*									*
;* Purpose:  Scheme interpreter support for conversion of characters	*
;*		to lowercase						*
;************************************************************************
	  public  ch_down
ch_down:  ch_case DOWN,m_ch_dwn

	  purge   ch_case

;************************************************************************
;*								AL  AH	*
;* (make-string len init)			make-string	len,init*
;************************************************************************
	  public  make_str
make_str: lods	  word ptr ES:[SI] ; load the operands of the instruction
	  save	  <AX,SI>	   ; save the operands and location pointer
	  xor	  BX,BX
	  mov	  BL,AL 	   ; copy the destination register number
	  add	  BX,offset reg0   ;  into BX and compute its address
	  cmp	  byte ptr [BX].C_page,SPECFIX*2 ; is length a fixnum?
	  jne	  mk_st_er	   ; if not, error (jump)
	  mov	  AX,[BX].C_disp   ; load the immediate value for the size
	  shl	  AX,1		   ;  and sign extend it
	  sar	  AX,1
	  jl	  mk_st_er	   ; if size is negative, error
	  mov	  CX,STRTYPE	   ; load the tag value for the string object
	  pushm   <AX,CX,BX>	   ; push arguments to "alloc_block"
	  C_call  alloc_bl,,Load_ES ; call: alloc_block(reg, STRTYPE, len)
	  pop	  BX		   ; restore destination register address
	  mov	  DI,[BX].C_disp   ; load a pointer to the newly allocated
	  mov	  BX,[BX].C_page   ;  string object
	  LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX]
	  restore <AX>		   ; reload operands to instruction
	  mov	  BL,AH 	   ; copy initial value register number
	  mov	  AL,byte ptr reg0_pag+[BX] ; load page number of init value
	  cmp	  AL,SPECCHAR*2    ; init value a character?
	  je	  st_fl_3	   ; if a character, jump
	  cmp	  AL,NIL_PAGE*2    ; use default value? (nil?)
	  jne	  mk_st_er	   ; if not nil, error (jump)
	  mov	  AL," "           ; load default string fill character
	  jmp	  short st_fl_4
mk_st_er: lea	  BX,m_mk_str	   ; load address of "make-string" text
	  jmp	  src_err	   ; display "source operand error" message

;************************************************************************
;*							      AL  AH	*
;* (string-fill! string char)			string-fill!  str,char	*
;************************************************************************
	  public  str_fill
str_fill: lods	  word ptr ES:[SI] ; load string-fill operands
	  save	  <SI>		   ; save current location pointer
	  xor	  BX,BX
	  mov	  BL,AL 	   ; copy string register number
	  mov	  DI,BX
	  mov	  BL,byte ptr reg0_pag+[DI]
	  cmp	  byte ptr ptype+[BX],STRTYPE*2 ; is 1st operand a string?
	  jne	  st_fl_er	   ; if not, error (jump)
	  LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX] ; load a pointer to the string object
	  mov	  DI,reg0_dis+[DI]
	  mov	  BL,AH 	   ; copy initialization value register number
	  cmp	  reg0_pag+[BX],SPECCHAR*2 ; is it a char?
	  jne	  st_fl_er	   ; if not, error
st_fl_3:  mov	  AL,byte ptr reg0_dis+[BX] ; load initialization character
st_fl_4:  mov	  CX,ES:[DI].str_len ; load length of string object
	  cmp	  CX,0		   ;;; check for small string
	  jge	  st_010
	  add	  CX,BLK_OVHD+PTRSIZE  ;;; adjust for small string
st_010:	  sub	  CX,offset str_data ; compute number of characters
	  add	  DI,offset str_data ; advance index to 1st character position
rep	  stosb 		   ; fill string object with init character
	  jmp	  next_SP	   ; return to interpreter
st_fl_er: lea	  BX,m_st_fl	   ; load address of "fill-string" text
	  jmp	  src_err	   ; display "source operand error" message

str_int   endp

;************************************************************************
;*		Macro Support for String ref/set			*
;************************************************************************
st_thing  macro   ref_or_set,message
	  local   w,x,y,z
	  lods	  word ptr ES:[SI] ; load string pointer and index regs
	  xor	  BX,BX
	  mov	  BL,AL 	   ; copy string/dest reg number into DI
	  mov	  DI,BX
IFIDN	  <ref_or_set>,<SET>
	  lods	  byte ptr ES:[SI] ; load source operand register number
	  mov	  DL,AL 	   ;  and save it in TIPC register DL
ENDIF
	  save	  <SI>		   ; save the location pointer
	  mov	  BL,byte ptr reg0_pag+[DI] ; load string page number
	  cmp	  byte ptr ptype+[BX],STRTYPE*2 ; is it a string?
	  jne	  y		   ; if not a string, error (jump)
	  LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX]
	  mov	  BL,AH 	   ; copy index register number
	  cmp	  byte ptr reg0_pag+[BX],SPECFIX*2 ; is index a fixnum?
	  jne	  y		   ; if not a fixnum, error (jump)
	  mov	  AX,reg0_dis+[BX] ; load immediate value and
	  shl	  AX,1		   ;  sign extend to 16 bits
	  sar	  AX,1
	  jl	  z		   ; if index negative, error (jump)
	  add	  AX,offset str_data ; advance pointer past string header
	  mov	  SI,reg0_dis+[DI] ; load pointer to string object
	  mov	  CX,ES:[SI].str_len ; compare index with string length
	  cmp	  CX,0		   ;;; check for small string
	  jge	  w
	  add	  CX,BLK_OVHD+PTRSIZE  ;;; adjust for small string
w:	  cmp	  AX,CX
	  jge	  z		   ; if index too large, error (jump)
	  add	  SI,AX 	   ; add index to string pointer
IFIDN	  <ref_or_set>,<REF>
	  mov	  byte ptr reg0_pag+[DI],SPECCHAR*2 ; set tag=character
	  mov	  BL,ES:[SI]	   ; fetch desired character
	  mov	  reg0_dis+[DI],BX ;  and store into destination register
ELSE
IFIDN	  <ref_or_set>,<SET>
	  mov	  BL,DL 	   ; copy source value register number
	  cmp	  byte ptr reg0_pag+[BX],SPECCHAR*2 ; is source a character?
	  jne	  y		   ; if not a character, error (jump)
	  mov	  AL,byte ptr reg0_dis+[BX] ; store source character into
	  mov	  ES:[SI],AL	   ;  string at desired offset
ELSE
	  ***error***  Invalid:  ref_or_set
ENDIF
ENDIF
	  jmp	  next_PC	   ; return to interpreter
;     ***error-- invalid source operand***
y:	  lea	  BX,message	   ; load address of operation name text
	  jmp	  src_err	   ; display "source operand error" message
;     ***error-- invalid string offset***
z:	  mov	  BX,offset message ; load address of instruction name
IFIDN	  <ref_or_set>,<REF>
	  mov	  DX,3		   ; STRING-REF is 3 bytes long
s_out_bn: restore <SI>		   ; load location pointer and
	  sub	  SI,DX		   ;  back up to start of instruction in error
	  pushm	  <SI,BX>	   ; push instruction's offset, name
	  C_call  disassem,,Load_ES ; disassemble instruction for *irritant*
	  pushm	  <tmp_adr,m_soff,m_one> ; push args to "set_numeric_error"
	  C_call  set_nume	   ; set_numeric_error(1,ST_OFF_ERR,tmp_reg);
	  restore <SI>		   ; load offset of next instruction
	  jmp	  sch_err	   ; Link to Scheme debugger
ELSE
	  mov	  DX,4		   ; STRING-SET! is 4 bytes long
	  jmp	  s_out_bn	   ; continue error processing
ENDIF
	  endm

;************************************************************************
;*							      AL  AH	*
;* (string-ref string index)			string-ref    str,index *
;************************************************************************
	  public  st_ref
st_ref:   st_thing REF,m_st_ref

;************************************************************************
;*							AL  AH	  AL	*
;* (string-set! string index char)	string-set!	str,index,char	*
;************************************************************************
	  public  st_set
st_set:   st_thing SET,m_st_set

	  purge   st_thing

prog	  ends
	  end