pcs/cprint1.asm

755 lines
24 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.

; =====> CPRINT1.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* S-Expression printing *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 10 Feb 1987 *
;* *
;* tc 2/10/87 fixed problem printing *
;* circular data structs *
;* rb 1/21/88 binary I/O uses *
;* line-length = 0; *
;* set dirty bit on writes *
;* (commented out) *
;* *
;***************************************
page 60,132
include scheme.equ
P_FLAGS equ 6
TEST_NUM equ 8
RETURN equ 0Dh
SPACE equ 20h
CUR_COL equ 12
N_COLS equ 20
SYM_OVHD equ 7
HEAPERR equ -3
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public display, show, detail, ccount
extrn port_seg:word
extrn port_d:word
extrn port_r:word
extrn direct:word
extrn test_ch:word
extrn t_array:word
ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0
deep_str db "#<DEEP!>",0
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
display dw 1 ; whether to use | and "
show dw 1 ; whether to send actual char
detail dw 1 ; whether to show detail
ccount dw 0 ; character count
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 sp_ref ; [11] REFTYPE
dw sp_port ; [12] PORTTYPE
dw sp_char ; [13] CHARTYPE
dw sp_env ; [14] ENVTYPE
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
spt_arg struc
dw ? ; caller's BP
dw ? ; caller's return address
pg dw ? ; location of item to be printed
dis dw ?
ppg dw ? ; location of output port
pds dw ?
spt_arg ends
extrn setabort:near
extrn ssetadr:near
public sprint
sprint proc near
push BP
mov BP,SP
call setabort ; set address when abort
xor AX,AX
mov ccount,AX
pushm <[BP].pds, [BP].ppg>
call ssetadr ; set port address
mov SP,BP
;fix for random i/o - note a write has taken place
lea SI,port_r
mov BX,[SI].C_page
LoadPage ES,BX
mov SI,port_d
or word ptr ES:[SI+P_FLAGS],DIRTY
pushm <[BP].dis, [BP].pg>
call subsprin ; print it
mov SP,BP
mov AX,ccount ; return number of characters
pop BP
ret
sprint endp
;**************************************************************************
extrn take_cdr:near
extrn restart:near
extrn stkspc:near
extrn get_sym:near
extrn givechar:near
extrn gvchars:near
extrn copybig:near
extrn fix2big:near
extrn big2asc:near
extrn get_flo:near
extrn isspace:near
extrn abort:near
subp_arg struc
tmp_reg1 dw ?
tmp_reg2 dw ?
tmp_reg3 dw ?
tmp_pg dw ?
tmp_SI dw ?
ch_buf db 14 dup (0) ; character buffer
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
push AX
call givechar
mov SP,BP
mov AX,41 ; length of message
lea BX,ab_write
pushm <AX, BX>
call printstr ; 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
pushm <AX, BX>
call printstr ; print no deeper
mov SP,BP
jmp subp_ret
; act on object type
subp_20: shl [BP].spg,1 ; adjust page number
mov BX,[BP].spg
mov DI,ptype+[BX] ; get port type
jmp branchtab+[DI]
;; the individual type handlers
; handle for list
sp_list: test BX,BX ; null page?
jnz sp_l01 ; no, jump
mov AX,2
lea BX,parens
pushm <AX, BX>
call printstr ; print "()"
mov SP,BP
jmp subp_ret
sp_l01: mov DX,28h ; '('
push DX
call printcha
mov SP,BP
mov BX,[BP].spg ; Get page
LoadPage ES,BX ; Get paragraph address of page
mov SI,[BP].sdis ; dispacement
sp_l02: mov [BP].tmp_pg,BX ; Save page
mov [BP].tmp_SI,SI ; and displacement
xor DH,DH
mov DL,byte ptr ES:[SI] ; Get car's page
shr DX,1 ; Change to number for subsprin
mov CX,word ptr ES:[SI+1] ; Get car's displacement
pushm <CX, DX>
call subsprin ; Go print it
mov SP,BP
mov BX,[BP].tmp_pg ; Restore page
LoadPage ES,BX ; Its para address
mov SI,[BP].tmp_SI ; and displacement
mov BL,byte ptr ES:[SI+3] ; Get cdr's page offset
mov SI,word ptr ES:[SI+4] ; and displacement
test BX,BX ; more items in list?
jz sp_l04 ; no, jump
mov [BP].tmp_SI,SI ; save registers
mov [BP].tmp_reg1,BX
mov DX,SPACE ; print ' '
push DX
call printcha
mov SP,BP
mov BX,[BP].tmp_reg1 ; restore registers
mov SI,[BP].tmp_SI
LoadPage ES,BX ; Get paragraph address of page
cmp byte ptr ptype+[BX],LISTTYPE*2 ; check port type
je sp_l02
; last cdr not nil
mov [BP].tmp_SI,SI ; save registers
mov [BP].tmp_reg1,BX
mov DX,2Eh ; print '.'
push DX
call printcha
mov SP,BP
mov DX,SPACE ; print ' '
push DX
call printcha
mov SP,BP
mov BX,[BP].tmp_reg1 ; restore registers
mov SI,[BP].tmp_SI
shr BX,1 ; corrected page number
pushm <SI, BX>
call subsprin
mov SP,BP
sp_l04: mov DX,29h ; print ')'
push DX
call printcha
mov SP,BP
jmp subp_ret
; handle for fixnum
sp_fix: mov AX,5
mov [BP].tmp_reg2,AX
push AX
C_call getmem
mov SP,BP
cmp AX,0
je mem_err
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
mem_err: mov AX,HEAPERR ; memory not available
push AX
call abort
mov SP,BP
jmp subp_ret ; return
; handle for flonum
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
; handle for array
sp_ary: mov AX,2
LoadPage ES,BX ; page segment
lea BX,ary_str ; print "#("
pushm <AX, BX>
call printstr
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].tmp_SI,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 DX,SPACE ; print ' '
push DX
call printcha
mov SP,BP
mov BX,[BP].tmp_reg2 ; restore registers
sp_a02: mov SI,[BP].tmp_SI
add BX,PTRSIZE
LoadPage ES,[BP].spg ; Reload page address of array
jmp sp_a01
; handle for continuation
sp_cont: mov AX,15
lea BX,cont_str
pushm <AX, BX>
call printstr
mov SP,BP
jmp subp_ret
; handle for closure
sp_clos: mov AX,11
lea BX,clos_str
pushm <AX, BX>
call printstr ; print "#<PROCEDURE"
; fetch information operand from closure object
LoadPage ES,[BP].spg ; Get address of page
mov SI,[BP].sdis
lea BX,[BP].tmp_reg1
xor AH,AH
mov AL,byte ptr ES:[SI+3] ; Page # of information op
mov [BX].C_page,AX
mov AX,word ptr ES:[SI+4] ; Disp of information op
mov [BX].C_disp,AX
; follow information operand list to cdr of last list cell
sp_c001: mov DI,[BX].C_page
cmp DI,0
je sp_c01
cmp byte ptr ptype+[DI],LISTTYPE*2
jne sp_c01
push BX
call take_cdr
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
jne sp_c04
LoadPage ES,DI
mov SI,[BX].C_disp
mov BX,word ptr ES:[SI+1] ; get the object size
sub BX,BLK_OVHD+PTRSIZE
push DI ; temp-save DI
push BX
dec BX
mov [BP].tmp_reg3,BX ; BX = symbol length
C_call getmem
pop DI ; (get getmem arg off stack)
pop DI ; temp-restore DI
mov SP,BP
cmp AX,0 ; memory available?
jne sp_c02
jmp mem_err ; no, jump
sp_c02: mov [BP].tmp_reg2,AX
sar DI,1
mov CX,DS ; ES points to DS segment
mov ES,CX
pushm <[BP].tmp_reg1, DI, AX> ; [tmp_reg1] = disp
call get_sym ; get the symbol name
mov SP,BP
mov DX,SPACE
push DX
call printcha ; print ' '
mov SP,BP
pushm <[BP].tmp_reg3, [BP].tmp_reg2>
call printstr ; print the symbol name
mov SP,BP
mov BX,[BP].tmp_reg3
inc BX
pushm <BX, [BP].tmp_reg2>
C_call rlsmem
mov SP,BP
sp_c04: mov DX,3Eh
push DX
call printcha ; print '>'
mov SP,BP
jmp subp_ret
; handle for free
sp_free: mov AX,7
lea BX,free_str
pushm <AX, BX>
call printstr ; print #<FREE>
mov SP,BP
jmp subp_ret
; handle for code block
sp_code: mov AX,7
lea BX,code_str
pushm <AX, BX>
call printstr ; print #<CODE>
mov SP,BP
jmp subp_ret
; handle for environment
sp_env: mov AX,14
lea BX,env_str
pushm <AX, BX>
call printstr ; print #<ENVIRONMENT>
mov SP,BP
jmp subp_ret
; handle for symbol
sp_sym: mov AX,7Ch
mov CX,SYM_OVHD
mov SI,[BP].sdis
shr BX,1 ; corrected page number
pushm <AX, CX, SI, BX>
C_call printatm,,Load_ES ; print the symbol
mov SP,BP
jmp subp_ret
; handle for string
sp_str: LoadPage ES,BX ; Get address of page
mov SI,[BP].sdis ; and displacement
mov CX,word ptr ES:[SI+1]
cmp CX,0 ; check for small string
jge sp_s01
add CX,BLK_OVHD+PTRSIZE
sp_s01: sub CX,BLK_OVHD ; get the string length
mov [BP].tmp_reg1,CX ; save the string length
mov DX,ccount
add DX,CX
mov ccount,DX
cmp show,0
jne sp_s02
jmp subp_ret
sp_s02: add SI,BLK_OVHD ; advance pointer to string
mov [BP].tmp_SI,SI
cmp display,0
jne sp_s02a
jmp sp_sdis
; write, need to print double quotes, escape characters
sp_s02a: xor BX,BX
mov DX,2 ; strange = 2
sp_s001: cmp BX,CX
jge sp_s05
mov AL,byte ptr ES:[SI+BX]
cmp AL,5Ch ; check for \
je sp_s03
cmp AL,22h ; check for "
jne sp_s04
sp_s03: inc DX
sp_s04: inc BX
jmp sp_s001
sp_s05: add DX,CX ; strange + len
push DX
call wrap
mov AX,22h
push AX
call givechar ; print " for string
mov SP,BP
xor BX,BX
mov SI,[BP].tmp_SI
sp_s06: cmp BX,[BP].tmp_reg1 ; finish the string?
jge sp_s10
cmp s_break,0 ; check for SHIFT-BREAK
je sp_s07
jmp kill_out ; yes, jump
sp_s07:
LoadPage ES,[BP].spg ; Ensure string page loaded
mov DL,byte ptr ES:[SI+BX] ; Get one character
xor DH,DH
mov [BP].tmp_reg2,BX ; save registers
cmp DL,5Ch ; \?
je sp_s08
cmp DL,22h ; "?
jne sp_s09
sp_s08: mov AX,5Ch
mov [BP].tmp_reg3,DX ; save the character
push AX
call givechar ; print the \ for special
mov SP,BP
mov DX,[BP].tmp_reg3
sp_s09: push DX
call givechar ; print the character
mov SP,BP
mov SI,[BP].tmp_SI ; restore registers
mov BX,[BP].tmp_reg2
inc BX
jmp sp_s06
sp_s10: mov AX,22h
push AX
call givechar ; print "
mov SP,BP
jmp subp_ret
; display, just print the string
sp_sdis: push CX
call wrap
xor BX,BX
mov SI,[BP].tmp_SI
sp_s11: cmp BX,[BP].tmp_reg1 ; finish the string?
jl sp_s12
jmp subp_ret ; yes, return
sp_s12: cmp s_break,0 ; check for SHIFT-BREAK
je sp_s13
jmp kill_out ; yes, jump
sp_s13: xor AH,AH
LoadPage ES,[BP].spg ; Ensure string page loaded
mov AL,byte ptr ES:[SI+BX] ; get the character
push AX
mov [BP].tmp_reg2,BX ; save registers
call givechar ; print the character
mov SP,BP
mov BX,[BP].tmp_reg2 ; restore registers
mov SI,[BP].tmp_SI
inc BX ; increment the index
jmp sp_s11
; handle for character
sp_char: mov SI,[BP].sdis
and SI,00FFh ; get the low byte for character
cmp display,0
je sp_c10
mov AX,SI ; AL = character
lea SI,[BP].ch_buf
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
; check for a special multi-character character constant
xor BX,BX
lea DI,test_ch
sp_ch01: cmp BX,TEST_NUM ; end of comparison?
jl sp_ch02
mov BX,3 ; yes
jmp sp_ch12
sp_ch02: cmp AL,byte ptr [DI+BX] ; compare with special char
je sp_ch05
inc BX
jmp sp_ch01
sp_ch05: lea DI,t_array
shl BX,1 ; get the word offset
mov DI,word ptr [DI+BX] ; pointer to special char string
mov BX,2
sp_ch03: cmp byte ptr [DI],0 ; end of string?
je sp_ch04 ; yes, jump
mov AL,byte ptr [DI]
mov byte ptr [SI+BX],AL ; move character by character
inc BX
inc DI
jmp sp_ch03
sp_ch04: mov byte ptr [SI+BX],0 ; end of string
sp_ch12: pushm <BX, SI> ; BX = length of buffer
call printstr
mov SP,BP
jmp subp_ret
; print character without escapes
sp_c10: push SI
call printcha
mov SP,BP
jmp subp_ret
; handle for bignum
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].tmp_SI,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 printstr ; print the bignum
mov SP,BP
pushm <[BP].tmp_reg2, [BP].tmp_reg1>
C_call rlsmem
pushm <[BP].tmp_SI, [BP].tmp_reg3>
C_call rlsmem
mov SP,BP
jmp subp_ret
; handle for port
sp_port: mov AX,7
lea BX,port_str
pushm <AX, BX>
call printstr ; print #<PORT>
mov SP,BP
sp_ref:
subp_ret: add SP,offset subp_BP ; release local storage
pop BP
pop ES
ret
subsprin endp
;******************************************************************************
; Print a single character to the file, and send a newline
; if necessary.
;******************************************************************************
pch_arg struc
dw ? ; caller's BP
dw ? ; caller's return address
cha dw ? ; character
pch_arg ends
printcha proc near
push BP
mov BP,SP
inc ccount ; ccount++
cmp show,0 ; show?
je prch_ret ; no, return
call currspc ; check spaces remaining
cmp AX,0
jle prch_01
prch_001: push [BP].cha
call givechar
mov SP,BP
jmp prch_ret ; return to caller
prch_01: test direct,BINARY
jnz prch_001
mov AX,RETURN
push AX
call givechar ; newline
mov SP,BP
push [BP].cha
call isspace ; after newline, print nonspaces
test AX,AX
jnz prch_ret ; space, return
jmp prch_001
prch_ret: pop BP
ret ; return to caller
printcha endp
;******************************************************************************
; Print the string with length LEN, first sending a newline
; if necessary.
;******************************************************************************
str_arg struc
dw ? ; caller's BP
dw ? ; caller's return address
str dw ? ; string pointer
len dw ? ; string length
str_arg ends
public printstr
printstr proc near
push BP
mov BP,SP
push [BP].len
call wrap ; check available spaces
mov AX,ccount
add AX,[BP].len ; ccount += len
mov ccount,AX
cmp show,0 ; show?
je pstr_ret ; no, return
pushm <[BP].len, [BP].str>
call gvchars ; display all characters
pstr_ret: pop BP
ret
printstr endp
;******************************************************************************
; Return number of spaces remaining on current line
;******************************************************************************
currspc proc near
pop DI ; get the return address
push ES
push SI
lea SI,port_r
mov SI,[SI].C_page
LoadPage ES,SI
;;; LoadPage ES,port_seg ; Get port para address
mov SI,port_d
mov AX,word ptr ES:[SI+N_COLS] ; line length
test AX,AX ; line length defined?
jnz curr_01
mov AX,-1 ; no, return negative value
jmp curr_02
curr_01: sub AX,word ptr ES:[SI+CUR_COL]
curr_02: pop SI
pop ES
jmp DI ; return to caller
currspc endp
;******************************************************************************
; Return current column
;******************************************************************************
curr_col proc near
pop DI ; get the return address
push ES
push SI
lea SI,port_r
mov SI,[SI].C_page
LoadPage ES,SI
;;; LoadPage ES,port_seg ; Get port para address
mov SI,port_d
mov AX,word ptr ES:[SI+N_COLS] ; Get Number of columns
or AX,AX ; Maintaining column?
jz ccol_ret ; No, just return 0
mov AX,word ptr ES:[SI+CUR_COL] ; Yes, get column and return
ccol_ret: pop SI
pop ES
jmp DI ; return to caller
curr_col endp
;******************************************************************************
; Wrap issues a newline if there are less than LEN spaces
; left on the current output line.
; Note: DX = LEN
;******************************************************************************
public wrap
wrap proc near
pop DI ; get the return address
pop DX ; get the length
cmp show,0
jz wrap_ret
push DI ; save return address
call curr_col ; get the current column number
pop DI ; restore return address
cmp AX,1
jle wrap_ret
push DI ; save return address
call currspc ; get the available spaces
pop DI ; restore return address
cmp AX,DX
jge wrap_ret
mov AX,RETURN ; issue a newline
push AX
call givechar
mov SP,BP
wrap_ret: jmp DI ; return to caller
wrap endp
prog ends
end