pcs/srch_str.asm

;							=====> SRCH_STR.ASM
;***************************************
;*     TIPC Scheme  Runtime Support    *
;*      String Search Capabilities     *
;*				       *
;*    (C) Copyright 1985 by Texas      *
;*     Instruments Incorporated.       *
;*	  All rights reserved.	       *
;*				       *
;* Date Written:  21 July 1985	       *
;* Last Modification:  17 October 1985 *
;***************************************
	  include scheme.equ
	  include pcmake.equ
	  include sinterp.arg
IFDEF PROMEM
	  include rpc.equ
	  include xli_pro.mac
	  include realio.equ
	  .286c
ENDIF

DGROUP	  group   data
XGROUP	  group   PROGX
PGROUP	  group   prog

MSDOS	  equ	  021h
TI_CRT	  equ	  049h
IBM_CRT   equ	  010h

;     Definitions for control characters
CTL_A	  equ	  1
CTL_I	  equ	  9
CTL_Z	  equ	  26

data	  segment word public 'DATA'
	  assume  DS:DGROUP
IFDEF PROMEM
;from pro2real.asm
	  extrn   REAL_BUF_SELECTOR:word,REAL_BUF_TOP:word,RPC_HANDLE:byte
ENDIF
ret_sav1  dw	  0		   ; return address save area
ret_sav2  dw	  0		   ; return address save area
m_srch_f  db	  "SUBSTRING-FIND-NEXT-CHAR-IN-SET",0
m_srch_b  db	  "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",0
m_st_ln	  db	  "STRING-LENGTH",0
m_mk_str  db	  "MAKE-STRING",0
m_stapnd  db	  "%STRING-APPEND",0
m_reifs	  db	  "%REIFY-STACK",0
m_reifsb  db	  "%REIFY-STACK!",0
m_st_dsp  db	  "%SUBSTRING-DISPLAY",0
m_opnd	  dw	  INVALID_OPERAND_ERROR ; numeric error code
m_one	  dw	  1		   ; a constant "one" (1)
data	  ends

prog	  segment byte public 'PROG'
	  assume  CS:PGROUP
	  extrn	  %allocbl:far	   ; "alloc_block" linkage routine
	  extrn	  next:far	   ; Interpreter's "next instruction" point
	  extrn	  next_PC:far	   ; Interpreter's "next instruction" point
	  extrn	  sch_err:far	   ; Linkage to Scheme debugger
;************************************************************************
;*		      Far Linkage to "set_src_err"			*
;************************************************************************
	  public  %set_src
%set_src  proc	  far
	  pop	  ret_sav1
	  pop	  ret_sav2
	  push	  DS		   ; make ES point to the current data segment
	  pop	  ES
	  extrn	  set_src_:near
	  call	  set_src_
	  push	  ret_sav2
	  push	  ret_sav1
	  ret
%set_src  endp

;************************************************************************
;*		     Far Linkage to "set_numeric_error"			*
;************************************************************************
	  public  %set_num
%set_num  proc	  far
	  pop	  ret_sav1
	  pop	  ret_sav2
	  push	  DS		   ; make ES point to the current data segment
	  pop	  ES
	  extrn	  set_nume:near
	  call	  set_nume
	  push	  ret_sav2
	  push	  ret_sav1
	  ret
%set_num  endp

;************************************************************************
;*		      Far Linkage to "dissamble"			*
;************************************************************************
	  public  %disasse
%disasse  proc	  far
	  pop	  ret_sav1
	  pop	  ret_sav2
	  push	  DS		   ; make ES point to the current data segment
	  pop	  ES
	  extrn	  disassem:near
	  call	  disassem
	  push	  ret_sav2
	  push	  ret_sav1
	  ret
%disasse  endp

;************************************************************************
;*		      Far Linkage to "get_port" 			*
;************************************************************************
	  public  %getport
%getport  proc	  far
	  pop	  ret_sav1
	  pop	  ret_sav2
	  push	  DS		   ; make ES point to the current data segment
	  pop	  ES
	  extrn	  get_port:near
	  call	  get_port
	  push	  ret_sav2
	  push	  ret_sav1
	  ret
%getport  endp

prog	  ends

PROGX	  segment byte public 'PROGX'
	  assume  CS:XGROUP

	  extrn	  CRT_DSR:far

;************************************************************************
;*		      Substring-Find-Next-Char-in-Set			*
;************************************************************************
srch_arg  struc
strt_off  dw	  ?		   ; starting offset (16 bit positive integer)
end_off	  dw	  ?		   ; ending offset (16 bit positive integer)
lngth	  dw	  ?		   ; number of characters in source string
result	  dw	  ?		   ; index of character matched

;     Note:  the following two entries are order dependent
str_beg	  dw	  ?		   ; beginning offset of string
str_DS	  dw	  ?		   ; segment register value for string

srch_BP	  dw	  ?		   ; caller's BP
	  dw	  ?		   ; caller's ES
	  dd	  ?		   ; return address (far)
	  dw	  ?		   ; return address (near)
str_reg	  dw	  ?		   ; register containing string
strt_reg  dw	  ?		   ; register containing substr starting offset
end_reg	  dw	  ?		   ; register containing substr ending offset
cs_reg	  dw	  ?		   ; register containing charset string
srch_arg  ends

srch_str  proc	  far

%srchprv  label	  far
	  mov	  CX,1		   ; set search direction = backward
	  jmp	  short srch_go    ; go to common processing code

;     Long Branch to Source Error Support
srch_er1: jmp	  srch_err

%srchnxt  label	  far
	  xor	  CX,CX		   ; set search direction = forward

srch_go:  push	  ES		   ; save caller's ES register
	  push	  BP		   ; save caller's BP register
	  sub	  SP,offset srch_BP ; allocate local storage
	  mov	  BP,SP		   ; establish addressability of local data

;     Validate Source String Argument
	  mov	  BX,[BP].str_reg  ; load address of string register
	  mov	  SI,[BX].C_page   ;  and load string's page number
	  cmp	  byte ptr ptype+[SI],STRTYPE*2 ; is source string a string?
	  jne	  srch_er1	   ; if not a string, error (jump)
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load string's paragraph address
	  mov	  SI,[BX].C_disp   ; load displacement of string
	  mov	  AX,ES:[SI].str_len ; load length of string
	  cmp	  AX,0             ;;; check length of string
	  jge	  srch_01
	  add	  AX,PTRSIZE
	  jmp	  srch_02
srch_01:  sub	  AX,BLK_OVHD	   ;  and compute number of characters in it
srch_02:  mov	  [BP].lngth,AX	   ; save string length for further testing
	  add	  SI,BLK_OVHD	   ; advance string start to first character
	  mov	  [BP].str_beg,SI  ; save starting character offset
	  mov	  [BP].str_DS,ES   ;  and segment register pointer

;     Validate Starting Offset Argument
	  mov	  BX,[BP].strt_reg ; load address of starting offset regsiter
	  call	  get_num	   ; obtain the integer value
	  jc	  srch_er1	   ; if carry set, error
	  mov	  [BP].strt_off,AX ;  and save it for future use

;     Validate Ending Offset Argument
	  mov	  BX,[BP].end_reg  ; load address of ending offset register
	  call	  get_num	   ; obtain the integer value
	  jc	  srch_er1	   ; if carry set, error
	  cmp	  [BP].strt_off,AX ; is starting offset greater than ending?
	  ja	  srch_er1	   ; if so, invalid substring range (jump)
	  cmp	  AX,[BP].lngth	   ; test ending offset against string length
	  ja	  srch_er1	   ; if ending offset too big, error (jump)
	  mov	  [BP].end_off,AX  ; save ending offset for future use

;     Validate Charset String Argument
	  mov	  BX,[BP].cs_reg   ; load number of register holding charset
	  mov	  DI,[BX].C_page   ; load page number of charset pointer
	  cmp	  byte ptr ptype+[DI],STRTYPE*2 ; this is a sting, isn't it?
	  jne	  char_p	   ; if not a string, error (jump)
	  %LoadPage ES,DI
