	.TITLE	VL5
	.psect	VL5


;	stored on:	VL5.MAC
;	last revision:	16-APR-82


; MODULE	PAGE	CONTENTS

; VL5		10	****** fonctions de controle.
;		13	****** predicats, true, false.
;		20	****** recherches.
;		25	****** creation d'objets.
;		30	****** modifications d'objets.
;		34	****** fonctions sur p-listes.


xx1	=	version
xx2	=	options
xx3	=	eis
xx4	=	fis
xx5	=	clock
xx6	=	i11.04
xx7	=	recor


	.globl	atescp,batom,blist,bnum
	.globl	catol,cons,erfs,erplc
	.globl	eval,evca1,expr,fexpr
	.globl	fsubr,hcnst,hnum,hstak
	.globl	macro,nil,nsubr,prgna3
	.globl	progn,qcons,savpil
	.globl	subr0,subr1,subr2,subr3
	.globl	t,tem0,undef,valnb,valnb2,xcons
	.page
; ****** fonctions de controle.

; ***** (IF S . L)  [FSUBR]

if::
	push	a1
	call	evca1		; evaluer le predicat.
	pop	a2
	mov	cdr(a2),a2
	jfnil	a1,then		; [PM]
	mov	cdr(a2),a3
	jmp	prgna3		; else clauses.

then:	mov	(a2),a1		; [PM] then clause.
	jmp	eval

; ***** (IFN S . L)  [FSUBR]

ifn::
	push	a1
	call	evca1		; evaluer le predicat.
	pop	a2
	mov	cdr(a2),a2
	jtnil	a1,then		; [PM]
	mov	cdr(a2),a3
	jmp	prgna3		; else clauses.



; ***** (COND . LC)  [FSUBR]

cond::
	mov	a1,a2
cond1:
	jtlst	a2,1$
2$:	return			; ya plus de clauses.
1$:
	mov	(a2)+,a1	; a1 = clause suivante.
	push	(a2)		; sauve le reste des clauses.
	push	cdr(a1)
	call	evca1		; evalue le predicat.
	pop	a3		; a3 = le corps de la clause.
	pop	a2		; a2 = le reste des clauses.
	jtnil	a1,cond1	; le predicat ramene nil.
	jtnil	a3,2$		; en cas de clause vide.
	jmp	prgna3		; evalue le corps de la clause.
.page
; ***** (OR . L)  [FSUBR]	tail-recursif.

or1:
	push	a2
	call	evca1
	jfnil	a1,pret		; depile et retourne.
	pop	a1

; ----- entry or.

or::
	mov	cdr(a1),a2
	jtlst	a2,or1
	jmp	evca1		; le dernier element.


; ***** (AND . L)  [FSUBR]

and2:	push	a2
	call	evca1
	jtnil	a1,pret		; depile et retourne.
	pop	a1
and1:
	mov	cdr(a1),a2
	jtlst	a2,and2
	jmp	evca1		; le dernier element.

; ----- entry and.

and::
	jtlst	a1,and1
	jmp	true		; (AND) -> T

; ***** (WHILE . L)  [FSUBR]

while::
	push	a1		; empile toute l'expression.
	br	while2
while1:
	mov	(p),a1		; recupere l'expression entiere.
	mov	cdr(a1),a1	; le corps.
	call	progn
while2:
	mov	(p),a1
	call	evca1		; value le test.
	jfnil	a1,while1	; faut reevaluer le corps.
				; pret doit suivre.

; ----- pret : depile et retourne.

pret:
	tst	(p)+
	return
.page
; ***** (UNTIL . L)  [FSUBR]

until::
	push	a1		; empile toute l'expression.
	br	until2
until1:
	mov	(p),a1		; recupere l'expression entiere.
	mov	cdr(a1),a1	; le corps.
	call	progn
until2:
	mov	(p),a1
	call	evca1		; value le test.
	jtnil	a1,until1	; faut reevaluer le corps.
				; pret doit suivre.
	br	pret


; ***** (SELECTQ E C1 ... CN L)   [FSUBR]

seltq::
	push	#prgna3		; hack derec final.
	push	cdr(a1)		; sauver (C1 ... CN L).
	call	evca1		; evaluer E.
	mov	(p),a4		; a4 = (C1 ... CN L).
	mov	a1,(p)		; pile = E*:PRGNA3: ...
	br	seltq2
