pcs/prosprin.asm

1403 lines
48 KiB
NASM
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

; ======> PROSPRIN.ASM
;************************************************************************
;* PC Scheme Runtime Support - Sexpression Print Routines *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* *
;* Modifications: *
;* *
;* 11/27/87 (tc) Rewritten for protected mode scheme. Also *
;* modified to buffer the output more effectively. *
;* *
;************************************************************************
page 60,132
title PC Scheme Print Handlers
include scheme.equ
include sinterp.arg
include xli_pro.mac
NUMBER_SPECIAL_CHARS equ 8 ;special chars defined in cread.asm
RETURN equ 0Dh
SPACE equ 20h
SYM_OVHD equ 7
HEAPERR equ -3
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public display, show, ccount
;from sread.asm
extrn test_ch:word
extrn t_array:word
;from xli_pro.asm
extrn rpc_handle:byte
extrn REAL_MODE_BUFFER:dword
extrn REAL_BUF_OFFSET:word,REAL_BUF_SELECTOR:word
extrn REAL_BUF_PARA:word,REAL_BUF_TOP:WORD
;from iosupport.asm
extrn port_seg:word,port_pg:word,port_ds:word
;from ???
extrn hicases:byte
;Table of strange characters used by printatm
stranges db " ,'"
db ';":()`'
db 13,12,11,10,9,0
;
; The following global data is used to tell the print handlers about
; the print characteristics, ie. to surround strings with double quotes,
; to display escape characters, etc.
;
;
display dw 0 ; whether to surround atoms/strings with | or "
show dw 1 ; whether actually printing chars or not
ccount dw 0 ; char count used to determine print length
;
; Branch table of all Scheme object print handlers
;
branchtab dw sp_list ; [0] LISTTYPE
dw sp_fix ; [1] FIXTYPE
dw sp_flo ; [2] FLOTYPE
dw sp_big ; [3] BIGTYPE
dw sp_sym ; [4] SYMTYPE
dw sp_str ; [5] STRTYPE
dw sp_ary ; [6] ARYTYPE
dw sp_cont ; [7] CONTTYPE
dw sp_clos ; [8] CLOSTYPE
dw sp_free ; [9] FREETYPE
dw sp_code ; [10] CODETYPE
dw subp_ret ; [11] REFTYPE
dw sp_port ; [12] PORTTYPE
dw sp_char ; [13] CHARTYPE
dw sp_env ; [14] ENVTYPE
;
; Following text will be output for those objects which have not
; printable representations.
;
port_str db "#<PORT>",0
parens db "()",0
cont_str db "#<CONTINUATION>",0
ary_str db "#("
free_str db "#<FREE>",0
code_str db "#<CODE>",0
env_str db "#<ENVIRONMENT>",0
clos_str db "#<PROCEDURE",0
;
; Following are error messages
;
sp1_er db "WRITE",0
spc_er db "DISPLAY",0
spt_er db "PRINT",0
new_er db "NEWLINE",0
deep_str db "#<DEEP!>",0
ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0
bad_set db "[VM INTERNAL ERROR] setadr: bad port",CR,LF,0
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
extrn next_SP:near
extrn src_err:near
extrn get_port:near
extrn setabort:near,abort:near
extrn take_cdr:near,restart:near,stkspc:near
extrn copybig:near,fix2big:near,big2asc:near,get_flo:near
extrn isspace:near
extrn gvchars:near,ssetadr:near
extrn scannum:near
comment | Commented out 2/10/88 by TC - moved to realio routine
;******************************************************************************
;WRAP - Local macro definition. If there are less than LEN spaces left on
; the local output line, make AX non-zero to denote wrap necessary.
;
; Note: es:di are destroyed
;******************************************************************************
wrap macro len,result
local wrapend
push es
push di
xor result,result ;result = default no wrap
cmp show,0 ;are we actually printing?
jz wrapend ; no, just return with default
LoadPage es,port_pg
mov di,port_ds ;es:di => port object
cmp es:[di].pt_ncols,0 ;maintaining line length?
jz wrapend ; no, return default
cmp es:[di].pt_ccol,1 ;in the first column already?
jle wrapend ; yes, return default
mov result,es:[di].pt_ncols ;ax = number cols
sub result,es:[di].pt_ccol ;ax = remaining spaces
cmp result,len ;any room left?
mov result,0 ;
jge wrapend ; yes, return nowrap flag
inc result ; no, return wrap flag
wrapend:
pop di
pop es
endm
|
prn_proc proc near
;;;****************************************************************************
;;; VM Opcode handler for "WRITE"
;;;
;;; Print an S-Expression with slashification
;;;
;;;****************************************************************************
public spprin1
spprin1: lods word ptr ES:[SI] ; load register operand
save <SI>
xor BX,BX
mov BL,AH
add BX,offset reg0 ; BX = port object
xor AH,AH
add AX,offset reg0 ; AX = s-expression pointer
mov DI,AX
save <DI>
mov CX,1 ; write indicator
pushm <CX, BX>
C_call get_port,,Load_ES ; get port address
mov SP,BP
test AX,AX ; check return status
jz sp1_010
lea BX,sp1_er
jmp src_err ; link to error handler
sp1_010:
inc AX
mov display,AX
mov show,AX
pushm <tmp_disp, tmp_page>
restore <DI>
mov BX,[DI].C_page
shr BX,1
pushm <[DI].C_disp, BX>
call sprint ; write
mov SP,BP
sp1_020: restore <DI> ; get the register pointer
mov [DI].C_page,NPR_PAGE*2 ; return as non-printable object
mov [DI].C_disp,NPR_DISP
mov display,0 ; default display = no
jmp next_SP ; return to interpreter
;;;****************************************************************************
;;; VM Opcode handler for "DISPLAY"
;;;
;;; Print an S-Expression without slashification
;;;
;;;****************************************************************************
public spprinc
spprinc: lods word ptr ES:[SI] ; load register operand
save <SI>
xor BX,BX
mov BL,AH
add BX,offset reg0 ; BX = port object
xor AH,AH
add AX,offset reg0 ; AX = s-expression pointer
mov DI,AX
save <DI>
mov CX,1
pushm <CX, BX>
C_call get_port,,Load_ES ; get port address
mov SP,BP
test AX,AX ; check return status
jz spc_010
lea BX,spc_er
jmp src_err ; link to error handler
spc_010: mov display,AX
inc AX
mov show,AX
pushm <tmp_disp, tmp_page>
restore <DI>
mov BX,[DI].C_page
shr BX,1
pushm <[DI].C_disp, BX>
call sprint ; display
mov SP,BP
jmp sp1_020
;;;****************************************************************************
;;; VM Opcode handler for "PRINT"
;;;
;;; Print an S-Expression with spacing control
;;;
;;;****************************************************************************
public spprint
spprint: lods word ptr ES:[SI] ; load register operand
save <SI>
xor BX,BX
mov BL,AH
add BX,offset reg0 ; BX = port object
xor AH,AH
add AX,offset reg0 ; AX = s-expression pointer
mov DI,AX
save <DI>
mov CX,1
pushm <CX, BX>
C_call get_port,,Load_ES ; get port address
mov SP,BP
test AX,AX ; check return status
jz spt_010
lea BX,spt_er
jmp src_err ; link to error handler
spt_010: mov display,AX
inc AX
mov show,AX
mov DX,SPECCHAR
mov BX,RETURN ; carriage return
pushm <tmp_disp, tmp_page, BX, DX>
call sprint ; print it
mov SP,BP
xor AX,AX
inc AX
mov show,AX
mov display,AX
pushm <tmp_disp, tmp_page>
restore <DI>
mov BX,[DI].C_page
shr BX,1
pushm <[DI].C_disp, BX>
call sprint ; print the s-expression
mov SP,BP
mov BX,SPACE
mov DX,SPECCHAR ; space
xor AX,AX
mov display,AX
inc AX
mov show,AX
pushm <tmp_disp, tmp_page, BX, DX>
call sprint ; print it
mov SP,BP
jmp sp1_020
;;;****************************************************************************
;;; VM Opcode handler for "NEWLINE"
;;;
;;; Output a newline character
;;;
;;;****************************************************************************
public spnewlin
spnewlin: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; AX = port object
mov CX,1
pushm <CX, AX>
C_call get_port,,Load_ES ; get port address
mov SP,BP
test AX,AX ; check return status
jz new_010
lea BX,new_er
jmp src_err ; link to error handler
new_010: mov display,AX
inc AX
mov show,AX
mov BX,SPECCHAR
mov DX,RETURN ; carriage return
pushm <tmp_disp, tmp_page, DX, BX>
call sprint
mov SP,BP
mov display,0 ; default display = no
jmp next_SP ; return to interpreter
;;;****************************************************************************
;;; VM Opcode handler for "LINE-LENGTH"
;;;
;;; Determine the print length of a scheme object
;;;
;;;****************************************************************************
public prt_len
prt_len: lods byte ptr ES:[SI] ; load register operand
save <SI>
add AX,offset reg0 ; AX = port object
mov DI,AX
xor CX,CX
mov display,CX ; no display and show
mov show,CX
save <DI>
mov DX,OUT_PAGE*2
mov CX,OUT_DISP
mov BX,[DI].C_page
shr BX,1 ; correct page number
pushm <CX, DX, [DI].C_disp, BX>
call sprint
mov SP,BP ; AX = print length
restore <DI>
mov [DI].C_page,SPECFIX*2
mov [DI].C_disp,AX ; get the print length
jmp next_SP ; return to interpreter
prn_proc endp
;**************************************************************************
; SPRINT - Sexpression print routine
;
; Calling Sequence: sprint(pds,ppg,dis,pg)
;
; Where: ppg:pds = page:displacement of port to output to
; pg:dis = scheme object to output
;
; Upon Exit: AX = number of characters printed
;
;**************************************************************************
spt_arg struc
dw ? ;caller's BP
dw ? ;caller's return address
pg dw ? ;page num of object to print
dis dw ? ;page disp of object to print
ppg dw ? ;page num of output port
pds dw ? ;page disp of output port
spt_arg ends
public sprint
sprint proc near
push BP
mov BP,SP ;set up stack
call setabort ;set address when abort
pushm <[BP].pds, [BP].ppg>
call ssetadr ;set port address
mov SP,BP
;fix for random i/o - note a write has taken place
mov AX,ES ;save extra segment
LoadPage ES,port_pg ;address port
mov SI,port_ds
or byte ptr ES:[SI].pt_pflgs,DIRTY ;note write has occurred
mov ES,AX ;restore extra segment
mov ccount,0 ;clear character count
pushm <[BP].dis, [BP].pg>
call subsprin ;go print the object
mov SP,BP
mov AX,ccount ;return number of characters
pop BP
ret ;return to caller
sprint endp
;**************************************************************************
; SUBSPRIN - Recursive print routine
;
; Calling Sequence: subsprin(dis,pg)
;
; Where: dis = displacement with pg of object to print
; pg = page of object to print
;
;**************************************************************************
public subsprin
subp_arg struc
tmp_reg1 dw ?
tmp_reg2 dw ?
tmp_reg3 dw ?
lst_pag dw ?
lst_dsp dw ?
subp_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
spg dw ? ; page number
sdis dw ? ; displacement
subp_arg ends
subsprin proc near
push ES
push BP
sub SP,offset subp_BP ;allocate local storage
mov BP,SP
cmp s_break,0 ;check for SHIFT-BREAK
je subp_10
kill_out: mov AX,RETURN ;carriage return
call printcha
mov AX,41 ;length of message
lea BX,ab_write
pushm <AX, BX>
call printtxt ;display message
mov SP,BP
cmp show,0
je kill_01
xor AX,AX
jmp kill_02
kill_01: mov AX,2
kill_02: push AX ;instruction length
C_call restart ;link to scheme debugger
;control does not return to here
subp_10: call stkspc ;check stack space
cmp AX,64 ;stack low?
jge subp_20 ;no, jump
mov AX,8
lea BX,deep_str ;#<DEEP!>
jmp subp_ret ;print message and return
; act on object type
subp_20:
shl [BP].spg,1 ;adjust page number
mov BX,[BP].spg
mov DI,ptype+[BX] ;get page type
jmp branchtab+[DI] ;envoke appropriate handler
;
; any problems with getmem should exit here
mem_err:
mov AX,HEAPERR ;memory not available
push AX
call abort
mov SP,BP
;
; return to caller
subp_ret:
add SP,offset subp_BP ;release local storage
pop BP
pop ES
ret
page 60,132
;-----------------------------------------------------------------------------
;
; Following are the print handlers for each object type, they will be invoked
; via an indirect call through BRANCHTAB.
;
; Upon entry: BX = an adjusted page number
; DI = the page type
;
; Upon exit: Jump to SUBP_RET for cleanup
;
;-----------------------------------------------------------------------------
;*******************************************************************************
;
; Print representation for code block object
;
;*******************************************************************************
public sp_code
sp_code: mov AX,7
lea BX,code_str ; #<CODE>
jmp subp_txt
;*******************************************************************************
;
; Print representation for continuation object
;
;*******************************************************************************
public sp_cont
sp_cont: mov AX,15
lea BX,cont_str ; #<CONTINUATION>
jmp subp_txt
;*******************************************************************************
;
; Print representation for environment object
;
;*******************************************************************************
public sp_env
sp_env: mov AX,14
lea BX,env_str ; #<ENVIRONMENT>
jmp subp_txt
;*******************************************************************************
;
; Print representation for free page
;
;*******************************************************************************
public sp_free
sp_free: mov AX,7
lea BX,free_str ; #<FREE>
jmp subp_txt
;*******************************************************************************
;
; Print representation for port object
;
;*******************************************************************************
public sp_port
sp_port: mov AX,7
lea BX,port_str ; #<PORT>
subp_txt:
pushm <AX, BX> ;ax = length, bx = message address
call printtxt ;print the message
mov SP,BP ;clean up stack
jmp subp_ret ;and return to caller
;*******************************************************************************
;
; Print floating point value
;
;*******************************************************************************
public sp_flo
sp_flo: mov SI,[BP].sdis ; displacement
shr BX,1 ; corrected page number
pushm <SI, BX>
call get_flo ; get a floating point value
pushm <AX, BX, CX, DX> ; in AX:BX:CX:DX
C_call printflo,,Load_ES
mov SP,BP
jmp subp_ret
;*******************************************************************************
;
; Print list
;
;*******************************************************************************
public sp_list
sp_list:
test bx,bx ;null page?
jnz sp_l01 ; no, go chase list
mov ax,2
lea bx,parens
pushm <ax, bx>
call printtxt ;print "()" for null list
mov sp,bp
jmp subp_ret
sp_l01:
mov al,byte ptr parens
call printcha ;print open paren
mov bx,[bp].spg
LoadPage es,bx
mov si,[bp].sdis ;es:si => list cell
sp_l02:
mov [bp].lst_pag,bx
mov [bp].lst_dsp,si ;save list cell
xor dh,dh
mov dl,byte ptr es:[si] ;get car of list
shr dx,1 ; make number for subsprin
mov cx,word ptr es:[si+1] ;get car's displacement
pushm <cx, dx>
call subsprin ;print car of list
mov sp,bp
mov bx,[bp].lst_pag ;restore list cell
LoadPage es,bx
mov si,[bp].lst_dsp
mov bl,byte ptr es:[si+3] ;get cdr of list
mov si,word ptr es:[si+4]
test bx,bx ;is it null?
jz sp_l04 ; yes, finished
pushm <si,bx> ;tempsave si,bx
mov al,' '
call printcha ;print space as item seperator
popm <bx,si> ;restore stack
LoadPage es,bx ;reload page of cdr
cmp byte ptr ptype+[bx],LISTTYPE*2 ;is cdr a list cell?
je sp_l02 ; yes, chase the list
; cdr is not a list cell - improper list
mov dx," ." ;need " ." due to byte swapping
pushm <si,bx,dx> ;tempsave si,bx - dx is text
mov si,sp
mov dx,2
pushm <dx,si> ;push length, address of text
call printtxt ;print ". "
add sp,6 ;dump last 3 args
popm <bx,si> ;restore saved regs
shr bx,1 ;make page a number for subsprin
pushm <si, bx>
call subsprin ;go chase last cdr
mov sp,bp ;dump args off stack
sp_l04:
mov al,byte ptr parens+1
call printcha ;and print it
mov sp,bp
jmp subp_ret ;return to caller
;*******************************************************************************
;
; Print array
;
;*******************************************************************************
public sp_ary
sp_ary: mov AX,2
LoadPage ES,BX ; page segment
lea BX,ary_str ; print "#("
pushm <AX, BX>
call printtxt
mov SP,BP
LoadPage ES,[BP].spg ; Get page address of array
;;; mov ES,word ptr pagetabl+[BX]
mov SI,[BP].sdis ; and segment
mov CX,word ptr ES:[SI+1]
sub CX,BLK_OVHD ; length of array
mov BX,BLK_OVHD
mov [BP].tmp_reg1,CX
sp_a01:
cmp BX,[BP].tmp_reg1
jle sp_a04
jmp sp_l04
sp_a04: mov AL,byte ptr ES:[SI+BX] ; AX <= page of array element
mov DX,word ptr ES:[SI+BX+1] ; DX <= disp. of array element
xor AH,AH
shr AX,1 ; Page number for subsprin
mov [BP].tmp_reg2,BX ; Save registers
mov [BP].lst_dsp,SI
pushm <DX, AX>
call subsprin ; print element
mov SP,BP
mov BX,[BP].tmp_reg2 ; restore BX
cmp BX,[BP].tmp_reg1 ; last element?
jge sp_a02
mov ax,SPACE ; print ' '
call printcha
mov BX,[BP].tmp_reg2 ; restore registers
sp_a02: mov SI,[BP].lst_dsp
add BX,PTRSIZE
LoadPage ES,[BP].spg ; Reload page address of array
jmp sp_a01
;*******************************************************************************
;
; Print representation for closure object
;
;*******************************************************************************
public sp_clos
sp_clos: mov ax,11
lea bx,clos_str
pushm <ax,bx>
call printtxt ;print "#<PROCEDURE"
mov SP,BP
; get info operand from closure object
LoadPage es,[bp].spg
mov si,[bp].sdis ;es:si => closure object
lea bx,[bp].tmp_reg1
xor ah,ah
mov al,byte ptr es:[si+3] ;pag # of information op
mov [bx].C_page,ax ; save in tmp_reg1
mov ax,word ptr es:[si+4] ;displ of information op
mov [bx].C_disp,ax ; save in tmp_reg1
; follow info operand list
sp_c001:
mov di,[bx].C_page
cmp di,0 ;if reached end of list
je sp_c04 ; then exit loop
cmp byte ptr ptype+[di],LISTTYPE*2 ;if cdr not list cell
jne sp_c01 ; then exit loop
push bx
call take_cdr ;follow cdr of list
lea bx,[bp].tmp_reg1
jmp sp_c001
; If final operand is a symbol, print it
sp_c01:
cmp byte ptr ptype+[DI],SYMTYPE*2 ;do we have a symbol?
jne sp_c04 ; no, jump
push bx ;tempsave reg around call
mov ax,SPACE
call printcha ;print ' '
pop bx ;restore reg
push display ;save around call
mov display,0 ;don't print escape chars
shr [bx].C_page,1 ;make page # for subsprin
pushm <[bx].C_disp,[bx].C_page> ;push page:disp of symbol
call subsprin ;go print the symbol
add sp,4 ;dump args off stack
pop display ;restore display indicator
sp_c04:
mov al,'>'
call printcha ;print '>'
mov SP,BP
jmp subp_ret
;*******************************************************************************
;
; Print symbol to output port
;
;*******************************************************************************
public printatm
printatm label near
sp_sym:
;
; Warning: local data segment is not used in code below
;
loadpage ds,bx
mov si,[bp].sdis ;ds:si => object
mov cx,[si]+1 ;get object length
sub cx,SYM_OVHD ;cx = length of atom
add SS:ccount,cx ;update character count
cmp SS:show,0 ;do we want to print the object?
jne pra_010 ; yes, continue
mov dx,ss ; no, restore data segment
mov ds,dx
jmp pra_exit ; and return
pra_010:
;cx = length of symbol
add si,SYM_OVHD ;ds:si => symbol name
GET_BUFFER ;es:di => real buffer
call atm2pbuf ;move printname to print buffer
;
; Warning: local data segment is not used in code above
;
mov dx,ss
mov ds,dx ;restore local data segment
cmp cx,0 ;if negative print length
jl pra_err ; then error, jump
;;; wrap cx,dx ;cx = length, dx = result
mov dx,1 ;check wrap flag
;cx = length, dx = check wrap flag, es:di => print buffer
call gvchars ;go print the buffer
pra_exit:
RLS_BUFFER
jmp subp_ret
pra_err:
jmp mem_err
;*******************************************************************************
;
; Print string to output port
;
;*******************************************************************************
public printstr
printstr label near
sp_str:
;
; Warning: local data segment is not used in code below
;
loadpage ds,bx
mov si,[bp].sdis ;ds:si => object
mov cx,[si]+1 ;cx = length indicator
add si,BLK_OVHD ;ds:si => actual string
or cx,cx ;small string?
jge prs_005 ; no, jump
add cx,BLK_OVHD+PTRSIZE
prs_005:
sub cx,BLK_OVHD ;cx = length of string
add SS:ccount,cx ;update character count
cmp SS:show,0 ;actually printing?
jne prs_010 ; yes, continue
mov dx,ss ; no, restore data segment
mov ds,dx
jmp pra_exit ; and return
prs_010:
;cx = string length
GET_BUFFER ;es:di => buffer for print string
call str2pbuf ;move string to print buffer
;
; Warning: local data segment is not used in code above
;
mov bx,ss ;restore local data segment
mov ds,bx
cmp cx,0 ;if negative print length
jl prs_err ; then error, jump
;;; wrap cx,dx ;cx=length, dx=result
mov dx,1 ;check wrap flag
;cx = length, dx = check wrap flag, es:di => print buffer
call gvchars ;go print the buffer
prs_exit:
RLS_BUFFER ;release the print buffer
jmp subp_ret
prs_err: jmp mem_err ;must be a long jump
;*******************************************************************************
;
; Print character to output port
;
;*******************************************************************************
public sp_char
sp_char:
cmp display,0 ;display escape chars?
jne sp_ch10 ; yes, jump
;print character without escapes
mov ax,[BP].sdis ;get character
xor ah,ah
call printcha ;call print routine
jmp subp_ret ;get outa here
;print character with escapes
sp_ch10:
mov bx,14 ;max size of character buffer
push bx
C_call getmem ;allocate space
mov sp,bp ;dump arg off stack
cmp ax,0
jne sp_ch00
jmp mem_err ;error allocating heap - jump
sp_ch00:
mov si,ax ;si => buffer
mov dx,ax ;dx => buffer
mov ax,[BP].sdis ;get character
mov byte ptr [si],23h ; #
mov byte ptr [si+1],5Ch ; \
mov byte ptr [si+2],AL ;character
mov byte ptr [si+3],0 ;end of string
mov bx,3 ;length
;
; see if character one of the multi-character constants in cread.asm
;
mov cx,ds
mov es,cx ;ensure ds=es
mov cx,NUMBER_SPECIAL_CHARS ;cx = counter
lea di,test_ch
add di,NUMBER_SPECIAL_CHARS-1 ;di => last special char
std
repne scasb ;search for special char
cld
jnz sp_ch20 ;if none found, jump
shl cx,1 ;make index into t_array
lea di,t_array
add di,cx
mov di,[di]
xchg si,di ;ds:si => character string
add di,2 ;es:di => character buffer
cld
xor al,al ;al = null terminator
sp_chlp:
movsb ;move byte into character buffer
cmp al,[si] ;reached terminator?
jne sp_chlp
sub di,dx ;calc length
mov bx,di
sp_ch20:
pushm <bx,dx> ;bx=buffer length, dx=buffer address
call printtxt ;print the character constant
mov SP,BP
mov bx,14 ;length of character buffer
pushm <bx,si>
C_call rlsmem ;release character buffer
mov sp,bp ;dump args off stack
jmp subp_ret
;*******************************************************************************
;
; Print integer value
;
;*******************************************************************************
public sp_fix
sp_fix: mov AX,5
mov [BP].tmp_reg2,AX
push AX
C_call getmem
mov SP,BP
or ax,ax
jnz sp_f10
jmp mem_err
sp_f10:
mov [BP].tmp_reg1,AX ; address of divider
mov SI,[BP].sdis ; get the value
shl SI,1
sar SI,1
pushm <AX, SI>
mov AX,DS
mov ES,AX ; get the right ES segment
call fix2big ; change to bignum
mov SP,BP
jmp printint
;*******************************************************************************
;
; Print bignum
;
;*******************************************************************************
public sp_big
sp_big: LoadPage ES,BX
mov SI,[BP].sdis
mov AX,word ptr ES:[SI+1] ; get object size
dec AX
mov [BP].tmp_reg2,AX
push AX
C_call getmem ; allocate memory for divider
mov SP,BP
cmp AX,0 ; memory available?
jne sp_big1
jmp mem_err ; no, error
sp_big1: mov [BP].tmp_reg1,AX ; address of divider
mov BX,[BP].spg
shr BX,1
pushm <AX, [BP].sdis, BX>
mov AX,DS
mov ES,AX ; get the right ES segment
call copybig ; copy bignum to buffer
printint:
mov AX,[BP].tmp_reg2
mov BX,3
mul BX
sub AX,5
mov [BP].lst_dsp,AX
push AX
C_call getmem ; allocate memory for char buffer
mov SP,BP
cmp AX,0 ; memory available?
jne sp_big2
jmp mem_err ; no, error
sp_big2: mov [BP].tmp_reg3,AX ; address of bigchars
pushm <AX,[BP].tmp_reg1>
call big2asc ; convert bignum to char string
mov SP,BP ; AX = characters count
pushm <AX, [BP].tmp_reg3>
call printtxt ; print the bignum
mov SP,BP
pushm <[BP].tmp_reg2, [BP].tmp_reg1>
C_call rlsmem
pushm <[BP].lst_dsp, [BP].tmp_reg3>
C_call rlsmem
mov SP,BP
jmp subp_ret
subsprin endp
; page 60,132
; title Print Handler Support Routines
;
;******************************************************************************
;PRINTTXT - C callable routine to print a string, first sending a newline
; character if necessary. The string is assumed to be in the
; local data segment.
;
; Calling Sequence: printtxt(string,len)
;
;******************************************************************************
str_arg struc
dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
str dw ? ; string pointer
len dw ? ; string length
str_arg ends
public printtxt
printtxt proc near
push es
push bp
mov bp,sp ;set up stack
mov cx,[bp].len ;cx = length of string
add ccount,cx ;keep track of character count
cmp show,0 ;show?
je pstr_ret ; no, return
push display
mov display,0
mov si,[bp].str ;ds:si => string to write
GET_BUFFER ;es:di => buffer for print string
call str2pbuf ;move string to print buffer
pop display
;;; wrap cx,dx ;cx=length, dx=result
mov dx,1 ;check wrap flag
;cx = length, dx = check wrap flag, es:di => print buffer
call gvchars ;go print the buffer
RLS_BUFFER ;release the print buffer
pstr_ret:
pop bp
pop es
ret
printtxt endp
;******************************************************************************
;PRINTCHA - C callable routine to print a character, first sending a newline
; character if necessary. At least for now, this is performed by
; calling gvchars - in the future we may want output routines for
; outputting individual characters.
;
; Upon Entry: al contains character to print
;
;******************************************************************************
pcha_arg struc
dw ? ;caller's BP
dw ? ;caller's ES
dw ? ;caller's return address
pcha_arg ends
public printcha
printcha proc near
push es
push bp
mov bp,sp ;set up stack
inc ccount ;bump character count
cmp show,0 ;if not actually printing
jz pcha_ret ; then return
comment |
;see if enough space left on current output line
LoadPage es,port_pg
mov di,port_ds ;es:di => port object
xor dx,dx ;dx = wrap flag (0 = nowrap)
mov cx,es:[di].pt_ncols ;maintaining line length?
jcxz pcha_010
sub cx,es:[di].pt_ccol ;cx = space remaining
cmp cx,1 ;any space left?
jge pcha_010
mov dx,1
|
mov dx,1 ;check wrap flag
pcha_010:
RESET_REAL_BUFFER_OFFSET
MOVE_BYTE_TO_BUF al,REAL_MODE_BUFFER
mov cx,1 ;cx = length
call gvchars
pcha_ret:
xor ax,ax
pop bp
pop es
ret
printcha endp
COMMENT %
The two routines below are written such that they may run either on the
hummingboard or out of 286/386 pritected memory. The hummingboard cannot
directly address the host's physical memory, so when displaying escape
chars within a string, it is first buffered into space allocated in the
heap, then written via a block move to the print buffer. Although this is
somewhat clumsy, it significantly improves performance over writing
individual bytes to the print buffer with the BLOCK-MOVE dos function
provided by OSx86.
If in the future the hummingboard os traps instructions which are writing
to real memory, then the buffering may be discarded and simple memory
moves may be performed.
%
;******************************************************************************
;ATM2PBUF - Move symbol printname to printbuffer
;
; Description:
; The symbol name pointed to by ds:si is moved into a print buffer for output.
;
; If the display flag is set, the symbol is being output by the "write" lisp
; function and all backslashes and vertical bars (\,|) are written to the
; buffer preceeded by a backslash. In addition, the symbol must also be
; surrounded by vertical bars (|) if lowercase letters, commas, semi-colons,
; and other strange characters are encountered; or if the printname is a
; ".", a name starting with a # (other than special symbols), or is numeric.
;
; If the display flag is not set, then the printname is moved to the buffer
; without performing any translation.
;
; Upon Entry:
; cx = length of printname
; ds:si => printname
; es:di => print buffer
;
; Upon Exit:
; cx = # characters placed in print buffer
; es:di => print buffer
;
;******************************************************************************
p_struc struc
dest_top dw ?
dest_start dw ?
heap_top dw ?
heap_str dd ?
src_start dw ?
src_str dd ?
dest_str dd ?
stlen dw ?
call_bp dw ?
p_struc ends
public atm2pbuf
atm2pbuf proc near
BUFFER_IS_BUFFER ;real mode buffer treated as such
cmp ss:display,0 ;displaying escape chars?
jnz a2p_xlat ; yes, jump
;move printname to print buffer
MOVE_TO_REAL_BUF ;move entire string over
ret ;return to caller
a2p_err:
mov [bp].stlen,-1
jmp a2p_fin
;move printname to print buffer, checking for backslashes and delimiters '|'
a2p_xlat:
push bp ;save callers bp
push cx ;save length
push es
push di ;save real buffer address
push ds
push si ;save string address
sub sp,src_str ;allocate local storage
mov bp,sp
mov [bp].src_start,si ;save start location of source string
mov [bp].dest_start,di ;save print buffer start
GET_REAL_BUFFER_TOP dx
sub dx,pt_bfend+20
mov [bp].dest_top,dx ;save print buffer end
mov ax,ss
mov ds,ax
mov es,ax ;setup for c call
mov ax,512
push ax
c_call getmem ;allocate 512 bytes of storage
add sp,2 ;dump arg from stack
cmp ax,0 ;allocation successful?
jne a2p_write ; no, go write the buffer
mov [bp].stlen,-1 ;indicate error
jmp a2p_fin2 ; and exit
a2p_write:
mov [bp].heap_top,510 ;note top of heap buffer
mov word ptr [bp].heap_str,ax ;save heap buffer address
mov word ptr [bp].heap_str+2,es
mov di,ax ;es:di = buffer
mov byte ptr es:[di],'|' ;start buffer with escape char
inc di ;di = address within buffer
mov dx,1 ;dx = # chars written
lds si,[bp].src_str ;ds:si addresses the string
mov cx,[bp].stlen ;cx = char count
xor bx,bx ;bh = strangeness
cmp cx,0 ;char count zero?
jne b2p_init ; no, jump
or bh,080h ; yes, mark as strange
jmp b2p_post ; and skip loop
b2p_init:
;dx = #chars written, di=heap buffer offset, si=string offset, cx=char count
b2plp:
cmp dx,[bp].dest_top ;room left in buffer?
jg a2p_err ; no, return error status
lodsb ;fetch char from printname
cmp al,'\' ;is char escape char?
je escit ; yes, jump
cmp al,'|' ;is char delimiter?
jne storit ; no, just go store it
escit:
mov byte ptr es:[di],'\' ;write escape char to buffer
inc di ;bump print buffer ptr
inc dx ;bump # chars written
storit:
stosb ;write char to buffer
inc dx ;bump # chars written
test bh,80h ;do we already know that atom's strange?
jnz skptest ; yes, skip following tests
;if lowercase letters or comma, semi-colon, etc. encountered, then it contains
;"strange" characters and must be delimited by '|'
push si ;tempsave pname offset
mov bl,al ;save copy of char in bl
lea si,hicases ;si => table of upper cases
xchg bx,si
mov ah,al ;save char
xlat ss:hicases ;fetch upper-case equivalent
xchg bx,si
cmp ah,al ;are chars different?
jne mrkstrng ; yes, indicate strangeness
mov si,offset stranges ;si => strange-character string
strnglp: lods byte ptr ss:[si] ;fetch strange char
or al,al ;finished searching for strange chars?
jz notstrng ; yes, exit loop
cmp ah,al ;Do we have a strange char?
jne strnglp ; no, try next
mrkstrng: or bh,80h ; yes, mark strange bit
notstrng:
pop si ;restore pname offset
skptest:
cmp di,[bp].heap_top ;heap buffer full?
jl a2p_cont ; no, continue
push cx ;save loop count
mov word ptr [bp].src_str,si ;update string pointer
sub di,word ptr [bp].heap_str ;calc number chars written
mov cx,di ; and save in cx
lds si,[bp].heap_str ;ds:si = heap buffer
les di,[bp].dest_str ;es:di = real mode buffer
MOVE_TO_REAL_BUF autoinc ;move string to print buffer
add word ptr [bp].dest_str,di ;update next location in real buffer
pop cx ;restore count
lds si,[bp].src_str ;ds:si = pointer into string
les di,[bp].heap_str ;es:di = heap allocated string ptr
a2p_cont:
loop b2plp ;look at next char in printname
; bh= strangeness, dx= #chars printed, di= end of printname
; write delimeter to heap allocated string, then copy to print buffer
b2p_post:
mov al,'|' ;follow with escape char
stosb ;write to heap buffer
inc dx ;bump character count
sub di,word ptr [bp].heap_str ;calc number chars written
mov cx,di ; and save in cx
lds si,[bp].heap_str ;ds:si = heap buffer
les di,[bp].dest_str ;es:di = real mode buffer
MOVE_TO_REAL_BUF autoinc ;move string to print buffer
mov [bp].stlen,dx ;save actual # chars written
mov ds,word ptr [bp].src_str+2
mov si,[bp].src_start ;ds:si => start of source string
test bh,80h ;do we already know atom's strange?
jnz a2p_fin ; yes, jump
; Check for ., #macro, or numeric confusion
cmp dx,3 ;a single char? (remember delimiters)
jne a2p_sharp ; no, jump
mov al,byte ptr ds:[si] ;get first byte of symbol
cmp al,'.' ;do we have a period - "." ?
je a2p_fin ; yes, delimits necessary
a2p_sharp:
cmp al,'#' ;macro designator?
jne a2p_num ; no, jump
cmp dx,3 ;a single sharp? (remember delimiters)
je a2p_fin ; yes, delimits necessary
cmp [bp].spg,SPECSYM*2 ;special symbol
je a2p_nodelim ; yes, no delimeters required
jne a2p_fin ; no, delimits necessary
a2p_num:
mov ax,10 ;check for number
push ax ;base 10
push si ;ds:si => printname
call scannum ;check for number
add sp,4 ;dump args from stack
test ax,ax ;is it a number?
jnz a2p_fin ; yes, jump
a2p_nodelim:
;although symbol being witten via "write", there are no stranges chars,
;or anything, so it can be written without delimiters.
inc [bp].dest_start ;position past initial delimiter
sub [bp].stlen,2 ;exclude delimeters from length
a2p_fin:
mov ax,ss
mov ds,ax ;set up data segment
mov es,ax ; and extra segment
mov bx,512 ;length of heap buffer
pushm <bx,word ptr [bp].heap_str>
C_call rlsmem, ;release character buffer
add sp,4 ;dump args off stack
a2p_fin2:
mov es,word ptr [bp].dest_str+2
mov di,[bp].dest_start ;es:di => real buffer start
mov cx,[bp].stlen ;cx = number characters written
lds si,[bp].src_str ;restore ds:si
add sp,call_bp ;dump args off stack
pop bp ;restore base pointer
ret
atm2pbuf endp
;******************************************************************************
;STR2PBUF - Move string to printbuffer
;
; Description:
; The print buffer is in real mode, the string is moved into the print
; buffer (possibly surrounded by quotes '"' and containing escape
; characters.
;
; Upon Entry:
; cx = length of string
; ds:si => string
; es:di => print buffer
;
; Upon Exit:
; cx = number of bytes written to print buffer
; es:di => print buffer
;
;******************************************************************************
public str2pbuf
str2pbuf proc near
BUFFER_IS_BUFFER ;real mode buffer treated as such
cmp ss:display,0 ;display escape chars?
jne s2p_xlat ; yes, jump
;move string to print buffer
MOVE_TO_REAL_BUF ;move string to print buffer
ret ;and return to caller
;move string to print buffer, inserting double quotes and escape chars
s2p_xlat:
push bp ;save callers bp
push cx ;save length
push es
push di ;save real buffer address
push ds
push si ;save string address
sub sp,src_str ;allocate local storage
mov bp,sp
mov [bp].dest_start,di ;save buffer start
GET_REAL_BUFFER_TOP dx
sub dx,pt_bfend+20
mov [bp].dest_top,dx ;save buffer end
mov ax,ss
mov ds,ax
mov es,ax ;setup for c call
mov ax,512
push ax
c_call getmem ;allocate 512 bytes of storage
add sp,2 ;dump arg from stack
cmp ax,0 ;allocation successful?
jne s2p_write ; no, go write the buffer
mov cx,-1 ;indicate error
jmp s2p_fin2 ; and exit
s2p_write:
mov [bp].heap_top,510 ;note top of heap buffer
mov word ptr [bp].heap_str,ax ;save heap buffer address
mov word ptr [bp].heap_str+2,es
mov di,ax ;es:di = buffer
mov byte ptr es:[di],'"' ;start buffer with escape char
inc di ;di = address within buffer
mov dx,1 ;dx = number chars written
mov cx,[bp].stlen
jcxz s2p_done ;jump if null string
lds si,[bp].src_str ;ds:si addresses the string
;dx = #chars written, es:di=heap buffer offset, ds:si=string offset
s2p_loop:
cmp dx,[bp].dest_top ;room left in buffer?
jg s2p_err ; no, return error status
lodsb ;fetch char from string
cmp al,'\' ;Is char escape char?
je s2p_esc ; yes, jump
cmp al,'"' ;Is char double quote?
jne s2p_stor ; no, just go store it
s2p_esc:
mov ah,al
mov al,'\'
stosb ;store escape character
inc dx ;bump # chars written
xchg al,ah
s2p_stor:
stosb ;store escape character
inc dx ;bump # chars written
cmp di,[bp].heap_top ;heap buffer full?
jl s2p_cont ; no, continue
push cx ;save loop count
mov word ptr [bp].src_str,si ;update string pointer
sub di,word ptr [bp].heap_str ;calc number chars written
mov cx,di ; and save in cx
lds si,[bp].heap_str ;ds:si = heap buffer
les di,[bp].dest_str ;es:di = real mode buffer
MOVE_TO_REAL_BUF autoinc ;move string to print buffer
add word ptr [bp].dest_str,di ;update next location in real buffer
pop cx ;restore count
lds si,[bp].src_str ;ds:si = pointer into string
les di,[bp].heap_str ;es:di = heap allocated string ptr
s2p_cont:
loop s2p_loop ;look at next char in printname
s2p_done:
mov al,'"' ;follow with escape char
stosb
inc dx
sub di,word ptr [bp].heap_str ;calc number chars written
mov cx,di ; and save in cx
lds si,[bp].heap_str ;ds:si = heap buffer
les di,[bp].dest_str ;es:di = real mode buffer
MOVE_TO_REAL_BUF autoinc ;move string to print buffer
mov cx,dx ;cx = actual # chars written
jmp s2p_fin ;finished
s2p_err:
mov cx,-1 ;indicate error
s2p_fin:
push cx ;save length around call
mov bx,512 ;length of heap buffer
pushm <bx,word ptr [bp].heap_str>
C_call rlsmem,,restore_es ;release character buffer
add sp,4 ;dump args off stack
pop cx
s2p_fin2:
lds si,[bp].src_str ;restore ds:si
mov es,word ptr [bp].dest_str+2
mov di,[bp].dest_start ;es:di => real buffer start
add sp,call_bp ;dump args off stack
pop bp ;restore base pointer
ret ;return
str2pbuf endp
prog ends
end