;;;	  mov	  ES,pagetabl+[DI] ; load paragraph address of string
	  mov	  DI,[BX].C_disp   ; load displacement of string in page
	  mov	  DX,ES:[DI].str_len ; load length of string object
	  cmp	  DX,0             ;;; check length of string
	  jge	  srch_03
	  add	  DX,PTRSIZE
	  jmp	  srch_04
srch_03:  sub	  DX,BLK_OVHD	   ; compute number of characters in charset
srch_04:  add	  DI,BLK_OVHD	   ; advance string pointer past block header
	  jmp	  short go
char_p:	  cmp	  DI,SPECCHAR*2	   ; is charset argument a single character?
	  je      char_p0	   ; Yes, continue
	  jmp	  srch_er1	   ; No,  error (jump)

;     Single character search-- optimize it
char_p0:  mov	  AL,byte ptr [BX].C_disp
	  les	  DI,dword ptr [BP].str_beg
	  mov	  DX,CX		   ; save direction indicator in DX
	  mov	  CX,[BP].end_off  ; compute length of search string
	  sub	  CX,[BP].strt_off
	  je	  not_fnd1	   ; if search length is zero, return 'nil
	  cmp	  DX,0
	  jne	  b_ward	   ; if backward, jump
;     search for single character in forward direction
	  add	  DI,[BP].strt_off ; compute address of start of substring
repne	  scasb			   ; search for single character
	  jne	  not_fnd1	   ; character found?  If so, jump
	  dec	  DI		   ; fix up ending index
	  jmp	  short over
;     search for single character in backward direction
b_ward:   add	  DI,[BP].end_off  ; compute address of end of substring
	  dec	  DI
	  std			   ; set search direction to be backwards
repne	  scasb			   ; search for single character
	  cld			   ; reset "direction" flag to go forwards
	  jne	  not_fnd1	   ; if search length is zero, return 'nil
	  inc	  DI		   ; fix up ending index
over:	  mov	  SI,DI		   ; copy character address to SI
	  sub	  SI,[BP].str_beg  ;  and compute found character's address
	  jmp	  short found	   ; return index to found character

;     Determine whether string search is forward or backward
go:	  push	  DS		   ; save the data segment address
	  cmp	  CX,0		   ; in which direction are we to search?
	  je	  forward	   ; if CX=0, forward; else backward

;   Register Usage in Innermost Loop:
;	DS:SI - pointer to next character in source string
;	ES:DI - pointer to charset string
;	AL    - search character
;	BX    - ending offset (source string)
;	CX    - length of charset string
;	DX    - length of charset string (used to refresh CX)

;     Search Source String in a Backwards Direction
	  mov	  BX,[BP].str_beg  ; compute ending offset for string
	  add	  BX,[BP].strt_off
	  lds	  SI,dword ptr [BP].str_beg  ; load addr of string's beginning
	  add	  SI,SS:[BP].end_off ;  and compute end of substring address
	  jmp	  short startb	   ; jump to initial entry point in loop

loopb:    sub	  DI,DX		   ; reset starting offset of charset string
startb:   cmp	  SI,BX		   ; at beginning of substring?
	  jbe	  not_fnd	   ; if at end, jump
	  mov	  CX,DX		   ; reload charset string length
	  dec	  SI		   ; decrement source string index
	  mov	  AL,[SI]	   ;  and load next character to test
repne	  scasb			   ; search charset for current character
	  jne	  loopb
	  pop	  DS		   ; restore DS to point to data segment
	  sub	  SI,[BP].str_beg  ; compute index of current character
	  jmp	  short found	   ; current character found in charset

;     no characters found which appear in the charset
not_fnd:  pop	  DS		   ; restore DS to current data segment
not_fnd1: xor	  AX,AX		   ; store #!false in the
	  mov	  BX,[BP].str_reg  ;  destination register
	  mov	  byte ptr [BX].C_page,AL
	  mov	  [BX].C_disp,AX
	  jmp	  short ret	   ; return to caller

;     Search Source String in a Forward Direction
forward:  mov	  BX,[BP].str_beg  ; compute ending offset for string
	  add	  BX,[BP].end_off
	  lds	  SI,dword ptr [BP].str_beg  ; load addr of string's beginning
	  add	  SI,SS:[BP].strt_off ;  and compute beginning of substring
	  jmp	  short start	   ; jump to initial entry point in loop

loop:     sub	  DI,DX		   ; reset starting offset of charset string
start:	  cmp	  SI,BX		   ; at end of source string?
	  jae	  not_fnd	   ; if at end, jump
	  mov	  CX,DX		   ; reload charset string length
	  lodsb			   ; load next character to test
repne	  scasb			   ; search charset for current character
	  jne	  loop

;     current character found in charset-- return offset of current character
	  pop	  DS		   ; restore DS to current data segment
	  sub	  SI,[BP].str_beg  ; adjust offset of character found
	  dec	  SI
found:	  mov	  BX,[BP].str_reg  ; load address of destination register
	  call	  ret_num	   ; convert offset to Scheme integer

;     return to caller
ret:	  xor	  AX,AX		   ; set completion code for normal return
ret1:	  add	  SP,offset srch_BP ; release local storage
	  pop	  BP		   ; restore the caller's BP register
	  pop	  ES		   ; restore the caller's ES register
	  ret			   ; return

;     error-- invalid operand to string search primitive
srch_err: pushm	  <[BP].cs_reg,[BP].end_reg,[BP].strt_reg,[BP].str_reg>
	  cmp	  CX,0		   ; search forward or backward?
	  jne	  backward	   ; if backward search, jump
	  mov	  AX,offset m_srch_f
	  jmp	  short common
backward: mov	  AX,offset m_srch_b 
common:   mov	  BX,4		   ; load VM argument count
	  pushm	  <BX,AX>	   ; push args=4, name of instruction
	  call	  %set_src	   ; call set_src_err(...);
	  mov	  AX,-1		   ; load "invalid operand" flag
	  mov	  SP,BP		   ; drop arguments off the TIPC's stack
	  jmp	  ret1		   ; return to interpreter
	  
srch_str  endp

dumy_arg  struc
	  dw	  ?		   ; caller's BP
	  dd	  ?		   ; return address (far linkage)
	  dw	  ?		   ; return address (near linkage)
arg1	  dw	  ?		   ; register address for argument 1
arg2	  dw	  ?		   ; register address for argument 2
arg3	  dw	  ?		   ; register address for argument 3
arg4	  dw	  ?		   ; register address for argument 4
dumy_arg  ends

;************************************************************************
;*								   AL	*
;* (string-length string)			string-length      d=s1	*
;*									*
;* Purpose:  Scheme Interpreter support for the "string-lengt" function.*
;************************************************************************
%st_len	  proc	  far
	  push	  BP		   ; save the caller's BP register
	  mov	  BP,SP		   ; establish addressability for arguments
;     validate the string argument
	  mov	  BX,[BP].arg1	   ; load address of argument register
	  mov	  SI,[BX].C_page   ; load the string's page number
	  cmp	  byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it?
	  jne	  st_l_err	   ; if not a string, error (jump)
;     compute string length
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load paragraph address of string's page
	  mov	  SI,[BX].C_disp   ; load string's displacement
	  mov	  SI,ES:[SI].str_len ; load length field from string object
	  cmp	  SI,0             ;;; check length of string
	  jge	  str_010
	  add	  SI,PTRSIZE
	  jmp	  str_020
str_010:  sub	  SI,BLK_OVHD	   ;  and compute number of characters in it
;     return string length as an integer
str_020:  call	  ret_num	   ; create Scheme representation for integer
;     return
	  xor	  AX,AX		   ; set error code for normal return
str_ret:  pop	  BP		   ; restore the caller's BP register
	  ret			   ; return to caller