seltq1:
	mov	(p),a1		; a1 = E*, A3 = Ci.
	push	a4		; empiler reste des clauses.
	mov	(a3)+,a2	; a2 = car Ci.
	push	(a3)		; sauve reste de Ci.
	push	#2$		; hack.
	jtlst	a2,1$
	br	eq
1$:	jmp	member

2$:
	pop	a3		; recuperer reste-de-Ci.
	pop	a4		; recuperer clauses.
	jfnil	a1,seltq3	; si OK.
seltq2:
	mov	(a4)+,a3	; a3 = Ci.
	mov	(a4),a4		; a4 = (Ci+1 ... )
	jtlst	a4,seltq1	; si Ci non-derniere.
seltq3:
	tst	(p)+		; ignorer E*.
	return			; vers PRGNA3.
; ****** predicats, true, false

; ***** (NEQ S1 S2)  [subr 2]	neq est aussi polymorphique (gasp!).

neq::	call	eq		; null doit suivre.

; ***** (NULL S)  [SUBR 1]
; ***** (NOT S)   [SUBR 1]

null::
not::	jtnil	a1,true
	br	false

; ***** (ATOM S)  [SUBR 1]

atom::	jflst	a1,true
	br	false


; ***** (LISTP S)  [SUBR 1]

listp::  jtlst	a1,true
	br	false


; ***** (NUMBP S)  [SUBR 1]

numbp::  jtnum	a1,true
	br	false


; ***** (EQ S1 S2)   [SUBR 2]   eq est polymorphique (sigh!) .

eq::	cmp	a1,a2
	beq	true

	cmp	a1,#hnum
	bhi	false
	cmp	a2,#hnum
	bhi	false
	cmp	a1,#bnum
	blo	false
	cmp	a2,#bnum
	blo	false
	cmp	(a1),(a2)
	bne	false

; .........
	.if	ne,fis		; [PM]
	cmp	2(a1),2(a2)
	bne	false
	.endc			; [PM]
; .........

	br	true
.page
; ***** (NEQUAL S1 S2)  [SUBR 2]

nequal::
	push	#not		; equal doit suivre.

; ***** (EQUAL S1 S2)   [SUBR 2]

equal::
	mov	p,savpil	; sauve le sp pour les retours rapides.
	call	equal2
	br	true
equal1:
	jflst	a2,equal3
	mov	(a1)+,a4	; car a1 dans a4.
	mov	(a2)+,a5	; car a2 dans a5.
	ckstk
	push	(a1)		; sauve cdr a1.
	push	(a2)		; sauve cdr a2.
	mov	a4,a1
	mov	a5,a2
	call	equal2		; recursion sur les car.
	pop	a2
	pop	a1
equal2:
	jtlst	a1,equal1	; iteration sur les cdrs.
	call	eq
	jtnil	a1,equal3
	return

				; ya eu 1 tres beau bug : lorsque les
				; 3 instructions precedentes etaient
				; remplacees par un "br eq".
equal3:
	mov	savpil,p	; ramene la pile a sa juste valeur.
	br	false		; retour faux.
.page
; ***** (BOUNDP A)  [SUBR 1]

boundp::
	cmp	(a1),#undef
	bne	true

	br	false


; ----- true, false

true::

	mov	#t,a1
	return

false::
	mov	#nil,a1
	return



; ***** (GT N1 N2)  [SUBR 2]
				; noter que :
				; (gt/ge/lt/le n) == (gt/ge/lt/le n 0)



gt::	exch	a1,a2		; (gt a b) == (lt b a)

; ***** (LT N1 N2)  [SUBR 2]
				; valnb2 : a1 = valnb(a1), a4 = valnb(a2).
				; cette bizarrerie permet de garantir que

	; garb ne trouvera pas dans a2
				; des adresses de CDR.
lt::
	jfnil	a1,1$
	clr	a1		; cas (fonc nil n)
1$:
	jfnil	a2,2$

	clr	a2		; cas (fonc n nil)
2$:

; .........
	.if	eq,fis
	call	valnb2
	cmp	a1,a4

	blt	true
	br	false

	.endc
