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

888 lines
24 KiB
NASM
Raw Normal View History

Unpack disk3.tgz
2023-05-20 05:57:06 -04:00
; =====> PROSREAD.ASM
;***************************************
;* TIPC Scheme Runtime Support *
;* S-Expression reading *
;* *
;* (C) Copyright 1985 by Texas *
;* Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 24 March 1986 *
;* Last Modification: 10 Feb 1987 *
;* *
;* tc 2/10/87 fix to convert first *
;* char after # to upper case *
;* tc 2/10/87 added support to do *
;* readline *
;***************************************
page 60,132
include scheme.equ
include sinterp.arg
SPACE equ 20h
CTRL_Z equ 1Ah
LINEFEED equ 0Ah
RETURN equ 0Dh
COM equ 3Bh
BK_SLASH equ 5Ch
BUFSIZE equ 256
TEST_NUM equ 8
EOFERR equ 1
SHARPERR equ 7
PORTERR equ -2
HEAPERR equ -3
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
public test_ch, t_array
extrn locases:word
extrn hicases:word
extrn CXFERR_s:word
extrn port_r:word
srd_str db "READ-ATOM",0
sln_str db "READ-LINE",0
inv_char db "Invalid character constant",0
limit dw ? ; current size of atom buffer
main_reg dw ? ; main register
flg_eof dw ? ; whether to flag end-of-file
atomb dw ? ; atom buffer
test_ch db 0Ah,20h,7Fh,0Ch,09h,08h,0Dh,1Bh ; special characters
char db 20h ; most recently received char
t_str1 db "NEWLINE",0
t_str2 db "SPACE",0
t_str3 db "RUBOUT",0
t_str4 db "PAGE",0
t_str5 db "TAB",0
t_str6 db "BACKSPACE",0
t_str7 db "RETURN",0
t_str8 db "ESCAPE",0
t_array dw t_str1
dw t_str2
dw t_str3
dw t_str4
dw t_str5
dw t_str6
dw t_str7
dw t_str8
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
;;;***************************************************************************
;;; Support for read-line
;;;***************************************************************************
rln_proc proc
extrn next_SP:near
extrn src_err:near
public srd_line
srd_line: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_lerr
pushm <tmp_disp,tmp_page,main_reg>
call sread_ln ; get a line
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_lerr: lea BX,sln_str
jmp src_err ; link to error handler
rln_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single line from the given port.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
srdlnarg struc
temp_r dw ? ; temporary storage
srdln_BP dw ? ; caller's BP
dw ? ; caller's return address
rp_reg dw ? ; port register
rpg dw ? ; adjusted page number
rdisp dw ? ; displacement
srdlnarg ends
;
public sread_at
sread_ln proc near
push BP
sub SP, offset srdln_BP ; allocate local storage
mov BP,SP
call setabort ; save stack pointer
pushm <[BP].rdisp,[BP].rpg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srdl_010
mov AX,PORTERR ; port error
push AX
call abort
;
mov flg_eof,1 ; flag eof
srdl_010:
call rcvchar ; get char, eof won't return here
cmp AL,LINEFEED ; is char linefeed?
je srdl_010 ; if so, ignore
mov [BP].temp_r,AX ; save character read
mov AX,BUFSIZE ; Get buffer size
mov limit,AX
push AX
C_call getmem ; allocate buffer
mov SP,BP
cmp AX,0 ; memory available?
jne srdl_020
;error allocate C heap space
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp srdln_ret
srdl_020: mov SI,AX
mov atomb,AX ; address of buffer
mov flg_eof,0 ; don't flag error on EOF
xor BX,BX ; index into buffer
mov AX,[BP].temp_r ; restore saved character
; read characters
srdln_cha:
cmp AL,RETURN ; Return character?
je srdln_ret ; yes, return
cmp AL,CTRL_Z ; EOF character?
je srdln_ret ; yes, return
cmp AL,LINEFEED ; Linefeed character?
je srdln_ret ; yes, don't put in atomb
pushm <AX,BX>
call addchar ; Add character to buffer
mov SP,BP
inc BX
srdln_nxt:
call rcvchar ; Get next character
jmp srdln_cha ; Go get next character
srdln_ret:
mov CX,STRTYPE ; Allocate string data type
mov [BP].temp_r,BX
pushm <BX,CX,main_reg>
c_call alloc_bl,,Load_ES
mov SP,BP
mov CX,3 ; Copy buffer to Scheme string
mov SI,atomb
pushm <[BP].temp_r,SI,CX,main_reg>
call toblock
mov AX,limit ; Release buffer
pushm <AX,atomb>
C_call rlsmem
mov SP,BP
mov flg_eof,1 ; Reset flags
mov limit,0
add SP,offset srdln_BP ; Deallocate local storage
pop BP
ret ; Return
sread_ln endp
;;;***************************************************************************
;;; Support for read-atom
;;;***************************************************************************
rds_proc proc
extrn next_SP:near
extrn src_err:near
public srd_atom
srd_atom: lods byte ptr ES:[SI]
save <SI>
add AX,offset reg0 ; compute register address
mov main_reg,AX
xor BX,BX
push BX
push AX
C_call get_port,,Load_ES ; get the port object
mov SP,BP ; get the return status
test AX,AX ; error returned?
jnz srd_err
pushm <tmp_disp,tmp_page,main_reg>
call sread_at ; sread_atom()
mov SP,BP
jmp next_SP ; return to interpreter
;
srd_err: lea BX,srd_str
jmp src_err ; link to error handler
rds_proc endp
;;;***************************************************************************
;;; Set up for the operation of reading a single atom from the given port.
;;; Special characters such as ')' are parsed as lists(!) to tell them from
;;; ordianry atoms.
;;;***************************************************************************
extrn setabort:near
extrn abort:near
extrn ssetadr:near
sreadarg struc
dw ? ; caller's BP
dw ? ; caller's return address
p_reg dw ? ; port register
pg dw ? ; adjusted page number
disp dw ? ; displacement
sreadarg ends
;
public sread_at
sread_at proc near
push BP
mov BP,SP
call setabort ; save stack pointer
mov BX,[BP].p_reg ;be certain main_reg gets set if
;sread_at gets called directly from C
mov main_reg,BX
pushm <[BP].disp,[BP].pg>
call ssetadr ; set port address
mov SP,BP
test AX,AX ; check return status
jz srd_010
mov AX,PORTERR ; port error
push AX
call abort
;
srd_010: mov flg_eof,1 ; initialization
mov limit,0
; skip spaces
srd_spa: call rcvchar
call ck_space ; check for space
test CX,CX
jz srd_spa ; yes, skip
; skip comments
srd_com: cmp AL,COM ; check for comment
jne srd_at
srd_c10: call rcvchar
cmp AL,RETURN
jne srd_c10 ; yes, ignore the whole line
jmp srd_spa
;
srd_at: test AL,AL ; null character?
jz srd_spa
call read_ato
pop BP
ret
sread_at endp
;;;***************************************************************************
;;; Fetch one character from the input stream
;;;***************************************************************************
extrn take_ch:near
rcvchar proc near
pop DX ; fetch return address
;
push DX ; save registers
push SI
push DI
push CX
push BX
call take_ch ; takechar()
pop BX ; restore registers
pop CX
pop DI
pop SI
pop DX
; Check the character
cmp AX,256
jge rcv_10
cmp AL,CTRL_Z ; EOF character?
je rcv_10 ; yes, jump
mov char,AL
jmp DX ; return to caller
; EOF character is fetched
rcv_10: cmp flg_eof,0 ; EOF flag set?
jne rcv_20 ; yes, error
mov AX,CTRL_Z
mov char,AL
jmp DX ; return to caller
;
rcv_20: mov AX,EOFERR
push AX
call abortrea ; abortread(EOFERR)
rcvchar endp
;;;***************************************************************************
;;; Read in an atom (symbol, string, number)
;;; Store the pointer to the atom in REG.
;;; Special characters such as ')' or ',' are read as atoms themselves.
;;; Normal atoms will end in a whitespace or a terminating macro character;
;;; strings end with the closing '"'.
;;; Numbers in the requested base are interpreted as such.
;;; On exit, the next character in the buffer is the one following the last
;;; character of the atom.
;;;***************************************************************************
extrn toblock:near
extrn cons:near
extrn buildint:near
extrn alloc_st:near
extrn scannum:near
extrn pushchar:near
readarg struc
num_base dw ? ; base of number
tmpreg dw ?
inputch dw ? ; whether the #\ macro is in effect
escaped dw ? ; whether an escape char is used
inflo dq ? ; for floating point value
bignum dw ?
biglimit dw ?
read_BP dw ? ; caller's BP
dw ? ; caller's ES
dw ? ; caller's return address
readarg ends
;
read_ato proc near
push ES
push BP
sub SP,offset read_BP ; allocate local storage
mov BP,SP
xor CX,CX
mov [BP].tmpreg,AX
;;; cmp AL,SPACE ; check for space?
;;; jne read_at
;;; mov [DI].C_page,CX ; yes, form NIL and return
;;; mov [DI].C_disp,CX
;;; jmp read_end
read_at: mov flg_eof,CX ; initialization
mov [BP].inputch,CX
mov [BP].escaped,CX
mov CXFERR_s,CX
mov AX,BUFSIZE
mov limit,AX
mov [BP].num_base,10
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne read_01
memerr: mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp read_ret
read_01: mov SI,AX
mov atomb,AX ; save the address of atom buffer
mov DI,main_reg
xor BX,BX
mov AX,[BP].tmpreg
; check for the special character first
cmp AL,5Bh ; [
je read_10
cmp AL,5Dh ; ]
je read_10
cmp AL,7Bh ; {
je read_10
cmp AL,7Dh ; }
je read_10
cmp AL,28h ; (
je read_10
cmp AL,29h ; )
je read_10
cmp AL,27h ; '
je read_10
cmp AL,60h ; `
jne read_st
; special character case
read_10: mov [SI],AL ; *atomb = ch
inc BX
jmp read_sp
;
read_st: cmp AL,22h ; "
jne read_co
; string case
push AX
call delimby ; get the string
mov SP,BP
mov [BP].tmpreg,BX ; save BX register
mov CX,STRTYPE
pushm <BX,CX,main_reg>
C_call alloc_bl,,Load_ES ; allocate string object
mov SP,BP
mov CX,3
mov SI,atomb
pushm <[BP].tmpreg,SI,CX,main_reg>
call toblock ; copy string to string object
jmp read_bye
;
read_co: cmp AL,2Ch ; ,
jne read_mac
; comma case
mov [SI],AL
inc BX
call rcvchar ; get the next character
cmp AL,40h ; check for @
je read_20
cmp AL,2Eh ; check for .
je read_20
jmp read_nor
read_20: mov [SI+BX],AL
inc BX
jmp read_sp
;
read_mac: cmp AL,23h ; #
je read_25
jmp read_sym
; macro case
read_25: mov flg_eof,1
read_30: test BX,BX ; first character?
jz read_34
read_32: jmp read_200 ; no, jump
;
read_34: cmp AL,23h ; #
jne read_32 ; no, jump
call rcvchar ; get the next character
call ck_space ; check for space
test CX,CX
jnz read_40
read_35: mov AX,SHARPERR ; yes, error
push AX
call abortrea
;
read_40: mov byte ptr [SI+1],AL ; save the character
push BX
mov BX,offset locases ; address of lower-case characters
xlat
pop BX ; restore registers
cmp AL,62h ; b?
jne read_d
mov [BP].num_base,2
jmp read_100
;
read_d: cmp AL,64h ; d?
jne read_x
mov [BP].num_base,10
jmp read_100
;
read_x: cmp AL,78h ; x?
je read_50
cmp AL,68h ; h?
jne read_o
read_50: mov [BP].num_base,16
jmp read_100
;
read_o: cmp AL,6Fh ; o?
jne read_ba
mov [BP].num_base,8
jmp read_100
;
read_ba: cmp AL,BK_SLASH ; \?
jne read_i
call rcvchar
pushm <AX,BX>
call addchar
mov SP,BP
inc BX
mov [BP].inputch,1
mov [BP].escaped,1
jmp read_100
;
read_i: cmp AL,69h ; i?
je read_100
cmp AL,65h ; e?
je read_100
cmp AL,73h ; s?
je read_100
cmp AL,6Ch ; l?
je read_100
cmp AL,3Ch ; <?
je read_60 ; yes, error
cmp AL,29h ; )?
jne read_70
read_60: jmp read_35 ; yes, error
;
read_70: mov byte ptr [SI],23h ; default
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI+1],AL ; Change letter past # to upper case
mov BX,2
cmp AL,28h ; check for (
jne read_100
jmp read_sp ; yes, special case
;
read_100: call rcvchar ; get the next character
jmp read_30
;
read_200: mov flg_eof,0
; handle for symbol
read_sym: ; default
call ck_space ; check for space
test CX,CX
jz read_en ; yes, jump
cmp AL,CTRL_Z ; eof character?
je read_en
cmp AL,28h ; (
je read_en
cmp AL,29h ; )
je read_en
cmp AL,27h ; '
je read_en
cmp AL,60h ; `
je read_en
cmp AL,COM ; comment?
je read_en
cmp AL,2Ch ; ,
je read_en
cmp AL,22h ; "
je read_en
cmp AL,5Bh ; [
je read_en
cmp AL,5Dh ; ]
je read_en
cmp AL,7Bh ; {
je read_en
cmp AL,7Dh ; }
je read_en
push BX
mov BX,offset hicases ; address of higher-case characters
xlat
pop BX
cmp AL,7Ch ; |?
jne read_210
mov [BP].escaped,1
push AX
call delimby ; read the whole symbol
mov SP,BP
jmp read_250
;
read_210: cmp AL,BK_SLASH ; \?
jne read_220
mov [BP].escaped,1
mov flg_eof,1
call rcvchar
mov flg_eof,0
read_220: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
read_250: call rcvchar ; get the next character
jmp read_sym
;
read_en: xor AL,AL ; put null at end of token
pushm <AX,BX>
call addchar
mov SP,BP
; Check for single, unescaped dot
cmp BX,1
jne read_num
cmp byte ptr [SI],2Eh ; check for .
jne read_num
cmp [BP].escaped,1
je read_num
jmp read_nor
; At this point a token has been accumulated, check for number
read_num: mov [BP].tmpreg,BX ; save BX register
push [BP].num_base
push SI
call scannum ; scan number
mov SP,BP
mov SI,atomb ; restore SI register
mov BX,[BP].tmpreg ; restore BX register
test AX,AX ; number or not?
jnz read_n05
jmp read_500
read_n05: cmp [BP].escaped,1
jne read_n07
jmp read_500
read_n07: cmp AX,0
jle read_300 ; negative for floating point number
; integer of some size
add AX,9 ; (AX + 9) / 2
shr AX,1 ; AX = bytes needed for integer
mov [BP].biglimit,AX ; save for later
push AX
C_call getmem ; allocate memory for bignum
mov SP,BP
cmp AX,0 ; memory available?
jne read_n10
jmp memerr ; no, error
read_n10: mov BX,AX
mov [BP].bignum,AX
mov byte ptr [BX+3],0
mov byte ptr [BX+4],0
pushm <[BP].num_base, atomb, BX>
call buildint ; form integer
mov SP,BP
mov DI,main_reg
mov BX,[BP].bignum
pushm <BX,DI>
C_call alloc_in,,Load_ES ; alloc_int
mov SP,BP
pushm <[BP].biglimit,[BP].bignum>
C_call rlsmem ; release memory for bignum
mov SP,BP
jmp read_rls
; Floating point number
read_300: lea DX,[BP].inflo
pushm <[BP].num_base, DX, SI>
C_call scanflo,,Load_ES ; scan the flonum
mov SP,BP
mov DI,main_reg
lea BX,[BP].inflo
pushm <[BX+6],[BX+4],[BX+2],[BX]> ; push flonum value
push DI
C_call alloc_fl,,Load_ES ; alloc_flonum
mov SP,BP
jmp read_rls
; Allocate character or interned symbol
read_500: cmp [BP].inputch,0 ; #\ macro?
mov DI,main_reg
jne read_510
jmp read_600 ; no, symbol
read_510: mov [DI].C_page,SPECCHAR*2
cmp BX,1 ; only one character?
jne read_mul ; no, jump
xor AH,AH
mov AL,byte ptr [SI]
mov [DI].C_disp,AX ; return the character
jmp read_rls
; Check for a multichar character constant
read_mul: mov AL,byte ptr [SI]
mov BX,offset hicases ; address of higher-case characters
xlat
mov byte ptr [SI],AL
xor BX,BX
read_515: cmp BL,TEST_NUM ; finish the comparison?
je read_580 ; yes, jump
lea DI,t_array ; save BX register
mov CX,BX
shl BX,1 ; get the word offset
mov DI,word ptr [DI+BX] ; address of special string
xor BX,BX
read_520: mov AL,byte ptr [DI+BX] ; get the character in string
cmp AL,0 ; end of string
je read_530 ; match
cmp byte ptr [SI+BX],AL
jne read_540
inc BX
jmp read_520
read_530: mov BX,CX
lea SI,test_ch ; address of special characters
mov AL,byte ptr [SI+BX]
mov DI,main_reg
mov [DI].C_disp,AX ; return the special character
jmp read_rls
;
read_540: mov BX,CX
inc BX
jmp read_515
; For the unrecognized multi-char character constant, return #\?
read_580: mov DI,main_reg
mov [DI].C_disp,3Fh ; return '?' character
;;; push SI
;;; lea BX,tmp_reg
;;; push BX
;;; C_call alloc_st,,Load_ES ; alloc_string for error message
;;; mov SP,BP
;;; lea BX,tmp_reg
;;; push BX
;;; lea BX,inv_char
;;; push BX
;;; xor BX,BX
;;; push BX
;;; C_call set_erro,,Load_ES ; set_error
;;; mov SP,BP
mov CXFERR_s,-1 ; error status
jmp read_rls
; Not a character, but a symbol
read_600: push BX ; length of symbol
push SI ; address of symbol
push DI ; register
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
jmp read_rls
;
read_sp: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
jmp read_bye
;
read_nor: pushm <BX, SI, DI>
C_call intern,,Load_ES ; intern the symbol
mov SP,BP
lea BX,nil_reg
mov DI,main_reg
pushm <BX, DI, DI>
call cons ; encase in a list
mov SP,BP
read_rls: cmp char,CTRL_Z ; EOF character?
je read_bye
call pushchar ; put post-atom char back to buffer
;
read_bye: mov AX,limit
pushm <AX, atomb>
C_call rlsmem ; release memory
mov SP,BP
mov flg_eof,1 ; reset flags
mov limit,0
;
read_end: mov AX,CXFERR_s ; return status
read_ret: add SP,offset read_BP ; release local storage
pop BP
pop ES
ret
read_ato endp
;;;************************************************************************
;;; DELIMBY(c)
;;; DELIMBY takes characters from the input stream and places them
;;; in the buffer ATOMB, starting at offset stored in BX register, and
;;; ending when the delimiting character C is reached.
;;; Note: SI = address of atomb
;;; BX = number of characters in atomb
;;;************************************************************************
deliarg struc
dw ? ; caller's BP
dw ? ; caller's return address
cha dw ? ; character
deliarg ends
delimby proc near
push BP ; get the return address
mov BP,SP
mov flg_eof,1 ; signal the EOF error
call rcvchar
deli_10: mov CX,[BP].cha
cmp AL,CL ; reach the end?
je deli_50 ; yes, return
cmp AL,RETURN ; carriage return?
je deli_40 ; yes, ignore
cmp AL,BK_SLASH ; check for \
jne deli_30
call rcvchar ; yes, ignore
deli_30: pushm <AX,BX>
call addchar
mov SP,BP
inc BX
deli_40: call rcvchar ; get the next character
jmp deli_10
deli_50: mov flg_eof,0
pop BP
ret
delimby endp
;;;************************************************************************
;;; ADDCHAR (i, c)
;;; ADDCHAR takes the character c and places it in the dynamic
;;; atom buffer atomb, at offset i. If the buffer can not contain
;;; any more characters, additional space is allocated, and limit
;;; is adjusted accordingly.
;;;************************************************************************
addarg struc
add_tmp dw ?
add_BP dw ? ; caller's BP
dw ? ; caller's return address
index dw ?
chara dw ?
addarg ends
addchar proc near
push BP
sub SP,offset add_BP ; allocate local storage
mov BP,SP
mov BX,[BP].index
cmp BX,limit ; room for character?
jge add_10 ; no, jump
add_01: mov AX,[BP].chara
mov byte ptr [SI+BX],AL
add_ret: add SP,offset add_BP
pop BP
ret
add_10: mov AX,limit
add AX,BUFSIZE
push AX
C_call getmem ; allocate memory
mov SP,BP
cmp AX,0 ; memory available?
jne add_20
mov AX,HEAPERR ; no, error
push AX
call abortrea
mov SP,BP
jmp add_ret
add_20: mov DI,AX ; address of new buffer
mov SI,atomb
mov CX,limit
rep movsb ; copy characters
mov [BP].add_tmp,AX ; save buffer pointer
pushm <limit, atomb>
C_call rlsmem ; discard the old buffer
mov SP,BP
mov SI,[BP].add_tmp
mov atomb,SI
mov CX,limit
add CX,BUFSIZE ; increase the limit
mov limit,CX
mov BX,[BP].index
jmp add_01
addchar endp
;;;************************************************************************
;;; ABORTREAD(code)
;;; Cancels the entire read operation via ABORT, after
;;; resetting some vital registers.
;;; Note: DI = address of main register
;;;************************************************************************
abortarg struc
dw ? ; caller's BP
dw ? ; caller's return address
errcode dw ? ; error code
abortarg ends
abortrea proc near
push BP
mov BP,SP
mov DI,main_reg ; main register
cmp [BP].errcode,EOFERR ; EOF error?
jne ab_010
mov [DI].C_page,EOF_PAGE*2 ; return eof indicator
mov [DI].C_disp,EOF_DISP
jmp ab_020
;
ab_010: xor AX,AX
mov [DI].C_page,AX ; NUL main register
mov [DI].C_disp,AX
;
ab_020: push [BP].errcode
call abort
pop BP
ret
abortrea endp
;;;**********************************************************************
;;; Local support to check the character in AX is space or not
;;; Note: CX = 0 iff the character is whitespace
;;;**********************************************************************
ck_space proc near
pop DX ; get the return address
xor CX,CX
cmp AL,SPACE ; space?
je is
cmp AL,9
jb isnot
cmp AL,0Dh
jbe is
isnot: inc CX
is: jmp DX ; return to caller
ck_space endp
prog ends
end