;     ***error-- operand was not a string***
st_l_err: mov	  AX,offset m_st_ln ; load text address for "STRING-LENGTH"
	  mov	  CX,1		   ; indicate one operand
	  pushm	  <BX,CX,AX>	   ; push arguments for call
	  call	  %set_src	   ; call:  set_src_err("STRING-LENGTH",1,arg1)
	  mov	  SP,BP		   ; drop arguments off stack
	  mov	  AX,-1		   ; indicate error return
	  jmp	  str_ret	   ; return
%st_len	  endp

;************************************************************************
;* MAKE-STRING				(MAKE-STRING  LENGTH  INIT-VAL)	*
;*									*
;* Purpose:  Scheme Interpreter support for the "MAKE-STRING" function.	*
;*									*
;* Note:  The maximum length of a PCS string is 2^16 - 3 (65,532)	*
;*	characters.							*
;************************************************************************
%makestr  proc	  far
	  push	  BP		   ; save the caller's BP register
	  mov	  BP,SP		   ; establish addressability for arguments
;     validate the length operand
	  mov	  BX,[BP].arg1	   ; load address of reg containing length
	  call	  get_num	   ; get the value of the integer
	  jc	  mk_s_err	   ; error?  if so, jump
;     allocate the string object
	  mov	  CX,STRTYPE	   ; load the type code for a string
	  pushm	  <AX,CX,BX>	   ; push arguments for the call
	  call	  %allocbl	   ; call:  alloc_block(arg1, STRTYPE, length)
	  mov	  SP,BP		   ; drop the arguments off the stack
;     validate the initialization value
	  mov	  BX,[BP].arg2	   ; load address of register with init value
	  mov	  SI,[BX].C_page   ; load initialization value's page number
	  cmp	  SI,0		   ; default initialization value (nil)?
	  jne	  mk_s_ch	   ; if not nil, check for character (jump)
	  mov	  AL," "	   ; use blank (" ") as default fill value
	  jmp	  short mk_s_in	   ; initialize the string
mk_s_ch:  cmp	  SI,SPECCHAR*2	   ; is initialization value a character?
	  jne	  mk_s_err	   ; if not a character or nil, error (jump)
	  mov	  AL,byte ptr [BX].C_disp ; load the value of the character
;     initialize the string
mk_s_in:  mov	  BX,[BP].arg1	   ; load a pointer to the newly allocated
	  mov	  DI,[BX].C_disp
	  mov	  BX,[BX].C_page
	  %LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX]
	  mov	  CX,[BP].arg3     ; load length of string object
	  add	  DI,BLK_OVHD	   ; advance string ptr to 1st char position
rep	  stosb			   ; propagate initval throughout string
;     return to caller
	  xor	  AX,AX		   ; set the return code for a normal return
mk_s_ret: pop	  BP		   ; restore the caller's BP register
	  ret			   ; return
;     ***error-- invalid operand to MAKE-STRING***
mk_s_err: mov	  AX,offset m_mk_str ; load addr of "MAKE-STRING" text
	  mov	  BX,2		   ; load argument count = 2
	  pushm	  <[BP].arg2,[BP].arg1,BX,AX>
	  call	  %set_src	   ; set_src_err("MAKE-STRING",2,arg1,arg2)
	  mov	  SP,BP		   ; drop arguments off TIPC stack
	  mov	  AX,-1		   ; indicate error return
	  jmp	  short mk_s_ret   ; return
%makestr  endp

;************************************************************************
;* (%str-append str1 start1 end1 {nil,char,str2} str3 start3 end3)	*
;************************************************************************
str_arg   struc
start1	  dw	  ?		   ; starting offset of first string
start3	  dw	  ?		   ; starting offset of third string
len1	  dw	  ?		   ; length of first string
len2	  dw	  ?		   ; length of second string
len3	  dw	  ?		   ; length of third string
str_BP    dw	  ?		   ; caller's BP
	  dw	  ?		   ; caller's SI
	  dw	  ?		   ; caller's ES
reg7	  dw	  ?		   ; address of 7th operand register
reg6	  dw	  ?		   ; address of 6th operand register
reg5	  dw	  ?		   ; address of 5th operand register
reg4	  dw	  ?		   ; address of 4th operand register
reg3	  dw	  ?		   ; address of 3rd operand register
reg2	  dw	  ?		   ; address of 2nd operand register
reg_1	  dw	  ?		   ; address of 1st operand register
str_arg   ends

	  public  str_apnd
%strapnd  proc	  far
str_err1: jmp	  str_err	   ; indirect jump to error code
;     Load operands of this here instruction and compute register addresses
str_apnd: mov	  CX,7		   ; load count of number of operands
str_ld:   xor	  AX,AX		   ; clear AH
	  lods	  byte ptr ES:[SI] ; load register number of this operand
	  add	  AX,offset reg0   ;  and compute the register's address
	  push	  AX		   ; save the register's address on the stack
	  loop	  str_ld	   ; continue until all operands processed
;     Save registers and establish addressability of local storage
	  push	  ES		   ; save caller's ES register
	  push	  SI		   ; save caller's SI register
	  push	  BP		   ; save caller's BP register
	  sub	  SP,offset str_BP ; allocate local storage
	  mov	  BP,SP		   ;  and establish addressability

;     Validate the First String's Starting Offset
	  mov	  BX,[BP].reg2	   ; load address of start1 register
	  call	  get_num	   ; fetch value for start1
	  jc	  str_err1	   ; if error, jump
	  add	  AX,BLK_OVHD	   ; advance starting offset past block header
	  mov	  [BP].start1,AX   ; save start1 offset
;     Validate the First String's Ending Offset
	  mov	  BX,[BP].reg3	   ; load address of end1 register
	  call	  get_num	   ; fetch value for end1
	  jc	  str_err1	   ; if error, jump
	  add	  AX,BLK_OVHD	   ; advance ending offset past block header
;     Validate the First String Operand
	  mov	  BX,[BP].reg_1	   ; load address of string1 register
	  mov	  SI,[BX].C_page   ; load string's page number
	  cmp	  byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it?
	  jne	  str_err1	   ; if not a string, error (jump)
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load a pointer to the string
	  mov	  SI,[BX].C_disp
	  mov	  CX,ES:[SI].str_len ; ending offset past string end?
	  cmp	  CX,0             ;;; check length of string
	  jge	  str_01
	  add	  CX,BLK_OVHD+PTRSIZE  ;;; adjust the string length
str_01:	  cmp	  AX,CX
	  ja	  str_err1	   ; if ending offset too big, error (jump)
	  sub	  AX,[BP].start1   ; is ending offset too small?
	  jb	  str_err1	   ; if ending offset smaller than start, jump
	  mov	  [BP].len1,AX	   ; save length of substring1

;     Validate the Third String's Starting Offset
	  mov	  BX,[BP].reg6	   ; load address of start3 register
	  call	  get_num	   ; fetch value for start3
	  jc	  str_err	   ; if error, jump
	  add	  AX,BLK_OVHD	   ; advance starting offset past block header
	  mov	  [BP].start3,AX   ; save start3 offset
;     Validate the Third String's Ending Offset
	  mov	  BX,[BP].reg7	   ; load address of end3 register
	  call	  get_num	   ; fetch value for end3
	  jc	  str_err	   ; if error, jump
	  add	  AX,BLK_OVHD	   ; advance ending offset past block header
;     Validate the Third String Operand
	  mov	  BX,[BP].reg5	   ; load address of string3 register
	  mov	  SI,[BX].C_page   ; load string's page number
	  cmp	  byte ptr ptype+[SI],STRTYPE*2 ; it is a string, isn't it?
	  jne	  str_err	   ; if not a string, error (jump)
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load a pointer to the string
	  mov	  SI,[BX].C_disp
	  mov	  CX,ES:[SI].str_len ; ending offset past string end?
	  cmp	  CX,0             ;;; check length of string
	  jge	  str_02
	  add	  CX,BLK_OVHD+PTRSIZE  ;;; adjust the string length