; .........
.page
; .........
	.if	ne,fis

	clr	a4
	cmp	a1,#bnum
	blo	3$
	mov	2(a1),a4
	mov	(a1),a1
3$:
	clr	a5
	cmp	a2,#bnum
	blo	4$
	mov	2(a2),a5
	mov	(a2),a2
4$:
	cmp	a1,a2
	blt	true
	bgt	false
	cmp	a4,a5
	blt	true
	br	false

	.endc
; .........
.page
; ***** (GE N1 N2)  [SUBR 2]


ge::	exch	a1,a2		; (ge a b) == (ge b a)

; ***** (LE N1 N2)  [SUBR 2)

le::
	jfnil	a1,1$

	clr	a1		; cas (fonc nil n)
1$:
	jfnil	a2,2$
	clr	a2		; cas (fonc n nil)
2$:

; .........
	.if	eq,fis

	call	valnb2
	cmp	a1,a4
	ble	true
	br	false

	.endc
; .........

; .........
	.if	ne,fis

	clr	a4

	cmp	a1,#bnum
	blo	3$
	mov	2(a1),a4
	mov	(a1),a1
3$:
	clr	a5
	cmp	a2,#bnum
	blo	4$
	mov	2(a2),a5
	mov	(a2),a2
4$:
	cmp	a1,a2
	blt	true
	bgt	false
	cmp	a4,a5
	bgt	false
	br	true

	.endc
; .........
.page
; ***** (ZEROP N)	[SUBR 1]

zerop::	call	valnb
	tst	a1
	beq	1$
	br	false
1$:	return			; OK puisque 0 est un INUM !!!


; ***** (EVENP N)	[SUBR 1]

evenp::
	mov	a1,a2
	call	valnb
	bit	#1,a1
	bne	false
	a2popj


; ***** (ODDP N)	[SUBR 1]

oddp::
	mov	a1,a2
	call	valnb
	bit	#1,a1
	beq	false
	a2popj
.page
; ***** (LITATOM E)	[SUBR 1]

litato::

	jtnum	a1,false
	jtlst	a1,false
	br	true


; ***** (ALPHALE A1 A2)	[SUBR 2]

alphle::
	add	#dplpn,a1
	add	#dplpn,a2
	mov	(a2)+,a5
	mov	(a1)+,a4		; les longueurs respectives.
	br	2$
1$:
	cmpb	(a1)+,(a2)+
	bgt	false			; a1 > a2. KO.
	blt	true			; a1 < a2. OK.
	dec	a5
	dec	a4
2$:
	ble	true
	tst	a5
	bgt	1$
	br	false
; ****** recherches

; ***** (C...R S)  [SUBR 1]

cdddr::	tst	(a1)+
cddar::	mov	(a1),a1
cddr::	tst	(a1)+
cdar::	mov	(a1),a1
cdr.p::	tst	(a1)+
car.p::	mov	(a1),a1
	return

caddr::	tst	(a1)+
cadar::	mov	(a1),a1
cadr::	tst	(a1)+
caar::	mov	@(a1),a1
	return

cdadr::	tst	(a1)+
cdaar::	mov	(a1),a1
	br	cdar

caadr::	tst	(a1)+
caaar::	mov	(a1),a1
	mov	@(a1),a1
	return


; ***** (MEMQ A L)  [SUBR 2]

memq::
	push	#eq
	br	memb2
.page
; ***** (MEMBER E L)  [SUBR 2]

member::
	push	#equal
memb2:
	mov	a2,a3
	push	a1
	br	2$
1$:
	mov	(a3),a1		; a1 = (CAR L)
	mov	(p),a2		; a2 = E
	push	a3
	push	4(p)		; empiler eq ou equal.
	call	@(p)+		; coroutine.
	pop	a3
	jfnil	a1,3$
	mov	cdr(a3),a3
2$:
	jtlst	a3,1$		; la liste est vide ?
3$:
	cmp	(p)+,(p)+	; depiler.
	mov	a3,a1		; ramene le dernier cdr.
	return



; ***** (FVAL A [E])  [SUBR 2]	get/set la f-val de l'atome A.

fval::
	jtnum	a1,fval1	; l'argument doit etre
	jtlst	a1,fval1	; un atome litteral.
	jtnil	a2,1$		; en modification ?

	mov	a2,dpfval(a1)	; oui. forcer nouvelle f-val.
