conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/cprint1.asm

755 lines
24 KiB
NASM
Raw Permalink Normal View History

Unpack disk2.tgz
2023-05-20 05:57:05 -04:00
; =====> 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