str_02:   cmp	  AX,CX
       	  ja	  str_err	   ; if ending offset too big, error (jump)
	  sub	  AX,[BP].start3   ; is ending offset too small?
	  jb	  str_err	   ; if ending offset smaller than start, jump
	  mov	  [BP].len3,AX	   ; save length of substring3

;     Validate the "thing" to be inserted between string1 and string3
	  mov	  BX,[BP].reg4	   ; load register with said "thing"
	  mov	  SI,[BX].C_page   ; load page number
	  cmp	  SI,NIL_PAGE*2	   ; is object nil?
	  jne	  str_10	   ; if not nil, jump
;     The "thing" is nil-- indicate nothing to insert
	  mov	  [BP].len2,0	   ; indicate zero length "thing"
	  jmp	  short str_30	   ; continue processing

;     ***We interrupt this routine for some error support code***
str_err:  mov	  AX,offset m_stapnd
	  mov	  CX,7
	  pushm	  <[BP].reg7,[BP].reg6,[BP].reg5,[BP].reg4,[BP].reg3>
	  pushm	  <[BP].reg2,[BP].reg_1,CX,AX>
	  call	  %set_src
	  mov	  SP,BP
	  add	  SP,offset str_BP
	  pop	  BP
	  pop	  SI
	  pop	  ES	  
	  jmp	  sch_err

str_10:   cmp	  SI,SPECCHAR*2	   ; is "thing" a character?
	  jne	  str_20	   ; if not a character, jump
;     The "thing" is a character
	  mov	  [BP].len2,1      ; indicate length = 1 character
	  jmp	  short str_30
str_20:   cmp	  byte ptr ptype+[SI],STRTYPE*2 ; is "thing" a string?
	  jne	  str_err	   ; if not a string, error (jump)
;     The "thing" is a string-- establish string length
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load string page's paragraph address
	  mov	  SI,[BX].C_disp
	  mov	  AX,ES:[SI].str_len
	  cmp	  AX,0             ;;; check length of string
	  jge	  str_03
	  add	  AX,PTRSIZE
	  jmp	  str_04
str_03:   sub	  AX,BLK_OVHD	   ;  and compute number of characters in it
str_04:   mov	  [BP].len2,AX 	   ; save string length for further testing

;     All arguments OK, allocate the new string
str_30:	  mov	  AX,[BP].len1	   ; compute the length of the new string
	  add	  AX,[BP].len2
	  add	  AX,[BP].len3
	  cmp	  AX,16383	   ; is new string greater than max string size?
	  jg	  str_err 	   ; Yes ... error
	  mov	  BX,STRTYPE	   ; load tag=string
	  mov	  CX,offset tmp_reg
	  pushm	  <AX,BX,CX>	   ; push arguments to call
	  call	  %allocbl
	  mov	  SP,BP		   ; drop arguments off the stack
	  mov	  DI,tmp_page	   ; load pointer to newly allocated string
	  %LoadPage0 ES,DI
;;;	  mov	  ES,pagetabl+[DI]
	  mov	  DI,tmp_disp	   ; pointer is now in ES:[DI]
	  add	  DI,BLK_OVHD	   ; advance pointer to 1st character location
;     Move in data from all substrings
	  mov	  CX,[BP].len1	   ; load length of string1
	  mov	  BX,[BP].reg_1	   ; load addr of register containing string 1
	  mov	  SI,[BX].C_disp   ; load string 1's offset
	  add	  SI,[BP].start1   ; add in offset of starting character
	  mov	  BX,[BX].C_page   ; load page number
	  push	  DS		   ; save the data segment register
	  %LoadPage1 DS,BX
;;;	  mov	  DS,pagetabl+[BX]
;**********************************************************************
;* * * Warning:  The data segment register (DS) does not point to * * *
;* * *		 the data segment in the code which follows	  * * *
;**********************************************************************
rep	  movsb			   ; copy string1 into new string
	  pop	  DS		   ; restore data segment register

	  mov	  CX,[BP].len2	   ; load length of string2
	  cmp	  CX,0		   ; any characters to move?
	  je	  str_60	   ; if no characters, jump
	  mov	  BX,[BP].reg4	   ; load addr of register with "thing"
	  mov	  SI,SS:[BX].C_disp ; load a pointer to "thing"
	  mov	  BX,SS:[BX].C_page
	  push	  DS		   ; Save data segment register
	  cmp	  BL,SPECCHAR*2	   ; is "thing" a character?
	  jne	  str_40	   ; if not a character, then a string (jump)
	  mov	  SI,[BP].reg4	   ; load addr of register containing character
	  jmp	  short str_50
str_40:	  %LoadPage1 DS,BX
;;;    	  mov	  DS,SS:pagetabl+[BX] ; "thing" is a string-- load pointer
	  add	  SI,BLK_OVHD	   ;  to it and advance to 1st character
str_50:
rep	  movsb			   ; copy string2 into new string
	  pop	  DS		   ; restore data segment register

str_60:	  mov	  CX,[BP].len3	   ; load length of string3
	  mov	  BX,[BP].reg5	   ; load addr of register containing string 3
	  mov	  SI,SS:[BX].C_disp ; load string offset
	  add	  SI,[BP].start3   ; advance starting offset past block header
	  mov	  BX,SS:[BX].C_page ; load the string's page number and
	  push	  DS
	  %LoadPage1 DS,BX
;;;	  mov	  DS,SS:pagetabl+[BX] ;  paragraph address
rep	  movsb			   ; copy string3 into new string
	  pop	  DS		   ; restore the data segment register
;**********************************************************************
;* * * Warning:  The data segment register (DS) does not point to * * *
;* * *		 the data segment in the code above		  * * *
;**********************************************************************

;     Place pointer to new string into the destination register
	  mov	  DI,[BP].reg_1	   ; load destination register address
	  mov	  AL,byte ptr tmp_page
	  mov	  byte ptr [DI].C_page,AL
	  mov	  AX,tmp_disp
	  mov	  [DI].C_disp,AX

;     Return
	  add	  SP,offset str_BP ; deallocate local storage
	  pop	  BP		   ; restore caller's BP
	  pop	  SI		   ; restore caller's SI
	  pop	  ES		   ; restore caller's ES
	  jmp	  next		   ; return to Scheme interpreter

%strapnd  endp

;************************************************************************
;*			     Reify(!)-Stack				*
;*									*
;* Purpose:  To provide the ability to manipulate items on the Scheme	*
;*		runtime stack from Scheme.				*
;*									*
;* Description:  The elements of the stack are referenced by providing	*
;*		the byte offset of the desired element as an index	*
;*		to the REIFY-STACK or REIFY-STACK! instruction.	 An	*
;*		index of -1 to REIFY-STACK is a request that the current*
;*		stack frame pointer be returned.			*
;************************************************************************
r_stk	  struc
bang	  dw	  ?		   ; fetch/store indicator
r_stk_BP  dw	  ?		   ; caller's BP
	  dd	  ?		   ; return address (far call)
	  dw	  ?		   ; return address (near call)
r_index   dw	  ?		   ; register containing index; destination reg
r_value	  dw	  ?		   ; register containing value (for stores)
r_stk	  ends

%reifyst  proc	  far
;     ***Error-- Invalid Index for REIFY-STACK(!) Instruction***
reif_err: cmp	  CX,0		   ; is this a fetch or store?
	  jne	  reif_e10	   ; if store, jump
	  mov	  AX,offset m_reifs ; load text address for "REIFY-STACK"
	  mov	  BX,1		   ; indicate 1 operand to this instruction
	  jmp	  short reif_e20   ; jump to common error code