1$:
	mov	dpfval(a1),a1	; prendre la f-val.
	return
fval1:
	jmp	false
.page
; ***** (FTYPE A [E])  [SUBR 2]  get/set le f-type de l'atome A.

ftype::
	jtnum	a1,fval1	; A n'est pas
	jtlst	a1,fval1	; un atome litteral.

	jtnil	a2,ftype1	; modification ?
	mov	#etypft,a4	; oui.
	br	2$
1$:
	cmp	-(a4),-(a4)	; a4 <- a4 - 2.
2$:
	mov	(a4),a5
	jtnil	a5,3$		; fini c'est nil.
	cmp	a2,a5		; comparer a E.
	bne	1$		; c'est pas encore le bon truc.
3$:
				; trouve ou nil. calculer le type interne.
	sub	#typft,a4	; a4 = [0:20.]
	movb	a4,dpftyp(a1)	; forcer nouveau f-type.

ftype1:

	movb	dpftyp(a1),a2	; a2 = [0:20.]
	mov	typft(a2),a1	; recuperer l'atome correspondant.
	return			; et bye.


; ----- table typft utilisee par ftype.

typft:
	.word	nil		; code  0 : no-fonction.
	.word	subr0		; code  2
	.word	subr1		; code  4
	.word	subr2		; code  6
	.word	subr3		; code  8.
	.word	nsubr		; code 10.
	.word	fsubr		; code 12.
	.word	expr		; code 14.
	.word	fexpr		; code 16.
	.word	macro		; code 18.
etypft: .word	atescp		; code 20.
.page
; ***** (PTYPE A [N])  [SUBR 2]  get/set le p-type de l'atome A.

ptype::
	jtnum	a1,fval1	; A n'est pas
	jtlst	a1,fval1	; un atome litteral.

	mov	a1,a3		; atome dans a3.
	mov	a2,a1		; [N] dans a1.
	jtnil	a1,1$
	call	valnb		; a1 = valeur binaire nouveau p-type.
	bic	#177400,a1	; on ne garde que les 8 low bits.
	movb	a1,dpptyp(a3)	; forcer nouveau p-type.
1$:
	movb	dpptyp(a3),a1	; attraper p-type.
	bic	#177400,a1	; ne garder que les 8 low bits.
;	jmp	cranb		; et ramener le nombre ad hoc.
	return			; [PM] previous line not necessary


; ***** (PLENGTH A)  [SUBR 1]

plengt::
	movb	dplpn(a1),a1	; c'est (vraisemblablement) un inum.
	return			; on le ramene a sa grand-mere.


; ***** (NTH N L)	[SUBR 2]

nth::	call	valnb
	br	1$
2$:	mov	cdr(a2),a2
1$:
	sob	a1,2$
	a2popj
.page
; ***** (LAST L)   [SUBR 1]

last1:
	mov	a2,a1

; ----- entry last

last::
	mov	cdr(a1),a2
	jtlst	a2,last1
	return


; ***** (ASSQ AT L)   [SUBR 2]


assq::
	push	#eq
	br	asso2


; ***** (ASSOC E L)   [SUBR 2]


assoc::
	push	#equal
asso2:

	push	a1
	br	2$
1$:
	mov	(p),a1
	push	a2
	mov	@(a2),a2
	push	4(p)			; empiler le eq ou le equal.
	call	@(p)+			; coroutine.
	pop	a2
	jfnil	a1,3$
	mov	cdr(a2),a2
2$:
	jtlst	a2,1$
3$:
	mov	(a2),a1
	cmp	(p)+,(p)+
	return
; ****** creation d'objets.

; ***** (EVLIS L)  [SUBR 1]

evlis::	jflst	a1,evlis1		; R.A.F. bye.
	push	cdr(a1)			; preserver reste.
	call	evca1			; evalue l'element suivant.

	xtopst  a1,via,a2		; empile element evalue.
					; et recupere le reste.
	call	evlis

	; pile = En*:etiq: ... :E2*:etiq:E1*:retour:...

evlis2:					; used by mcons, copy
	pop	a2			; recuperer l'element evalue.
	jmp	xcons
