                                   lisp 8-2-64 _. part 3

/terminate print name

mkn,	cla
mke,	sad cso
	jmp x
	dac cso
	ral 1s
	add (72
	dac 100
	jmp oc

/pack character into print name

pak,	dap pk1
	sar 6s
	cal mke
pk1,	law
	and (77
	dac 100
	jmp oc

/PACK

pack,	lac pdl
	jda pwl
	law isj-1
	dac isi
pq1,	laa a0
	sma
	jmp pq2
	and (jmp
	sas (jmp
	jmp pq3
	laa a0
	and (177
	cal pak
pq4,	jsp uwl
	dio a0
	sas a0
	jmp pq1
	law isj-1
	sad isi
	jmp qp2
	cal rym
	jmp x1
	lac isj
	jmp mka
       
                                        
pq2,	loa a0
	lad a0
	jda pwl
	dio a0
	jmp pq1
pq3,	lac a0
	sas n
	jmp qp1
	jmp pq4

/UNPACK

unpack,	laa 100
	sma
	jmp qp1
	init pc0,uq1
	lac (jmp t0-1
	dac ar1
	dzm a1
	lac 100
	cal pr0
	lad ar1
	lio n
	doa ar1
	jmp x
uq1,	and (77
	sad (76
	jmp x1
	sas (74
	sad (72
	jmp uq2
	add a1
	cal mkc
	cal cns-1
	lod ar1
	lac t0
	daa ar1
	dac ar1
	dod t0
	jmp x1
uq2,	sub (72
	ral 5s
	dac a1
	jmp x1
       
                                        
/PUTOB

putob,	dac a0
	laa a0
	and (jmp
	sas (add
	jmp qp1
	laa a0
	and (-jmp
	dac isj
	dzm isi
	cal rym+1
	jmp fal
pob,	loa a2
	lac a0
	cal cns
	daa a2
	jmp tru
       
                                        
/MEMBER

member,	dac t0
mem1,	dio t1
	lac t1
	sad n
	jmp x
	lac t0
	loa t1
	cal equal
	sas n
	jmp x1
	idx t1
mem2,	dac a2
	loa a2
	jmp mem1

/REMOB

remob,	dac t0
	laa t0
	sma
	jmp qp1
	ral 1s
	spa
	jmp fal
	rar 1s
	cal hc
	cal mem2
	sad n
	jmp x1
	lad t1
	daa a2
	jmp tru
       
                                        
/EVAL

eva,	laa 100

eval,
evl,	dio ar2

evo,	dac ar1

/evaluate current expression

ev2,	laa ar1
	spa
	jmp e1
	dac t0
	laa t0
	spa
	jmp e2
       
                                        
/car[x] not atomic

ev4,	lac ar2
	jda pwl
	laa ar1
	jda pwl
	lad ar1
	cal elc
	jsp uwl
	dio arf
ev4a,	jsp uwl
	dio ar2
	jmp apl

/evaluate function name and try again

ev3,	lac ar2
	jda pwl
	lac ar1
	jda pwl
	lac arf
	cal evo
	dac arf
	jsp uwl
	dio ar1
	jmp ev4a

/search p-list of fn

e2a,	ral 1s
	spa
	jmp e1a
	lac arf
	dac t0
ev9,	lad t0
	sad n
	jmp e1a
	dac t0
	laa t0
	dac 100
	laa 100
	sad 1sb
	jmp esb
	sas 1xp
	jmp ev9

/function is EXPR

exp,	lad 100
	jmp apl-1
       
                                        
/x is atomic _. search a-list, then p-list

e1,	ral 1s
	spa
	jmp en1
	lac ar1
	cal asr
	jmp ev5
	jmp cdr

ev5,	law 1
	add ar1
	dac 100
	lio i 100
	lac 1ap
	cal asc
	jmp qa8
	jmp cdr

en1,	lac ar1
	jmp x

/APPLY

apply,	dio ar1
	lio a2
	dio ar2
	dac arf
apl,	lac i arf
	spa
	jmp e2a
	sad 1la
	jmp e3
	sas 1fa
	jmp ev3

/car[fn] = FUNARG

e4,	lad arf
	cal cadr
	dac ar2
	lac i arf
	cal car
	jmp apl-1
       
                                        
/car[x] is atomic _. search its p-list

e2,	lac t0

ev8,	sad n
	jmp ev4
	laa t0
	dac 100
	laa 100
	sad 1fs
	jmp efs
	sad 1fx
	jmp efx
	ldad t0
	jmp ev8

/function is FSUBR

efs,	lad 100
	cal vag
	dac exx
	lad ar1
	lio ar2

exy,	dac 100
	dzm ar1
exx,	0
	jmp x

/function is FEXPR

efx,	lad 100
	dac arf
	lac ar2
	cal cns-1
	lod ar1
	dzm ar1
	cal efc
	dac ar1
	jmp apl
efc,	dio 100
	lio t0
	jmp cns
       
                                        
/evaluate argument list _. also LIST

ela,	lad ar1
list,
elc,	dac ar1
	sad n
	jmp x
	lac ar2
	jda pwl
	lac ar1
	lio (jmp t0-1
	dio ar1
	dac t1
ele,	lio i pdl
	dac t0
	lac ar1
	jda pwl
	lad t1
	jda pwl
	laa t0
	cal evl
	cal cns-1
	jsp uwl
	dio t1
	idx i pdl
	dac ar1
	idx pdl
	loa ar1
	lac t0
	daa ar1
	dac ar1
	dod t0
	lac t1
	sas n
	jmp ele
	jsp uwl
	dio ar2
	lad ar1
	lio n
	doa ar1
	dac ar1
	jmp x
       
                                        
/function is SUBR

esb,	lad 100
	cal vag
	dac exx
	init esa,a0-1
	lac ar1
eda,	sad n
	jmp exs
	idx esa
	sad (dac a2+1
	jmp qa7
	laa ar1

esa,	dac
	ldad ar1
	jmp eda

exs,	lac a0
	lio a1
	jmp exy

/fn is atomic but propertyless

e1a,	lac arf
	cal asr
	jmp qa9
	lad 100
	jmp apl-1
       
                                        
/car[fn] = LAMBDA

e3,	ldad arf
	laa arf
ep1,	dac a0
	sad n
	jmp ep2
	lac ar1
	sad n
	jmp qf3
	lio ar2
	cal cns
	dac ar2
	loa ar1
	laa a0
	daa ar1
	lad ar1
	doa ar1
	dac ar1
	lad a0
	jmp ep1

ep2,	sas ar1
	jmp qf2
	lac arf
	cal cadr
	jmp evo
       
                                        
/error halt entries

qa3,	idx pdl
	lac pa3
	sza
	jmp prx
	error icd	/illegal COND
	jmp pxs

qa4,	error uss	/unbound symbol in SETQ
	jmp pxs

qa7,	error tma	/too many args for subroutine
	stf 6
	jmp exs

qa8,	error uas	/unbound atomic symbol
	lac ar1
	cal pnt
	jmp go

qc3,	complain ilp	/illegal parity
	law 377
	and avc
	cal prr-1
	cal tpr
	cla>>05<<cli
	cal stp+1
	jmp ava

qa9,	error uaf		/unbound atomic function
	lac arf
	jmp qc3-2
       
                                        
qf2,	error lts	/LAMBDA list too short
	jmp go

qf3,	error ats	/arglist too short
	jmp go

qg2,	error pce		/pushdown cap. exc.
	jmp go

qg1,	error sce		/storage cap. exc.
	jmp go

qi3,	lac 100
	dac a2
	error nna	/non-numeric arg for arith.
	lac a2
	cal pnt
	jmp go

qi4,	error ovf	/divide overflow

qix,	cla 16
	jmp crn

qp2,	error nap	/null argument for PACK
	jmp go

qp1,	error ana	/arg non-atom for PRIN1, PUTOB, PACK, UNPACK
	jmp go		/or REMOB

qp3,	complain iif	/illegal input format
	jmp go

pxs,	stf 6
prx,
fal,	lac n
	jmp x


start
       
                                                                               