reif_e10: mov	  AX,offset m_reifsb ; load text address for "REIFY-STACK!"
	  mov	  BX,2		   ; indicate 2 operands to this instruction
	  push	  [BP].r_value	   ;  and push second reigster operand
reif_e20: pushm	  <[BP].r_index,BX,AX> ; push arguments
	  call	  %set_src	   ; indicate source operand error
	  mov	  SP,BP		   ; drop arguments off the stack
	  mov	  AX,-1		   ; load an error flag
	  jmp	  reif_rt1	   ; return with error flag in AX

;     (REIFY-STACK! index value)   ; entry point
%reifstb  label   far
	  mov	  CX,1		   ; indicate a store operation
	  jmp	  short reif_go	   ; jump to common entry code

;     (REIFY-STACK index)	   ; entry point
%reifstk  label	  far
	  xor	  CX,CX		   ; indicate a fetch operation

reif_go:  push	  BP		   ; save the caller's BP register
	  sub	  SP,offset r_stk_BP ; allocate local storage
	  mov	  BP,SP		   ; establish addressability for operands/data

;     Validate index
	  mov	  BX,[BP].r_index  ; load address of register containing index
	  cmp	  CX,0		   ; is this a REIFY-STACK operation?
	  jne	  reif_no	   ; if not, skip special check for -1
;     Check for an index of -1 indicating we need to return FP
	  cmp	  byte ptr [BX].C_page,SPECFIX*2 ; is index a fixnum?
	  jne	  reif_no	   ; if not a fixnum index, jump
	  cmp	  [BX].C_disp,07FFFh ; is index a -1?
	  jne	  reif_no	   ; if not -1, jump
	  mov	  AX,FP		   ; load FP's offset in stack buffer
	  add	  AX,BASE	   ;  and add BASE to compute absolute offset
	  mov	  SI,AX		   ; copy quotient to SI
	  call	  ret_num	   ; convert element index to a Scheme integer
	  jmp	  reif_ret	   ; return the element index of FP
;     Fetch the index value
reif_no:  call	  get_num	   ; fetch the integer value
	  jc	  reif_err	   ; if not a valid index, jump
	  push	  AX		   ; save the byte offset
	  xor	  DX,DX		   ; convert to a double word (w/out sign ext)
	  mov	  BX,PTRSIZE	   ; load divisor
	  div	  BX		   ; divide by number of bytes/pointer
	  pop	  AX		   ; restore the byte index
	  cmp	  DX,0		   ; is remainder zero?
	  jne	  reif_err	   ; if not a multiple of PTRSIZE, error (jump)
	  mov	  DX,BASE	   ; compute the current top of stack (TOS)
	  add	  DX,TOS	   ;  offset
	  cmp	  AX,DX		   ; is index larger than TOS?
	  ja	  reif_err	   ; if so, error (jump)

;     Attempt to find the desired element in the stack buffer
	  cmp	  AX,BASE	   ; is BASE < element index?
	  jb	  reif_cnt	   ; if so, element is in previous stack segment
	  sub	  AX,BASE	   ; compute byte offset of desired element
	  add	  AX,offset S_stack ; compute offset in stack buffer
	  mov	  SI,AX		   ;  and move offset into SI
	  mov	  AX,DS		   ; put data segment address into ES so that
	  mov	  ES,AX		   ; desired element is pointed to by ES:[SI]
	  jmp	  reif_do	   ; fetch/store the element

;     Find the element in a previous stack segment (a continuation object)
reif_cnt: mov	  BX,PREV_pag	   ; make ES:[SI] point to the previous
	  mov	  SI,PREV_dis	   ;  stack segment continuation object
	  %LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX]
;     Follow stack segment chain until desired offset found
reif_lop: cmp	  AX,ES:[SI].con_base ; compare element index:continuation base
	  jae	  reif_fnd	   ; if offset > base, element in this segment
	  mov	  BL,ES:[SI].con_spag ; load pointer to previous stack segment
	  mov	  SI,ES:[SI].con_sdis ;  into ES:[SI]
	  %LoadPage ES,BX
;;;	  mov	  ES,pagetabl+[BX] ; 
	  jmp	  short reif_lop   ; loop until desired segment found
;     Element found in stack segment (continuation) object
reif_fnd: sub	  AX,ES:[SI].con_base ; subtrace off continuation's base
	  add	  SI,AX		   ; add entry's byte offset
	  add	  SI,offset con_data ; adjust for continuation header

;     Desired stack element address by ES:[SI]-- is this a fetch or store?
reif_do:  cmp	  CX,0		   ; test fetch/store flag
	  jne	  reif_st	   ; if a store, jump
;     Fetch desired stack element
	  mov	  BX,[BP].r_index  ; load address of destination register
	  mov	  AL,ES:[SI].car_page ; load page number of stack entry
	  mov	  byte ptr [BX].C_page,AL ; and store into destination register
	  mov	  AX,ES:[SI].car   ; load displacement of stack entry
	  mov	  [BX].C_disp,AX   ;  and store into destination register
	  jmp	  short reif_ret
;     Re-define desired stack element
reif_st:  mov	  BX,[BP].r_value  ; load add of register containing new value
	  mov	  AL,byte ptr [BX].C_page
	  mov	  ES:[SI].car_page,AL
	  mov	  AX,[BX].C_disp
	  mov	  ES:[SI].car,AX

;     return to caller
reif_ret: xor	  AX,AX		   ; indicate no error encountered
reif_rt1: add	  SP,offset r_stk_BP ; deallocate local storage
	  pop	  BP		   ; restore the caller's BP register
	  ret			   ; return to caller
%reifyst  endp

;************************************************************************
;*			    AL     AL    AH  AL       AH		*
;*	(%SUBSTRING-DISPLAY string start end row-bias window)		*
;*									*
;* Purpose:  Special support for displaying strings to the CRT for	*
;*		applications such as text editors.			*
;************************************************************************

IFDEF PROMEM

SD_BSIZE  equ	  100		   	; buffer size
sd_args	  struc
;     Warning: the following five (5) items are order dependent
sd_dummy  dw      ?			; extra for realio
sd_len    dw	  ?		   	; #chars in following buffer
sd_buff	  db	  SD_BSIZE dup (?)	; string buffer
sd_text	  dw	  ?		   	; text attributes for window
sd_cursv  dw	  ?		   	; cursor coordinate save area
;
sd_char	  db	  ?		   	; "saved" character
sd_streg  dw	  ?		   	; string register address
sd_start  dw	  ?		   	; substring's starting offset
sd_end	  dw	  ?		   	; substring's ending offset
sd_bias	  dw	  ?		   	; row bias
sd_cline  dw	  ?		   	; cursor line number
sd_ccol	  dw	  ?		   	; cursor column number
sd_nline  dw	  ?		   	; number of lines in the window
sd_ncols  dw	  ?		   	; number of columns in the window
sd_ullin  dw	  ?		   	; upper left corner line number
sd_ulcol  dw	  ?		   	; upper left corner column number
sd_arg45  dw	  ?		   	; arguments 4,5 save area
sd_last	  dw	  ?		   	; last write flag
sd_linum  db	  ?		   	; line number
;     Warning: the following two (2) items are order dependent
sd_wn_SI  dw	  ?		   	; pointer to window object, part 1
sd_wn_ES  dw	  ?		   	; pointer to window object, part 2
;
sd_BP	  dw	  ?		   	; caller's BP
sd_args	  ends

ELSE 