evlis1: return				; used by mcons.

; ***** (LIST . L)  [FSUBR]

list	==	evlis


; ***** (MCONS . L)  [FSUBR]
					; %%%%%% revoir, optimiser.

mcons::	jflst	a1,evlis1		; bye T.D.S. si a1 non-liste.
	br	mcons0
mcons2:
	push	cdr(a1)			; sauver reste.
	call	evca1			; evaluer element.
	xtopst  a1,via,a5
	push	#evlis2			; i.e. pop a2	; jmp xcons.
mcons0:
	jtlst	a1,mcons2		; test interne.

	tst	(p)+			; ignorer adresse de retour.
	pop	a1			; attraper le En* dans a1.
	return

; ***** (DCONS E L)  [SUBR 2]

dcons::	consl	0,#nil,a3		; last a3 = (0 . nil)
	push	a3			; empiler hook
	br	2$
1$:
	consl	a1,(a2)+,-(p)		; empiler (cons E (car a2)).
	mov	(a2),a2			; a2 = (cdr a2).
	consl	(p)+,#nil,cdr(a3)	; forcer ((cons ...) . nil) dans cdr.last.
	mov	a4,a3			; nouveau last.
2$:
	jtlst	a2,1$
	pop	a1			; recuperer hook.
	jmp	cdr.p			; et ramener son cdr.
.page
; ***** (OBLIST)  [SUBR 0]

oblist::
	mov	#nil,a1			; creation de liste inversee.
	mov	catol,a3
1$:
	consl	a3,a1,a1

	mov	dpnexa(a3),a3
	bne	1$
	br	cdr.pA			; [PM] pour eviter undef.

; ***** (REVERSE L1 L2)  [SUBR 2]

rev1:

	consl	(a1)+,a2,a2		; a2 = (cons (car a1) a2).
	mov	(a1),a1			; a1 = (cdr a1).

; ----- entry reverse.

revers::

	jtlst	a1,rev1
	a2popj


; ***** (LENGTH L)  [SUBR 1]


length::
	mov	a1,a4
	clr	a1
	br	2$
1$:	mov	cdr(a4),a4
	inc	a1

2$:	jtlst	a4,1$
;	jmp	cranb		; [PM] this line not necessary
	return			; [PM]
.page
; ***** (APPEND1 L1 S)   [SUBR 2]

appen1::

	consl	a2,#nil,a2
					; append doit suivre.


; ***** (APPEND L1 L2)   [SUBR 2]


append::
	consl	0,#nil,a3	; last a3 = (0 . nil)
	push	a3		; empiler hook.
	br	2$
1$:
	consl	(a1)+,#nil,cdr(a3)	; a4 = cdr(a3) = (cons (car a1) nil).
	mov	(a1),a1			; a1 = (cdr a1).
	mov	a4,a3			; new last.
2$:
	jtlst	a1,1$
	mov	a2,cdr(a3)	; forcer a2.
	pop	a1		; recuperer hook.
cdr.pA:	jmp	cdr.p		; et ramener son cdr.



; ***** (COPY S)   [SUBR 1]

copy::	jflst	a1,subst3	
	push	cdr(a1)
	mov	(a1),a1
	call	copy		; a1 = (COPY (car S))
	xtopst	a1,via,a5
	push	#evlis2		; i.e. pop a2	; jmp xcons.
	br	copy

;	call	copy		; a1 = (COPY (cdr S))
;	pop	a2
;	jmp	xcons
.page
; ***** (SUBST NEW OLD EXP)   [SUBR 3]

subst::
	push	a1		; sauver new.
	push	a2		; sauver old.
	mov	p,tem0		; pile = old:new:suite
	mov	a3,a1		; a1 = exp, a2 = old.
	call	subst1
	cmp	(p)+,(p)+	; depiler 2 fois.
subst3: return			; used by COPY.
subst0:
	mov	@tem0,a2	; a1 = exp, a2 = old.
subst1:
	push	a1		; a1 = exp, a2 = old.
	call	equal
	pop	a2		; a2 = exp.
	jtnil	a1,subst2	; si (nequal exp old).

	mov	tem0,a5		; cas (equal exp old), on ramene new.
	mov	2(a5),a1	; a1 = new.
	return
