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

651 lines
28 KiB
NASM
Raw Normal View History

Unpack disk3.tgz
2023-05-20 05:57:06 -04:00
; =====> SCAR_CDR.ASM
;***************************************
;* TIPC Scheme '84 Runtime Support *
;*Interpreter -- Car and Cdr operations*
;* *
;* (C) Copyright 1984,1985,1986 by *
;* Texas Instruments Incorporated. *
;* All rights reserved. *
;* *
;* Date Written: 11 September 1984 *
;* Last Modification: 26 February 1986*
;***************************************
include scheme.equ
; Modification History:
; 26 Feb 86 - modified the "CONS" support to attempt a "short circuit"
; (JCJ) allocation of a list cell, instead of calling the
; "alloc_list_cell" support unconditionally.
include sinterp.mac
include sinterp.arg
take_car macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].car_page
mov SI,ES:[SI].car
endm
take_cdr macro
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr
LoadPage ES,BX
;;; mov ES,pagetabl+[BX]
mov BL,ES:[SI].cdr_page
mov SI,ES:[SI].cdr
endm
; load arguments for cxr
load_arg macro
lods word ptr ES:[SI] ; fetch source/destination register numbers
save <SI> ; save the location pointer
mov BL,AH ; copy the source register number
mov SI,reg0_dis+[BX] ; load contents of the source register
mov BL,byte ptr reg0_pag+[BX]
endm
car_cdr2 macro arg1,arg2
mov CX,offset PGROUP:arg1&_last
mov DI,offset PGROUP:arg2&_CX
jmp load_ops
endm
car_cdr3 macro arg1,arg2,arg3
mov DX,offset PGROUP:arg1&_last
mov CX,offset PGROUP:arg2&_DX
mov DI,offset PGROUP:arg3&_CX
jmp load_ops
endm
DGROUP group data
data segment word public 'DATA'
assume DS:DGROUP
m_car db "CAR",0
m_cdr db "CDR",0
m_caar db "CAAR",0
m_cadr db "CADR",0
m_cdar db "CDAR",0
m_cddr db "CDDR",0
m_caaar db "CAAAR",0
m_caadr db "CAADR",0
m_cadar db "CADAR",0
m_caddr db "CADDR",0
m_cdaar db "CDAAR",0
m_cdadr db "CDADR",0
m_cddar db "CDDAR",0
m_cdddr db "CDDDR",0
m_cadddr db "CADDDR",0
m_%car db "%CAR",0
m_%cdr db "%CDR",0
m_table dw m_car,m_cdr,m_caar,m_cadr,m_cdar,m_cddr,m_caaar,m_caadr
dw m_cadar,m_caddr,m_cdaar,m_cdadr,m_cddar,m_cdddr,m_cadddr
m_setcar db "SET-CAR!",0
m_setcdr db "SET-CDR!",0
m_apendb db "APPEND!",0
m_ltail db "LIST_TAIL",0
m_one dw 1 ; a constant "one" (1)
m_two dw 2 ; a constant "two" (2)
m_three dw 3 ; a constant "three" (3)
data ends
PGROUP group prog
prog segment byte public 'PROG'
assume CS:PGROUP
car_cdr proc near
; Entry points defined in "sinterp.asm"
extrn next:near ; Top of interpreter
extrn next_PC:near ; Reload ES,SI at top of interpreter
extrn next_SP:near ; Reload SP,ES,SI at top of interpreter
extrn src_err:near ; "source operand error" message display
extrn sch_err:near ; "source operand error" message display
extrn printf_c:near ; Error message print routine
;************************************************************************
;* %car %CAR DEST *
;* *
;* Purpose: To obtain the first element of a list. This support is *
;* similar to the usual "car" operation except that %car *
;* returns #!unassigned if one tries to take the car of *
;* nil. *
;************************************************************************
public ld_car1
ld_car1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car1 ; if not a list cell, error (jump)
cmp BL,0 ; is source operand nil?
jne car_last ; if not nil, jump
cxr_undf: mov BX,AX ; reload dest register number
mov byte ptr reg0_pag+[BX],UN_PAGE*2 ; set destination reg
mov reg0_dis+[BX],UN_DISP ; to #!unassigned
jmp next_PC
bad_car1: mov AX,offset m_%car
jmp bad_one
;************************************************************************
;* %cdr %CDR DEST *
;* *
;* Purpose: To obtain the rest of a list. This support is similar *
;* to the usual "cdr" operation except that %cdr returns *
;* #!unassigned if one tries to take the cdr of nil. *
;************************************************************************
public ld_cdr1
ld_cdr1: lods byte ptr ES:[SI] ; load operand
save <SI> ; save the location pointer
mov BX,AX ; copy operand register number to BX
mov SI,reg0_dis+[BX] ; load the source operand
mov BL,byte ptr reg0_pag+[BX]
cmp BL,0 ; is source operand nil?
je cxr_undf ; if nil, return #!unassigned (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2
je cdr_last ; if a list cell, continue processing (jump)
jmp bad_cdr1 ; if not a list cell, error (jump)
bad_cdr1: mov AX,offset m_%cdr
jmp bad_one
;************************************************************************
;* AL AH *
;* Take "car" of a list cell LD_CAR dest,src *
;************************************************************************
public ld_car
ld_car: load_arg
car_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_car ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].car_page ; copy contents of car field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].car
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
car_CX: take_car
jmp CX
car_DX: take_car
jmp DX
;************************************************************************
;* AL AH *
;* Take "cdr" of a list cell LD_CDR dest,src *
;************************************************************************
public ld_cdr
ld_cdr: load_arg
cdr_last: cmp byte ptr ptype+[BX],LISTTYPE*2
jne bad_cdr ; if not a list cell, error (jump)
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load para addr of page containing cell
mov BL,AL ; copy destination register number
mov AL,ES:[SI].cdr_page ; copy contents of cdr field into
mov byte ptr reg0_pag+[BX],AL ; the destination register
mov AX,ES:[SI].cdr
mov reg0_dis+[BX],AX
jmp next_PC ; return to the interpreter
; ***Error-- attempt to take "car" of non- list cell***
bad_car:
; ***Error-- attempt to take "cdr" of non- list cell***
bad_cdr: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX ; load opcode of failing instruction
mov BL,ES:[SI]-3
shl BX,1
mov AX,m_table+[BX]-128
bad_one: les SI,dword ptr [BP].save_SI ; load next instruction's address
xor BX,BX
mov BL,ES:[SI]-1 ; load register used as last operand
add BX,offset reg0
pushm <BX,m_one,AX>
C_call set_src_,,Load_ES
jmp sch_err ; display error message
cdr_CX: take_cdr
jmp CX
cdr_DX: take_cdr
jmp DX
;************************************************************************
;* AL AH *
;* Take "cadddr" of a list cell LD_CADDDR dest,src *
;************************************************************************
public ld_caddd
ld_caddd: load_arg
take_cdr
mov DX,offset PGROUP:car_last
mov CX,offset PGROUP:cdr_DX
jmp cdr_CX
load_ops: load_arg
jmp DI
;************************************************************************
;* AL AH *
;* Take "caar" of a list cell LD_CAAR dest,src *
;************************************************************************
public ld_caar
ld_caar: car_cdr2 car,car
;************************************************************************
;* AL AH *
;* Take "cadr" of a list cell LD_CADR dest,src *
;************************************************************************
public ld_cadr
ld_cadr: car_cdr2 car,cdr
;************************************************************************
;* AL AH *
;* Take "cdar" of a list cell LD_CDAR dest,src *
;************************************************************************
public ld_cdar
ld_cdar: car_cdr2 cdr,car
;************************************************************************
;* AL AH *
;* Take "cddr" of a list cell LD_CDDR dest,src *
;************************************************************************
public ld_cddr
ld_cddr: car_cdr2 cdr,cdr
;************************************************************************
;* AL AH *
;* Take "caaar" of a list cell LD_CAAAR dest,src *
;************************************************************************
public ld_caaar
ld_caaar: car_cdr3 car,car,car
;************************************************************************
;* AL AH *
;* Take "caadr" of a list cell LD_CAADR dest,src *
;************************************************************************
public ld_caadr
ld_caadr: car_cdr3 car,car,cdr
;************************************************************************
;* AL AH *
;* Take "cadar" of a list cell LD_CADAR dest,src *
;************************************************************************
public ld_cadar
ld_cadar: car_cdr3 car,cdr,car
;************************************************************************
;* AL AH *
;* Take "caddr" of a list cell LD_CADDR dest,src *
;************************************************************************
public ld_caddr
ld_caddr: car_cdr3 car,cdr,cdr
;************************************************************************
;* AL AH *
;* Take "cdaar" of a list cell LD_CDAAR dest,src *
;************************************************************************
public ld_cdaar
ld_cdaar: car_cdr3 cdr,car,car
;************************************************************************
;* AL AH *
;* Take "cdadr" of a list cell LD_CDADR dest,src *
;************************************************************************
public ld_cdadr
ld_cdadr: car_cdr3 cdr,car,cdr
;************************************************************************
;* AL AH *
;* Take "cddar" of a list cell LD_CDDAR dest,src *
;************************************************************************
public ld_cddar
ld_cddar: car_cdr3 cdr,cdr,car
;************************************************************************
;* AL AH *
;* Take "cdddr" of a list cell LD_CDDDR dest,src *
;************************************************************************
public ld_cdddr
ld_cdddr: car_cdr3 cdr,cdr,cdr
;************************************************************************
;* Macro support for set-car!/set-cdr! *
;************************************************************************
set_cc macro field
local x
lods word ptr ES:[SI] ; load register numbers
mov DX,ES ; save TIPC register ES
mov BL,AL
mov DI,reg0_pag+[BX] ; load dest register page number
cmp DI,0 ; are we trying to set car/cdr of nil?
je x ; if (set-cxr nil v), error (jump)
cmp byte ptr ptype+[DI],LISTTYPE*2 ; Is destination a list cell?
jne x ; If not, set_field! not defined
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; Load paragraph addr for dest page
mov DI,reg0_dis+[BX] ; Load destination displacement
mov BL,AH ; Copy src register number
mov AL,byte ptr reg0_pag+[BX] ; redefine field's page number
mov ES:[DI].&field&_page,AL
mov AX,reg0_dis+[BX] ; redefine field's displacement
mov ES:[DI].&field,AX
mov ES,DX ; reload ES segment register
jmp next
x: mov BX,offset m_set&field ; load address of message text
IFIDN <&field>,<car>
bad_stcr: mov ES,DX
bad_st1: xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0
push AX
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0
pushm <AX,m_two,BX>
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
ELSE
jmp bad_stcr
ENDIF
endm
;************************************************************************
;* AL AH *
;* Side effect car field (set-car! dest src) SET-CAR! dest,src *
;* *
;* Purpose: Interpreter support for the set-car! operation. *
;************************************************************************
public set_car
set_car: set_cc car
;************************************************************************
;* AL AH *
;* Side effect cdr field (set-cdr! dest src) SET-CDR! dest,src *
;* *
;* Purpose: Interpreter support for the set-cdr! operation. *
;************************************************************************
public set_cdr
set_cdr: set_cc cdr
purge set_cc
;************************************************************************
;* DL DH AL *
;* Cons - Create and define new list cell CONS dest,car,cdr *
;* *
;* Purpose: Interpreter support for the Scheme "cons" operation. *
;************************************************************************
public s_cons
s_cons: lods word ptr ES:[SI] ; load destination/car register numbers
mov DX,AX ; and save in DX
xor AX,AX
lods byte ptr ES:[SI] ; load cdr register number
save <SI> ; save the location pointer
; Attempt a "short circuit" list cell allocation
mov DI,listpage
;;; cmp DI,END_LIST
;;; je cons_no
shl DI,1
mov SI,nextcell+[DI]
cmp SI,END_LIST
je cons_no
LoadPage ES,DI
;;; mov ES,pagetabl+[DI] ; load list cell page's segment address
mov CX,ES:[SI].car
mov nextcell+[DI],CX
; Move contents of CDR register to CDR field of new list cell
cons_ok: mov BX,AX ; copy register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].cdr_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].cdr,AX
; Move contents of CAR register to CAR field of new list cell
mov BL,DH ; copy CAR register number to BX
mov AL,byte ptr reg0_pag+[BX]
mov ES:[SI].car_page,AL
mov AX,reg0_dis+[BX]
mov ES:[SI].car,AX
; Update destination register number with pointer to new list cell
mov BL,DL
mov reg0_pag+[BX],DI
mov reg0_dis+[BX],SI
jmp next_SP
; "short circuit" list cell allocation failed-- go through channels
cons_no: push tmp_adr
C_call alloc_li,<AX,DX>,Load_ES
add SP,WORDINCR
restore <AX,DX>
mov DI,tmp_page
mov SI,tmp_disp
LoadPage ES,DI
;;; mov ES,pagetabl+[DI]
jmp cons_ok
;************************************************************************
;* List - Create and define new list cell w/ nil cdr LIST dest *
;* *
;* Purpose: Interpreter support for the Scheme "list" operation. *
;************************************************************************
public s_list
s_list: lods byte ptr ES:[SI] ; load destination register number
mov BX,offset tmp_reg ; load address of temporary register
pushm <AX,BX> ; push dest reg number, temp_reg address
C_call alloc_li,<SI>,Load_ES ; allocate list cell
add SP,WORDINCR ; dump argument from TIPC's stack
pop SI ; restore destination register pointer
mov BX,tmp_page ; load page number of new list cell
mov CX,BX
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell's page table address
mov DI,tmp_disp ; load displacement of new list cell
; copy car field into newly allocated list cell
mov AX,reg0_dis+[SI] ; load car's displacement, and
mov ES:[DI].car,AX ; store into new list cell
mov AL,byte ptr reg0_pag+[SI] ; load page number, and
mov ES:[DI].car_page,AL ; store it, too
; create nil cdr field into newly allocated list cell
xor AX,AX
mov ES:[DI].cdr,AX
mov ES:[DI].cdr_page,AL
; copy pointer to new list cell into destination register
mov byte ptr reg0_pag+[SI],CL
mov reg0_dis+[SI],DI
jmp next_PC
;************************************************************************
;* AL AH *
;* (list a b) LIST2 dest,src *
;* *
;* Purpose: Interpreter support for the (list a b) operation. *
;* *
;* Description: This operation: (list a b) *
;* is equivalent to: (cons a (cons b nil)) *
;************************************************************************
public list2
list2: lods word ptr ES:[SI] ; fetch operands
mov BL,AL ; save the destination register number
push BX
mov BL,AH ; copy the source register number
add BX,offset reg0 ; compute source register address
mov AX,offset nil_reg ; load "nil_reg" address
mov CX,offset tmp_reg ; load "tmp_reg" address
pushm <AX,BX,CX> ; push arguments to cons
C_call cons,<SI>,Load_ES ; call: cons(tmp_reg,src,nil_reg)
pop CX ; restore tmp_reg address
add SP,WORDINCR*2 ; drop arguments from TIPC's stack
pop BX ; restore destination register number
add BX,offset reg0 ; compute destination register address
pushm <CX,BX,BX> ; push arguments to cons
C_call cons ; call: cons(dest, dest, tmp_reg)
jmp next_SP ; return to the interpreter
;************************************************************************
;* (append! list obj) append! dest src *
;* *
;* Purpose: Scheme interpreter support for the append! primitive *
;************************************************************************
public appendb
appendb: lods word ptr ES:[SI] ; get args (AL=arg1, AH=arg2)
save <SI> ; save the location pntr
mov BL,AL
lea DI,reg0+[BX] ; DI=address of dest reg
mov BX,[DI].C_page ; load list header from dest reg
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is arg1 a list?
jne short not_list ; if not, error (jump)
;
cmp BL,NIL_PAGE*2 ; is arg1 == nil?
jne short find_end ; if not, continue (jump)
;
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
mov [DI].C_page,BX
mov BX,[SI].C_disp
mov [DI].C_disp,BX
jmp next_PC ; RETURN
;
find_end label near
mov CX,SB_CHECK ; load shift-break iteration count
mov DI,[DI].C_disp
next_cell label near
LoadPage ES,BX
;;; mov ES,pagetabl+[BX] ; load list cell page para address
mov BL,ES:[DI].cdr_page ; load list cell's cdr's page
cmp BL,NIL_PAGE*2 ; CDR == nil?
je short eolist ; then end-of-list (jump)
cmp byte ptr ptype+[BX],LISTTYPE*2 ; still pointing to cons nodes?
jne short weird_lst
mov DI,ES:[DI].cdr ; load list cell's cdr's displacement
loop next_cell
; Every one in awhile, check for shift-break
mov CX,SB_CHECK ; reload the shift-break iteration count
cmp s_break,0 ; has the shift-break key been depressed?
je next_cell ; if no shift-break, jump
push m_three ; push instruction length = 3
C_call restart ; link to Scheme debugger
; Note: control does not return from "restart"
;
weird_lst label near ; possible error checking here
; as list was non-nil terminated
eolist label near
mov BL,AH ; else get 2nd arg & return it in dest reg
lea SI,reg0+[BX] ; SI=address of src reg
mov BX,[SI].C_page ; Copy src reg to dest reg
; check page # for src?
mov ES:[DI].cdr_page,BL
mov BX,[SI].C_disp
mov ES:[DI].cdr,bx
jmp next_PC ; return to interpreter
not_list label near
mov BX,offset m_apendb
jmp bad_st1
;************************************************************************
;* (list_tail list count) l_tail list(dest) count *
;* *
;* Purpose: Scheme interpreter support for the list_tail primitive *
;************************************************************************
lt_args struc
COUNT dw ? ; Long integer count of list element
dw ?
REGSAVE dw ?
BP_SAVE dw ? ; Saved base pointer
ES_SAVE dw ? ; Saved ES reg
lt_args ends
public l_tail
l_tail:
lods word ptr ES:[SI] ; get register operands
save <SI> ; save instruction pointer
push ES ; save local registers
push BP
sub SP,offset BP_SAVE ; allocate local storage
mov BP,SP
xor BH,BH
mov BL,AL
add BX,offset reg0 ; reg holding list ptr
mov [BP].REGSAVE,BX ; save for later
xor BH,BH
mov BL,AH
add BX,offset reg0 ; get register containing count
push BX ; and push for call
lea BX,[BP+COUNT] ; get location for return value
push BX ; and push for call
mov DX,DS
mov ES,DX ; set ES for C routine
C_call int2long ; convert register to long
mov SP,BP
or ax,ax
jnz lt_err ; jump on error
mov ax,[BP].COUNT+2 ; get high word of long integer
or ax,ax ; if negative
js lt_rtn ; return
mov SI,[BP].REGSAVE ; reg holding list ptr
mov BX,[SI].C_page ; BX <= page of list
cmp byte ptr ptype+[BX],LISTTYPE*2 ; is it a list ?
jne lt_err ; no, jump
mov AX,BX ; AX <= page of list
mov BX,[SI].C_disp ; BX <= disp of list
lt_loop:
mov CX,[BP].COUNT+2 ; get lsw of long int
or CX,[BP].COUNT
jz lt_rtn ; jump if long int = zero
cmp AX,NIL_PAGE ; end of list?
je lt_rtn ; yes, return
LoadPage ES,AX ; ES <= page address of list cell
mov AL,ES:[BX].cdr_page ; AX <= page # of cdr
mov BX,ES:[BX].cdr ; BX <= disp of cdr
sub word ptr [BP].COUNT,1 ; decrement count
sbb word ptr [BP].COUNT+2,0
jmp lt_loop ; and loop
lt_rtn:
mov byte ptr [SI].C_page,AL ; save page in reg
mov [SI].C_disp,BX ; save disp in reg
add SP,BP_SAVE
pop BP
pop ES
jmp next_SP
lt_err:
add SP,BP_SAVE
pop BP
pop ES ; restore ES register
restore <SI> ; and instruction pointer
xor AX,AX
mov AL,ES:[SI]-1
add AX,offset reg0 ; get last operand
push AX ; and push for call
xor AX,AX
mov AL,ES:[SI]-2
add AX,offset reg0 ; get first operand
push AX ; and push for call
mov BX,offset m_ltail ; load address of message text
pushm <m_two,BX> ; and push
C_call set_src_,<SI>,Load_ES
restore <SI>
jmp sch_err
car_cdr endp
prog ends
end