sd_args	  struc
sd_buff	  db	  100 dup (?)	   ; string buffer
sd_char	  db	  ?		   ; "saved" character
sd_streg  dw	  ?		   ; string register address
sd_start  dw	  ?		   ; substring's starting offset
sd_end	  dw	  ?		   ; substring's ending offset
sd_bias	  dw	  ?		   ; row bias
sd_cline  dw	  ?		   ; cursor line number
sd_ccol	  dw	  ?		   ; cursor column number
sd_nline  dw	  ?		   ; number of lines in the window
sd_ncols  dw	  ?		   ; number of columns in the window
sd_ullin  dw	  ?		   ; upper left corner line number
sd_ulcol  dw	  ?		   ; upper left corner column number
sd_text	  dw	  ?		   ; text attributes for window
sd_arg45  dw	  ?		   ; arguments 4,5 save area
sd_cursv  dw	  ?		   ; cursor coordinate save area
sd_last	  dw	  ?		   ; last write flag
sd_linum  db	  ?		   ; line number
;     Warning: the following two (2) items are order dependent
sd_wn_SI  dw	  ?		   ; pointer to window object, part 1
sd_wn_ES  dw	  ?		   ; pointer to window object, part 2
;
sd_BP	  dw	  ?		   ; caller's BP
sd_args	  ends
SD_BSIZE  equ	  sd_char-sd_buff  ; buffer size

ENDIF
	  public  str_disp
strdisp   proc	  far
sd_err1:  jmp	  sd_err	   ; indirect branch to error code

;     load all five (5) of this instruction's operands
str_disp: lods	  byte ptr ES:[SI]
	  add	  AX,offset reg0
	  mov	  BX,AX		   ; save address of string register
	  lods	  word ptr ES:[SI]
	  mov	  DX,AX
	  lods	  word ptr ES:[SI]
	  save	  <SI>		   ; save location pointer

;     allocate local storage
	  push	  BP
	  sub	  SP,offset sd_BP
	  mov	  BP,SP
	  mov	  [BP].sd_last,0   ; initialize "last write?" flag
	  mov	  [BP].sd_linum,0  ; line number

;     save off argument information
	  mov	  [BP].sd_streg,BX
	  mov	  [BP].sd_arg45,AX

;     validate the string offsets
	  xor	  BX,BX		   ; clear register BX
	  mov	  BL,DL		   ; copy starting offset register number
	  add	  BX,offset reg0   ;  and compute register's address
	  call	  get_num	   ; obtain starting offset
	  jc	  sd_err1	   ; valid offset?  if not, error (jump)
	  add	  AX,BLK_OVHD	   ; adjust offset for block header
	  mov	  [BP].sd_start,AX ; save starting offset
	  xor	  BX,BX
	  mov	  BL,DH		   ; copy ending offset register number
	  add	  BX,offset reg0   ;  and compute register's address
	  call	  get_num	   ; obtain ending offset
	  jc	  sd_err1	   ; valid offset?  if not, error (jump)
	  add	  AX,BLK_OVHD	   ; adjust offset for block header
	  cmp	  AX,[BP].sd_start ; is ending offset greater than starting?
	  jb	  sd_err1	   ; if ending offset smaller, error (jump)
	  mov	  [BP].sd_end,AX   ; save ending offset

;     validate the row-bias
	  xor	  BX,BX
	  mov	  BL,byte ptr [BP].sd_arg45
	  cmp	  byte ptr reg0_pag+[BX],SPECFIX*2
	  je	  next$0
	  jmp	  sd_err
next$0:	  mov	  AX,reg0_dis+[BX]
	  shl	  AX,1
	  sar	  AX,1
	  mov	  [BP].sd_bias,AX

;     Validate the window operand
	  xor	  AX,AX
	  mov	  AL,byte ptr [BP].sd_arg45+1
	  add	  AX,offset reg0
	  pushm	  <m_one,AX>	   ; push mode=output, reg address
	  call	  %getport	   ; map port operand (result in tmp_reg)
	  cmp	  AX,0		   ; valid port operand?
	  jne	  sd_err	   ; if not a port, error (jump)
	  mov	  SI,tmp_page	   ; load a pointer to the port object
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI]
	  mov	  SI,tmp_disp
	  mov	  AX,ES:[SI].pt_pflgs ; load the port attributes
	  test	  AX,WINDOW	   ; is this port a window?
	  jz	  sd_err	   ; if not a window, error (jump)
	  test	  AX,OPEN	   ; window open for output?
	  jnz	  sd_open	   ; if open, jump
	  jmp	  sd_done	   ; if closed, ignore I/O request (jump)
;     Move parameters from the window object to local storage
sd_open:  mov	  AX,ES:[SI].pt_cline ; get cursor line number
	  mov	  [BP].sd_cline,AX
	  mov	  AX,ES:[SI].pt_ccol ; get cursor column number
	  mov	  [BP].sd_ccol,AX
	  mov	  AX,ES:[SI].pt_nline ; get number of lines in window
	  mov	  [BP].sd_nline,AX
	  mov	  AX,ES:[SI].pt_ncols ; get number of columns in window
	  mov	  [BP].sd_ncols,AX
	  mov	  AX,ES:[SI].pt_ullin ; get upper left corner's line number
	  mov	  [BP].sd_ullin,AX
	  mov	  AX,ES:[SI].pt_ulcol ; get upper left corner's column number
	  mov	  [BP].sd_ulcol,AX
	  mov	  AX,ES:[SI].pt_text ; get window's text attributes
	  mov	  [BP].sd_text,AX
	  mov	  [BP].sd_wn_ES,ES ; save pointer to window object
	  mov	  [BP].sd_wn_SI,SI
	  jmp	  short sd_more	   ; branch over error code

;     ***error-- invalid operand***
sd_err:   mov	  SP,BP		   ; clean up stack
	  add	  SP,offset sd_BP
	  pop	  BP
	  restore <SI>		   ; load address of next instruction and
	  sub	  SI,6		   ;  adjust for 5 operands + opcode
	  mov	  AX,offset m_st_dsp ; load address of "SUBSTRING-DISPLAY"
	  pushm	  <SI,AX>	   ; push arguments to "disassemble"
	  call	  %disasse	   ; create *irritant* (pointer in tmp_reg)
	  pushm	  <tmp_adr,m_opnd,m_one> ; push operands
	  call	  %set_num	   ; indicate source operand error
	  jmp	  sch_err	   ; Link to Scheme debugger

;     validate the string operand
sd_more:  mov	  BX,[BP].sd_streg ; load string register's address
	  mov	  SI,[BX].C_page   ; load string's page number
	  cmp	  byte ptr ptype+[SI],STRTYPE*2 ; type = string?
	  jne	  sd_err	   ; if not a string, error (jump)
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load pointer to string
	  mov	  SI,[BX].C_disp
	  mov	  AX,ES:[SI].str_len ; load string's length
	  cmp	  AX,0             ;;; check length of string
	  jge	  sd_010
	  add	  AX,BLK_OVHD+PTRSIZE  ;;; adjust for small string
sd_010:	  cmp	  AX,[BP].sd_end   ; is ending offset too big?
	  jb	  sd_err	   ; if too big, error (jump)
;     Note:  ES:[SI] points to the source string
	  mov	  DX,[BP].sd_end   ; load ending displacement and
	  add	  DX,SI		   ;  compute ending address
	  add	  SI,[BP].sd_start ; compute starting address
	
;     translate the string into the local buffer
	  mov	  CX,[BP].sd_ccol  ; load current cursor position
	  mov	  BX,[BP].sd_ncols ; load line length
	  mov	  DI,BP		   ; load pointer to local data
	  add	  DI,sd_buff	   ; and address buffer
	  push	  DS		   ; save the data segment register
	  mov	  AX,ES		   ; make DS point to the page containing
	  mov	  DS,AX		   ;  the source string
;**********************************************************************
;* * * Warning:  The data segment register (DS) does not point to * * *
;* * *		 the data segment in the code which follows	  * * *
;**********************************************************************
	  pop	  ES		   ; make ES point to the data segment
	  push	  ES

;     Register usage:  ES:[DI] - next character in output buffer
;		       DS:[SI] - next character in source string
;		       BX - number of columns in window
;		       CX - current column (cursor position) relative to window
;		       DX - end of source string address