subst2:
	jtlst	a2,1$		; a2 = exp atome ?
	a2popj			; oui. on le ramene.
1$:
	mov	(a2)+,a3	; a3 = (car exp)
	mov	(a2),a1		; a1 = (cdr exp)
	push	a3		; sauver (car exp).
	call	subst0		; (subst ... (cdr exp))
	xtopst  a1,via,a5
	call	subst0		; (subst ... (car exp))
	pop	a2
	jmp	cons
.page
; ***** (DELQ AT L)	[SUBR 2]

delq::
	push	#eq
	br	delet2


; ***** (DELETE E L)	[SUBR 2]

delete::
	push	#equal
delet2:
	push	a1		; empiler AT/E
	consl	0,#nil,a3	; last a3 = (0 . nil)
	push	a3		; empiler hook.
	br	3$
1$:				; pile = hook:AT/E:predicat:reste...
	mov	(a2)+,a1
	push	(a2)		; empiler cdr L.
	push	a1		; empiler car L = a1.
	mov	6(p),a2		; a2 = AT/E
	push	8.(p)		; empiler EQ ou EQUAL.
	call	@(p)+		; coroutine.
	pop	a2		; recuperer car L.
	jfnil	a1,2$		; si AT/E eq(ual) car L.
	consl	a2,#nil,cdr(a3)	; a4 = cdr(a3) = (cons (car L) nil).
	mov	a4,a3		; new last
2$:
	pop	a2		; recuperer cdr L.
3$:
	jtlst	a2,1$		; encore ?
	pop	a1		; recuperer le hook.
	cmp	(p)+,(p)+	; ignorer AT/E et predicat.
	jmp	cdr.p
; ****** modifications d'objets.

; ***** (RPLACA S1 S2)  [SUBR 2]

rplaca::
	cmp	a1,#hcnst		; [PM] is it restricted from modification?
	blos	erplc1			; [PM] jump if yes
	mov	a2,(a1)
	return


; ***** (RPLACD S1 S2)  [SUBR 2]

rplacd::
	cmp	a1,#hcnst		; [PM] is it restricted from modification?
	blos	erplc1			; [PM] jump if yes
	mov	a2,cdr(a1)
	return


; ***** (RPLACB S1 S2)   [SUBR 2]

rplacb::
	cmp	a1,#hcnst		; [PM] is it restricted from modification?
	blos	erplc1			; [PM] jump if yes
	mov	(a2)+,(a1)+
	mov	(a2),(a1)
	mov	-(a1),a2		; pour gc. recule a1. neutralise a2.
	return


; ***** (SET S1 S2)	[SUBR 2]

set::
	cmp	a1,#hcnst		; [PM] is it restricted from modification?
	bhi	.+6			; [PM] no, its ok
erplc1:	jmp	erplc			; [PM] tell user, cant modify a constant
	mov	a2,(a1)
	a2popj
.page
; ***** (SETQ V1 E1 ... VN EN)   [FSUBR]

setq1:  mov	a2,a1

; ----- entry   setq

setq::
	push	(a1)+		; sauve le nom de la variable varI
	mov	(a1),a1		; a1 = (valI varI+1 valI+1 ...)
	push	cdr(a1)		; sauve le reste
	call	evca1		; et evalue la val.
	pop	a2		; recupere le reste de la liste.
	mov	a1,@(p)+	; forcer c-val dans nom de la variable.
	jtlst	a2,setq1	; il reste encore des couples.
	return			; non. ramene la derniere valeur.

; ***** (SETQQ V1 E1 ... VN EN)  [FSUBR]

setqq::
	uncns			; a2 = variable suivante, a1 = reste.
	mov	(a1)+,a3	; a3 = valeur suivante.
	mov	a3,(a2)
	mov	(a1),a1
	jtlst	a1,setqq
	mov	a3,a1
	return
.page
; ***** (MSETQ V1 V2 E)   [FSUBR]

msetq::

;	uncns			; a2 = V1, a1 = (V2 E).
;	push	a2
;	uncns			; a2 = V2, a1 = (E).
;	push	a2
;	call	evca1

	push	(a1)+		; sauver V1.
	mov	(a1),a1		; a1 = (V2 E).
	push	(a1)+		; sauver V2.
	mov	@(a1),a1	; a1 = E
	call	eval

	mov	a2,@(p)+	; affecter V2.
	mov	a1,@(p)+	; affecter V1.
	return




; ***** (NEXTL V)	[FSUBR]

nextl::
	mov	(a1),a2		; a2 = la-variable.
	mov	(a2),a4		; a4 = sa-valeur
	mov	(a4)+,a1
	mov	(a4),(a2)
	return


; ***** (NEWL AT E)  [FSUBR]

newl::
	push	(a1)+		; sauve le nom de l'atome.
	mov	(a1),a1		; a1 = (E)
	call	evca1		; evalue l'expression. valeur dans a1.
	mov	@(p),a2		; valeur de la variable dans a2.
	call	cons		; fabrique la nouvelle valeur.
	mov	a1,@(p)+	; qui est rangee dans la cval.
	return
.page
; ***** (FREVERSE L1 L2)  [SUBR 2]

frev1:
	mov	cdr(a1),a3
	mov	a2,cdr(a1)
	mov	a1,a2
	mov	a3,a1

; ----- entry freverse.

frever::
	jtlst	a1,frev1
frev2:
	a2popj


; ***** (NCONC1 L1 AT)  [SUBR 2]

nconc1::
	consl	a2,#nil,a2
				; nconc doit suivre.

; ***** (NCONC L1 L2)   [SUBR 2]

nconc::
	jflst	a1,frev2	; si a1 non-liste.
	push	a1		; preserver pointeur sur debut de a1.
	br	3$		; et rouler.
2$:	mov	a4,a1		; avancer dans la liste.
3$:	mov	cdr(a1),a4	; dernier doublet ?
	jtlst	a4,2$		; non.
	mov	a2,cdr(a1)	; oui. forcer son cdr.
	pop	a1		; et ramener le debut.
	return

; ***** (EXCH AT1 AT2)	[FSUBR]  echange de variables.

exch.p::
	mov	(a1)+,a4	; a4 = v1
	mov	@(a1),a5	; a5 = v2

	mov	(a4),a1
	mov	(a5),(a4)
	mov	a1,(a5)
	return
; ****** fonctions sur p-listes.


; ***** (ADDPROP AT VAL INDIC)  [SUBR 3]


addpro::
	consl	a2,cdr(a1),a2	; a2 = (VAL . oldplist)
	consl	a3,a2,cdr(a1)	; cdr(a1) = (INDIC VAL . oldplist)
	return



; ----- gett	a1 = un atome, a2 = un indicateur.
;		   ramene : si non trouve  ->  a4 = nil.
;				si trouve	->  a4 = (oldval ...)
;						a5 = (x indic oldval ...)

gett:	mov	a1,a5
	push	a1		; sauver atome.
	mov	a1,a4
	br	2$		; aller attraper la p-liste de l'atome.

				; invariant : a5 = (x indic oldval ...)
				;		a4 = (indic oldval ...)
1$:
	mov	(a4),a1		; a1 = indic
	call	eq
	mov	cdr(a4),a4	; a4 = (oldval ...)
	jfnil	a1,3$		; si a2 = indic
	mov	a4,a5		; a5 = (x.oldval indic val ...)
2$:
	mov	cdr(a4),a4	; a4 = (indic val ...)
	jtlst	a4,1$		; a5 = (x indic val ...)
3$:
	pop	a1		; restaurer atome.
	return
.page
; ***** (GET AT INDIC)  [SUBR 2]

get::	call	gett
	mov	(a4),a1		; tant pis si a4 = nil.
	return


; ***** (PUT AT VAL INDIC)  [SUBR 3]

put::	push	a2		; sauver VAL.
	mov	a3,a2		; indic dans a2 pour gett.
	call	gett
	pop	a2		; restaurer VAL
	jtnil	a4,addpro	; en tete si INDIC n'existe pas encore.
	mov	a2,(a4)		; coller nouvelle VAL sous INDIC.
	return			; et bye.


; ***** (REMPROP AT INDIC)   [SUBR 2]

rempro:: call	gett
	jtnil	a4,rempr2	; si INDIC absent.
	mov	cdr(a4),cdr(a5)	; enlever (INDIC VAL).
rempr2: return

	.end			; ****** END OF VL5 ******