sd_next:  cmp	  SI,DX		   ; end of input string?
	  jae	  sd_final	   ; if end of string, jump
	  lodsb			   ; fetch next character from string
	  cmp	  AL,CTL_Z	   ; possible control character?
	  ja	  sd_norml	   ; if not control character, jump
	  cmp	  AL,CTL_A	   ; nul character?
	  jb	  sd_next	   ; if nul character, ignore it (jump)
	  cmp	  AL,CTL_I	   ; tab character?
	  jne	  sd_notab	   ; if not a tab, jump
;     TAB character-- output a series of blanks
	  mov	  AL," "	   ; load a blank to store one or more times
	  mov	  AH,CL		   ; copy cursor position
	  sub	  AH,[BP].sd_linum ;  and adjust for line number
sd_tloop: stosb			   ; store a blank to the output buffer
	  inc	  CX		   ; increment the current column number
	  inc	  AH
	  test	  AH,07h	   ; is next column a multiple of eight?
	  jnz	  sd_tloop	   ; if not, loop
	  jmp	  sd_test
;     "normal" control character-- prefix with "^"
sd_notab: mov	  AH,AL		   ; save control character
	  mov	  AL,"^"	   ; load a "^" character and output to buffer
	  stosb
	  inc	  CX
	  mov	  AL,AH		   ; copy control character to AL and
	  add	  AL,"A"-CTL_A	   ;  compute alphabetic for said
;     non- control character-- just copy to output buffer
sd_norml: stosb			   ; store character into output buffer
	  inc	  CX		   ; increment the current column number
sd_test:  cmp	  CX,BX		   ; line full?
	  jb	  sd_next	   ; if more room on current line, loop

;     Full line buffered-- display it on the screen
	  call	  flush		   ; display line
	  mov	  AX,[BP].sd_cline ; load the current line number
	  cmp	  AX,[BP].sd_nline ; are we at the end of the screen?
	  jl	  sd_next	   ; if more lines in window, jump
;     Window full-- set cursor position to last line + 1, column 0
	  les	  SI,dword ptr [BP].sd_wn_SI ; load pointer to window object
	  mov	  ES:[SI].pt_ccol,0 ; set next column number to zero
	  mov	  CX,[BP].sd_cline ; store next line number into window
	  mov	  ES:[SI].pt_cline,CX ; object, too
	  jmp	  sd_fin	   ; window full, jump

;     end of string-- output final line
sd_final: push	  ES		   ; save pointer to data segment
	  les	  SI,dword ptr [BP].sd_wn_SI ; load pointer to window object
	  mov	  AX,CX		   ; save current column
	  mov	  ES:[SI].pt_ccol,CX ; store next column into window object
	  mov	  CX,[BP].sd_cline ; store current line number into window
	  mov	  ES:[SI].pt_cline,CX ; object, too
	  pop	  ES		   ; restore pointer to data segment
	  mov	  CX,SD_BSIZE-1    ; load buffer length
	  sub	  CX,AX		   ; subtract number of columns in buffer
	  mov	  AL," "	   ; load a blank
rep	  stosb			   ; blank the remainder of output buffer
	  mov	  [BP].sd_last,1   ; indicate last line
	  call	  flush		   ; display to screen
sd_fin:	  pop	  DS		   ; restore DS

;**********************************************************************
;* * * Warning:  The data segment register (DS) does not point to * * *
;* * *		 the data segment in the code above		  * * *
;**********************************************************************

;     Operation complete-- return to Scheme interpreter
sd_done:  mov	  SP,BP		   ; clean up anything pushed on stack
	  add	  SP,offset sd_BP  ; deallocate local storage
	  pop	  BP		   ; restore Scheme interpreter's BP
	  jmp	  next_PC	   ; return to Schemem interpreter

strdisp   endp

;************************************************************************
;*	      Local Support:  Flush Output Buffer to Screen		*
;*									*
;* Input Parameters:  ES - points to data segment			*
;************************************************************************
	  public  flush	
flush	  proc	  near
	  pushm	  <DS,SI,DI,CX,DX> ; save valuable registers
;     Make DS register point to data segment
	  mov	  AX,ES
	  mov	  DS,AX

;     Test for negative bias
	  inc	  [BP].sd_bias	   ; increment and test "bias" value
	  jg	  fl_no_bs	   ; if zero or positive, no bias (jump)
	  jmp	  fl_bias	   ; if negative, don't display current line
;     Position the cursor in the current column position
fl_no_bs: mov	  DL,byte ptr [BP].sd_cline ; load the current cursor
	  mov	  DH,byte ptr [BP].sd_ccol  ;  position
	  add	  DL,byte ptr [BP].sd_ullin ; adjust cursor positon by
	  add	  DH,byte ptr [BP].sd_ulcol ;  coordinates of upper left corner
	  mov	  [BP].sd_cursv,DX ; save the cursor coordinates
IFNDEF PROMEM
	  xor	  BH,BH		   ; IBMism (page 0 for text-mode)
	  mov	  AH,02h	   ; load "put cursor" code
	  call	  CRT_DSR	   ; put cursor at current position
ENDIF
;     Display the line
	  mov	  CX,[BP].sd_ncols ; load line length
	  sub	  CX,[BP].sd_ccol  ; subtract starting column offset
;     Replace the "last" character in line with an exclamation mark
	  cmp	  [BP].sd_last,0   ; last line to be output?
	  jnz	  fl_last	   ; if last line, leave character alone (jump)
	  mov	  SI,CX		   ; copy character count
	  mov	  AL,"!"	   ; load an exclamation mark
	  xchg	  AL,[BP]+sd_buff+[SI]-1   ; swap with final character in line
	  mov	  [BP].sd_char,AL  ; save character to later viewing

	  public  fl_last
fl_last   label   near
IFDEF PROMEM
	  buffer_is_stack 	   ;treat comm buffer as stack
	  mov	  [BP].sd_len,cx   ;save character count
	  REALIO  REAL_WRTBLOCK,sd_len,sd_cursv,continue
	  buffer_is_buffer	   ;treat comm buffer as buffer
ELSE
;     Determine PC make
	  cmp	  PC_MAKE,TIPC	   ; on what flavor PC are we running?
	  jne	  fl_ibm	   ; if an IBM, jump
;     Write line to TIPC's screen
	  mov	  AL,byte ptr [BP].sd_text ; load text attributes
	  mov	  AH,010h	   ; load "write block w/ attr" code
	  mov	  DX,DS		   ; load segment address
	  mov	  BX,BP
	  add	  BX,sd_buff	   ; load buffer offset in segment	   
	  int	  TI_CRT	   ; write the buffer
	  jmp	  fl_back

;     Write line to IBM's screen
fl_ibm:	  mov	  DI,BP
	  add	  DI,sd_buff	   ; load buffer offset
	  mov	  DX,[BP].sd_cursv ; reverse row/column coordinates
	  xchg	  DL,DH
	  mov	  [BP].sd_cursv,DX
	  push	  CX		   ; save the character counter
	  jmp	  short fl_imidl   ; jump into middle of loop

fl_iloop: push	  CX		   ; save the character counter
	  mov	  DX,[BP].sd_cursv ; load the previous cursor coordinates,
	  inc	  DL		   ;  increment the column number
	  mov	  [BP].sd_cursv,DX ;  and save new coordinates
	  xor	  BH,BH		   ; page number (0 for graphics mode) IBMism
	  mov	  AH,02h	   ; load "put cursor" code
	  push	  DI
	  int	  IBM_CRT
	  pop	  DI
fl_imidl: mov	  AH,09h	   ; Load "write char w/ attributes" code
	  mov	  AL,byte ptr [DI] ; load character from buffer
	  mov	  BL,byte ptr [BP].sd_text ; load attribute bits
	  xor	  BH,BH		   ; page # for alpha mode
	  mov	  CX,1		   ; load repeat count = 1
;     test to see if we buy anything by using a repeat count
	  pop	  DX		   ; restore character count
fl_imore: cmp	  DX,1		   ; more characters to display?
	  jle	  fl_ibotm	   ; if no more characters, jump
	  cmp	  AL,byte ptr [DI]+1 ; is next character the same as previous?
	  jne	  fl_ibotm	   ; if not same character, jump
	  inc	  CX		   ; increment the repeat count
	  inc	  DI		   ; increment the output buffer index
	  inc	  byte ptr [BP].sd_cursv ; increment the cursor position
	  dec	  DX		   ; decrement the character count
	  jmp	  fl_imore	   ; try for another
fl_ibotm: push	  DX		   ; save the adjusted character count
;     output the character(s)
	  push	  DI		   ; save the output buffer index
	  int	  IBM_CRT	   ; write character with attributes
	  pop	  DI		   ; restore the output buffer index
	  pop	  CX		   ; restore character counter
	  inc	  DI		   ; increment buffer pointer
	  loop	  fl_iloop	   ; continue 'til all characters output
ENDIF

;     Restore last character in line to its rightful value
fl_back:  mov	  SI,[BP].sd_ncols
	  sub	  SI,[BP].sd_ccol
	  mov	  AL,[BP].sd_char
	  mov	  [BP]+sd_buff+[SI]-1,AL

;     Shift buffer to remove the line just displayed
	  inc	  [BP].sd_cline	   ; increment the line number
fl_bias:  mov	  SI,[BP].sd_ncols ; compute number of characters just output
	  sub	  SI,[BP].sd_ccol  ;  (unless bias < 0, in which case we just
	  dec	  SI		   ;   branched here)
	  push	  SI		   ; save character count
	  mov	  CX,10		   ; make up a character count for move
	  mov	  DI,BP		   ; load address of buffer start
	  add	  DI,sd_buff
	  add	  SI,BP		   ; load address of leftover characters
	  add	  si,sd_buff
rep	  movsb			   ; shift any characters left over
          mov     BX,[BP].sd_ccol  ;;; new code for fix
                                   ;;; save the current column for adjust
	  mov	  [BP].sd_ccol,0   ; set current column to zero
	  inc	  [BP].sd_linum	   ; increment formatting line number
	  
;     Reset Active Registers to reflect shifted buffer
	  pop	  AX		   ; restore output character count
	  popm	  <DX,CX,DI,SI>	   ; restore control registers
	  sub	  DI,AX		   ; adjust buffer index
	  sub	  CX,AX		   ; adjust current column
          sub     CX,BX            ;;; new code for fix
                                   ;;; adjust current column
	  mov	  BX,[BP].sd_ncols ; reload line length
	  pop	  DS		   ; restore DS register
	  ret			   ; return
flush	  endp

;************************************************************************
;* Local Support:  Fetch and Validate Integer Argument			*
;*									*
;* Input Parameters:  BX - address of register containing the integer	*
;*			  argument					*
;*									*
;* Output Parameters:  If CARRY off, normal return:			*
;*			  AX - the 16 bit positive integer value	*
;*		       If CARRY on, error:				*
;*			  AX - the error condition; 0=operand not an	*
;*				integer; 1=integer operand was negative	*
;*				or larger than 16 bits.			*
;************************************************************************
	  public  get_num
get_num	  proc	  near
;     test for a fixnum argument
	  cmp	  byte ptr [BX].C_page,SPECFIX*2 ; fixnum?
	  jne	  big_p		   ; if not a fixnum, test for bignum (jump)
	  mov	  AX,[BX].C_disp   ; load immediate value of fixnum
	  test	  AX,04000h	   ; negative?
	  jnz	  get_val	   ; if negative, error (jump)
	  ret			   ; if positive, return with value in AX

;     test for a bignum argument
big_p:	  mov	  SI,[BX].C_page   ; load page number of argument
	  cmp	  byte ptr ptype+[SI],BIGTYPE*2 ; is argument a bignum?
	  jne	  get_type	   ; if not a bignum, invalid type (jump)
	  %LoadPage ES,SI
;;;	  mov	  ES,pagetabl+[SI] ; load paragraph address of bignum's page
	  mov	  SI,[BX].C_disp   ; load displacement of bignum
	  cmp	  ES:[SI].big_sign,0 ; test sign of bignum
	  jne	  get_val	   ; if negative, error (jump)
	  cmp	  ES:[SI].big_len,BLK_OVHD+WORDINCR+1 ; test size of bignum
	  jne	  get_val	   ; if too large, error (jump)
	  mov	  AX,ES:[SI].big_data ; load 16 bit value of bignum
	  clc
	  ret			   ; return with value in AX
;     ***error-- operand is not an integer***
get_type: mov	  AX,0		   ; indicate operand wrong type
	  jmp	  short get_err
;     ***error-- integer operand is negative, or too large***
get_val:  mov	  AX,1		
get_err:  stc
	  ret
get_num	  endp

;************************************************************************
;* Local Support:  Return a 16 bit positive integer value		*
;*									*
;* Input Parameters:  BX - address of destination register		*
;*		      SI - 16 bit unsigned integer value to be returned *
;*									*
;* Output Parameters:  The Scheme representation of the 16 bit unsigned	*
;*			value is placed into the destination register.	*
;************************************************************************
	  public  ret_num
ret_num	  proc	  near
	  cmp	  SI,03fffh	   ; can result be represented as a fixnum?
	  ja	  make_big	   ; if not, create a bignum
;     return a fixnum result
	  mov	  byte ptr [BX].C_page,SPECFIX*2 ; set tag=fixnum
	  mov	  [BX].C_disp,SI   ; store value
	  ret			   ; return
;     return a bignum result
make_big: 
	  push    SI	   	   ; save value around call
	  push	  BX		   ; save destination reg also

	  mov	  CX,WORDINCR+1    ; load size of bignum desired
	  mov	  AX,BIGTYPE	   ; load type = bignum
	  pushm	  <CX,AX,BX>	   ; push arguments to allocate block
	  call	  %allocbl	   ; allocate the bignum
	  add	  SP,WORDINCR*3	   ; drop arguments off stack

	  pop	  BX		      ; restore destination reg
	  mov	  SI,[BX].C_page      ; get page number of new bignum
	  %LoadPage ES,SI	      ; and fetch its segment address
	  mov	  SI,[BX].C_disp      ; load the bignum's displacement
	  mov	  ES:[SI].big_sign,0  ; set bignum's sign to '+'
	  pop	  AX		      ; restore value and
 	  mov	  ES:[SI].big_data,AX ; store it into the bignum
	  ret			      ; return
ret_num	  endp


PROGX	  ends

prog	  segment byte public 'PROG'
	  assume  CS:PGROUP
;************************************************************************
;* Long Linkage to SUBSTRING-FIND-NEXT-CHAR-IN-SET			*
;************************************************************************
	  public  srch_nxt
srch_nxt  proc	  near
	  call	  %srchnxt
	  ret
srch_nxt  endp

;************************************************************************
;* Long Linkage to SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET			*
;************************************************************************
	  public  srch_prv
srch_prv  proc	  near
	  call	  %srchprv
	  ret
srch_prv  endp

;************************************************************************
;* Long Linkage to STRING-LENGTH					*
;************************************************************************
	  public  st_len
st_len	  proc	  near
	  call	  %st_len
	  ret
st_len	  endp

;************************************************************************
;* Long Linkage to MAKE-STRING						*
;************************************************************************
;;;	  public  make_str
make_str  proc	  near
	  call	  %makestr
	  ret
make_str  endp

;************************************************************************
;* Long Linkage to REIFY_STACK						*
;************************************************************************
	  public  reif_stk
reif_stk  proc	  near
	  call	  %reifstk
	  ret
reif_stk  endp

;************************************************************************
;* Long Linkage to REIFY_STACK!						*
;************************************************************************
	  public  reif_stb
reif_stb  proc	  near
	  call	  %reifstb
	  ret
reif_stb  endp

prog	  ends
	  end