	.TITLE	VL4
	.psect	VL4

;	stored on:	VL4.MAC
;	last revised:	20-Dec-83

; MODULE	PAGE	CONTENTS

; VL4		9	****** eval.
;		12	****** evaluation des subrs.
;		13	****** evaluation des expr.
;		16	****** evaluation des fexpr, macros, et escapes.
;		18	****** apply perdant.
;		21	****** autres fonctions interprete.
;		24	****** fonctions de definition dynamiques et statiques.

	.globl	atevhk,batom,blist,car.p,cntlc,erfs,errm,errmp,evlis
	.globl	form,hatom,hstak,lambda,ncons,nil,nth,pbind,reent
	.globl	tem0,typech,undef

; ****** eval

; ----- entry (eval (car a1))

evca1::	mov	(a1),a1		; (eval (car a1)) interne.
				; eval doit suivre.

; ***** (EVAL E)  [SUBR 1]

eval::				; (eval a1) interne.
	tst	cntlc		; [PM] are we interrupted by ^C^C ?
	beq	1$		; [PM] branch if not
	.ttinr			; [PM] flush the buffer of control-C's
	.ttinr			; [PM] flush the buffer of control-C's
	jmp	reent		; [PM] reenter
1$:	tst	atevhk		; tester variable evalhook.
	beq	eval1		; non. vers eval-interne.
	call	ncons
	mov	a1,a2		; a2 = liste d'arguments.
	mov	atevhk,a1	; valeur de evalhook : fonction dans a1
	clr	atevhk		; razer evalhook.
	push	pbind		; sauver old-pbind.
	push	a1		; sauver old val de evalhook (la fonction).
	push	#evk		; empiler adresse retour (bloc evalhook).
	mov	p,pbind		; nouveau pbind.
	jmp	apply		; a1 = la-fonction, a2 = liste-d'arguments.

evk:	pop	atevhk		; restituer old val evalhook.
	pop	pbind		; restituer old pbind.
	return			; et bye.
.page
; ***** (EVALHOOK FORM FUN)  [SUBR 2]

evalhk::
	push	pbind		; sauver old p-bind.
	push	atevhk		; sauver old val evalhook.
	mov	a2,atevhk	; forcer new val evalhook.
	push	#evk		; empiler adresse retour (bloc evalhook).
	mov	p,pbind		; nouveau pbind.
				; eval1 (eval-interne) doit suivre.

; ----- eval-interne-evalhook.

eval1:
	mov	a1,form		; sauve toute la forme
	jtlst	a1,evalf	; si la forme est une liste.

				; evaluation des atomes.

	jtnum	a1,popj
	mov	(a1),a1		; charge la valeur de l'atome.
	cmp	a1,#undef
	bne	popj		; valeur definie.

	push	form		; nom de l'atome.
	mov	#era8m,a1
	br	errmpA		; [PM]

era8m:	.asciz	/* Undefined variable : /
	.even


				; evaluation d'une forme dans a1.
evalf:
	ckstk
	uncns			; a2 = la-fonction, a1 = la liste-args.

evalfu::
	cmp	a2,#batom
	blo	evals
	cmp	a2,#hatom
	bhi	evals
				; a2 = fonction-atomique.

	push	dpfval(a2)	; empile la f-val de l'atome-fonction.
	movb	dpftyp(a2),a3	; a3 = le f-typ code de l'atome-fonction.

	jmp	@teval(a3)	; branchement indirect-indexe.
				; a1 = liste des arguments.
				; a2 = la fonction.
				; a3 = le f-typ de l'atome-fonction.
.page
teval:	.word	udfe		; code 0  : pas de definition de fonction.
	.word	popj		; code 2  : subr a 0 argument.
	.word	evca1		; code 4  : subr a 1 argument.
	.word	eval2		; code 6  : subr a 2 arguments.
	.word	eval3		; code 8  : subr a 3 arguments.
	.word	evlis		; code 10 : subr a n arguments.
	.word	popj		; code 12 : fsubr.
	.word	evexp		; code 14 : expr.
	.word	evfexp		; code 16 : fexpr
	.word	evmac		; code 18 : macro.
	.word	evesc		; code 20 : escape.


				; evaluation des fonctions speciales.

evals:
	jflst	a2,evaln	; si c'est un nombre.

				; la fonction est une liste.
	cmp	(a2),#lambda	; est-ce une lambda-explicite ?
	beq	evall		; oui.
	push	a1		; non. sauver la liste-des-arguments.
	mov	a2,a1
	ckstk
	call	eval		; evaluer cette liste.
	mov	a1,a2		; a2 = la-nouvelle-fonction.
	pop	a1		; recuperer les arguments.
	br	evalfu		; et re-evaluer la forme.


				; la fonction est un nombre.
evaln:
	push	a2		; sauve le nombre.
	call	evca1		; et evalue la liste.
	mov	a1,a2
	mov	(p),a1		; recuperer le nombre.
	mov	#car.p,(p)
	jmp	nth		; a1 = le-nombre, a2 = la-liste.

				; la fonction est une lambda-explicite.
evall:
	push	cdr(a2)
	br	evexp
; ****** evaluation des subrs.

; ----- evaluation rapide de type subr.

udfe:				; l'atome n'a pas de fonction associee.
				; indirection sur la c-val.
				; [PM] this allows - (SETQ NN 3)
				;		     (NN L)
	pop	a3		; nettoie l'ancienne f-val.
	cmp	#undef,(a2)	; variable sans valeur ?
	beq	1$		; oui
	cmp	a2,(a2)		; variable self valuee ?
	beq	1$		; erreur si cval(foo) = foo.
	mov	(a2),a2
	br	evalfu
1$:
	push	a2
unde1:	mov	#era9m,a1
errmpA:	jmp	errmp
era9m:	.asciz	/* Undefined function : /
	.even

eval2:				; traitement des 2subr.
	push	cdr(a1)
	call	evca1		; eval 1er arg.

	xtopst	a1,via,a5

	call	evca1		; eval 2d arg.

	mov	a1,a2		; val 2d arg dans a2.
	pop	a1		; val 1er arg dans a1.

; ----- popj

popj::	return			; traitement des 0subr/fsubr.
				; on tombe sur la f-val empilee.


eval3:				; traitement des 3subr.
	push	cdr(a1)
	call	evca1		; eval 1er arg.
	xtopst	a1,via,a5
	push	cdr(a1)
	call	evca1		; eval 2d arg.
	xtopst	a1,via,a5
	call	evca1		; eval 3d arg.
	mov	a1,a3		; val 3d  arg dans a3
	pop	a2		; val 2d  arg dans a2
	pop	a1		; val 1er arg dans a1
	return
; ****** evaluation des expr.

	; fabrique dans la pile un bloc de controle de type :
	;	pbind	->	[ lmb (adresse retour)  ]
	;			[ f-val de la fonction  ]
	;			[ fin bloc de controle  ]
	;			[ nom de la variable n  ]
	;			[ son ancienne valeur   ]
	;				  ...
	;				  ...
	;			[ nom de la variable 1  ]
	;			[ son ancienne valeur   ]
	;			[	.mark.		]
	;			[	ancien pbind	]
	;			-------------------------

evexp:
	mov	(p),a4		; a4 = la f-valeur.
	mov	(a4),a2		; a2 = la liste-de-parametres.
	push	#.mark.		; empile le marqueur de fin de variables.
	br	evexp2

				; fabrication des emplacements en pile.
				; et evaluation des arguments.

evexp1:
	push	cdr(a1)		; empile le reste des valeurs.
	push	a2		; empile toutes les variables.
	call	evca1
	pop	a2		; recupere toutes les variables.

	xtopst	a1,via,a5	; force valeur evaluee.

	push	(a2)+		; empile le nom de la variable.
	mov	(a2),a2		; variable suivante.
evexp2:
	jtlst	a2,evexp1	; il en reste.
	jtnil	a2,evexp3	; c'est vraiment la fin.

	push	a2		; c'est une variable pointee.
	call	evlis

	mov	(p),a5
	mov	a1,(p)		; empile la valeur et le nom.
	push	a5

				; effectue la liaison superficelle.
.page
; pile $p dans cette zone.

$p	=	a4

.macro	$pop	reg
	mov	($p)+,reg
.endm	$pop

evexp3:	mov	p,$p		; p garde la hauteur de la pile.
	br	evexp5

; ----- warning : ne PAS optimiser.

evexp4:
	mov	(a2),a1		; recupere l'ancienne c-val.

	mov	($p),a5
	mov	a1,($p)		; qui est empilee ($XTOPST a1)
	mov	a5,(a2)		; effectue la nouvelle liaison.
	$pop	a1		; saute la valeur.
evexp5:
	$pop	a2		; lecture de la nouvelle variable.
	cmp	a2,#.mark.
	bne	evexp4		; yen a encore.
	mov	pbind,a1	; a1 = le-pbind.

; ----- warning : ne PAS optimiser.

	mov	($p),a5
	mov	a1,($p)		; force pbind et recupere la f-val (XTOPST a1)
	mov	a5,a1

				; test de recursion terminale (post ou copost).

	$pop	a2		; saute l'ancien pbind.
	mov	$p,a3		; a3 pointe sur la fin du bloc.
	br	evexp6
evex6:
	tst	($p)+		; saute la f-val.

	$pop	$p		; i.e. (SSTACK TST).

evexp6:
	$pop	a2
	cmp	a2,#lmb
	bne	evexp8		; n'est pas une evaluation terminale.
	mov	($p),a2		; recup. la f-val de la fonction precedente.
	cmp	a1,a2
	bne	evex6		; c'est recursif : prepare la pile.

				; tailrec OK.
	mov	a3,p
	br	evexp9
.page
evexp8:
	cmp	a2,#whr
	bne	evexpn		; pas un bloc where/escape.
	cmp	($p)+,($p)+	; saute nom et old f-val.
	cmp	($p)+,($p)+	; saute old f-typ et old pbind.
	br	evexp6


	; a partir d 'ici pile normale.

				; recursif ok.
				; on repasse en debut de bloc.
				; avec la pile normale.
evexpn:

	push	a3		; empile l'adresse de fin de bloc.
evexpf:
	push	a1		; empile la f-val.

	push	#lmb		; empile l'adresse de retour du progn.
	mov	p,pbind		; sauve le pointeur de pile.

				; execution du corps de la fonction.

evexp9:
	mov	cdr(a1),a1
	jmp	progn		; evalue le corps.

				; delie les variables.

lmb:
	tst	(p)+		; ignore l'ancienne f-val.
	cmp	(p)+,(pc)+	; ignore la fin du bloc, et skipe vers unbin2.

;	cmp	(p)+,(p)+	; enleve l'ancienne f-val et la fin-bloc.
;	br	unbin2		; pour l'analyser.

unbin1:				; gaffe: est skipped.
	pop	(a4)		; charge l'ancienne c-val.
unbin2:
	pop	a4		; depile encore.
	cmp	a4,#.mark.
	bne	unbin1		; ce n'est pas le marqueur.
	pop	pbind
	return
; ****** evaluation des fexpr et des macros et des escapes.

evmac:
	mov	form,a1		; l'argument est la forme elle-meme.
	pop	a4
	call	evfex1
	jmp	eval
evfexp:
	pop	a4		; a4 = la f-val empilee.
evfex1:
	mov	(a4),a2		; a2 = la liste de variables.
	mov	p,a5		; planquer la pile (pour un pbind).
	push	pbind		; prepare le bloc de controle.
	push	#.mark.
	br	evfex3
evfex2:
	push	@(a2)		; sauve old cval.
	push	(a2)+		; sauve variable.
	mov	(a2),a2		; avance dans liste.
	mov	a1,@(p)		; force nouvelle valeur.


	mov	#nil,a1		; toutes les autres valeurs a nil.
evfex3:
	jtlst	a2,evfex2	; il reste des variables.
	push	a5		; sauve la fin du bloc de controle.
	mov	a4,a1		; a1 = la fval (cf: evexp).
	br	evexpf
.page
	; evaluation des escape.
evesc:				; *** de l'appel rapide.
	push	a2		; sauve le nom du escape.
	call	progn
	pop	tem0		; recupere le nom.
evesc1:				; delie un bloc dans la pile.
	mov	pbind,p		; pile en debut de bloc.
	pop	a4
	cmp	a4,#lmb		; bloc-lambda ?
	beq	evesc2		; oui.
	cmp	a4,#evk
	bne	1$

	pop	atevhk		; delier bloc evalhook.
	pop	pbind
	br	evesc1
1$:
	cmp	a4,#whr		; bloc-where ?
	bne	eresc		; non. bloc invalide.
	pop	a3		; delie un bloc-where.
	pop	dpfval(a3)	; restaure la f-val.
	pop	a5
	movb	a5,dpftyp(a3)	; restaure le f-typ.
	pop	pbind		; nouveau bloc dans la pile.
	cmp	tem0,a3		; est-ce le bloc demande ?
	bne	evesc1		; non. delie le bloc suivant
	return			; oui

evesc2:				; delie un bloc-lambda.
	tst	(p)+		; ignore f-val.
	cmp	(p)+,(pc)+	; ignore fin-bloc et skippe vers evesc4.


evesc3:				; gaffe : est skipped.
	pop	(a4)
evesc4:
	pop	a4
	cmp	a4,#.mark.
	bne	evesc3		; vers la variable suivante.
	pop	pbind		; nouveau bloc dans la pile.
	br	evesc1

eresc:				; *** erreur dans un escape.

	push	a1
	mov	#erescm,a1
	jmp	errm

erescm: .asciz	/* ESCAPE error : /
	.even
; ****** apply perdant

; ***** (APPLYN F . L)  [NSUBR]

applyn::
	mov	cdr(a1),a2	; a2 = la liste des arguments.
	mov	(a1),a1		; a1 = la fonction.
				; apply doit suivre.
; ***** (APPLY F L)	[SUBR 2]

apply::
	cmp	a1,#batom
	blo	applys		; fonction-nombre.
	cmp	a1,#hatom
	bhi	applys		; fonction-liste
				; a1 = fonction-atomique.
	push	dpfval(a1)	; empile la f-val.
	movb	dpftyp(a1),a3	; a3 = le f-typ.
	mov	a1,a4		; a4 = la-fonction.
	mov	a2,a1		; a1 = la liste des arguments.
	jmp	@tapply(a3)	; branchement indirect-indexe.

tapply: .word	udfa		; code 0  : pas de definition.
	.word	popj		; code 2  : subr a 0 argument.
	.word	apply1		; code 4  : subr a 1 argument.
	.word	apply2		; code 6  : subr a 2 arguments.
	.word	apply3		; code 8  : subr a 3 arguments.
	.word	popj		; code 10 : subr a n arguments.
	.word	popj		; code 12 : fsubr.
	.word	appexp		; code 14 : expr.
	.word	udfan		; code 16 : fexpr.
	.word	udfan		; code 18 : macro.
	.word	udfan		; code 20 : escape.

udfa:				; erreur apply fonc. indefinie.
	push	a4
	jmp	unde1		; [PM] report undefined function


udfan:				; erreur apply. fonction de type
	push	a4
	mov	#erufan,a1
	jmp	errmp

erufan: .asciz  /* APPLY : illegal function type : /
	.even
.page
	; evaluation des fonctions speciales.

applys:
	jtnum	a1,udfa		; si c'est un nombre.
	mov	(a1),a3		; a2 = fonction de la fonction.
	cmp	a3,#lambda	; est-ce une lambda explicite ?
	beq	applyL		; oui.
	push	a2		; non. sauver la liste des arguments.
	call	eval
	pop	a1
	br	apply		; et on rappelle apply.

applyL:
	push	cdr(a1)
	mov	a2,a1
	br	appexp

	; evaluation rapide de type subr.

apply2:
	mov	@cdr(a1),a2
apply1:
	mov	(a1),a1
	return

apply3: mov	cdr(a1),a2
	mov	(a1),a1
	mov	@cdr(a2),a3
	mov	(a2),a2
	return
.page
	; application des exprs. a1 = liste des valeurs, f-val empilee.

appexp:
	pop	a2		; a2 = la f-val
	mov	p,a5		; sauve le pointeur de pile courant.
	push	pbind		; fabrique le bloc de controle.
	push	#.mark.
	mov	(a2),a3		; a3 = liste des variables.
	br	appex2
appex1:
	mov	(a3),a4		; a4 = variable suivante.
	push	(a4)		; empile l'ancienne valeur.
	push	a3		; sauve toutes les variables.
	mov	(a1)+,a3	; a3 = nouvelle valeur.
	mov	(a1),a1		; avance dans les valeurs.
	mov	a3,(a4)		; force la nouvelle valeur.

	xtopst  a4,via,a3	; recupere la list des variables.

	mov	cdr(a4),a3	; avance dans cette liste.
appex2:
	jtlst	a3,appex1	; s'il en reste.
	ckstk
	jtnil	a3,appex3	; c'est la vraie fin.
				; dernier de liste d'arguments pointee.
	push	(a3)		; empile l'ancienne valeur.
	push	a3		; empile le nom.
	mov	a1,(a3)		; force la nouvelle valeur.
appex3:
	push	a5		; empile pointeur sur fin de bloc de controle.
	mov	a2,a1		; a1 = la f-val (cf: evexp)
	jmp	evexpf		; en voiture simone.
; ****** autres fonctions interprete.


; ***** (PROGN . L)  [FSUBR]


prgna3::
	mov	a3,a1		; fonction (PRGN a3) interne.
	br	progn
prgn1:
	push	a2		; sauve le reste.
	call	evca1		; evalue l'element.
	pop	a1		; recupere le reste.
eprogn::
progn::
	mov	cdr(a1),a2	; a2 = reste des elements.
	jtlst	a2,prgn1
	jmp	evca1		; c'est le dernier element.


; ***** (PROG1 . L)  [FSUBR]

prog1::
	mov	(a1)+,a2	; a2 = le 1er element.
	push	(a1)		; sauve reste.
	mov	a2,a1
	call	eval		; evaluer le 1er.
	mov	(p),a3		; restaurer reste.
	mov	a1,(p)		; sauver valeur 1er.
	call	prgna3		; progner le reste. gniam!
	pop	a1		; restaurer valeur du 1er.
	return			; a un de ces jours.
.page
; ***** (SELF . L)  [FSUBR]

$p	=	a4

				; p conserve la hauteur de la pile.



	; pile $p dans cette zone.

self2:	cmp	a2,#whr		; est-ce un bloc-where ?
	bne	1$		; non.
	cmp	($p)+,($p)+	; saute la f-val et le f-typ
	$pop	$p		; saute au bloc suivant.
	br	self1
1$:
	cmp	a2,#evk		; est-ce un bloc evalhook ?
	bne	selfer		; non. erreur.
	tst	($p)+		; sauter old val evalhook.
	$pop	$p		; saute au bloc suivant.
	br	self1

; ----- entry self
; %%%%%% tres merdique. revoir ces positionnements.

self::
	mov	pbind,$p	; positionne sur le bloc de controle.
self1:
	$pop	a2		; recupere l'adresse de retour.
	$pop	a3		; recupere la fval.
	cmp	a2,#lmb		; est-ce un bloc-lambda ?
	bne	self2		; non.

	; pile p dans cette zone

	push	a3		; empile la vraie f-val.
	jmp	evexp


	; pile p dans cette zone.

selfer:				; erreur dans un self
	push	a1
	mov	#erself,a1
	br	errmpB		; [PM]

erself: .asciz	/* SELF error : /
	.even
.page
; ***** (EXIT . L)  [FSUBR]
;			sort du dernier bloc de type lambda ou where.
;			permet de forcer une recursion terminale.
;			doit traiter les enveloppes de type where/escape.

exit1:
	cmp	a2,#evk
	bne	1$
				; bloc evalhook.
	tst	(p)+		; depiler adresse retour.
	pop	atevhk
	pop	pbind
	br	exit
1$:
	cmp	a2,#whr		; est-ce un bloc-where ?
	bne	exiter		; non. erreur exit.
	tst	(p)+		; enleve l'adresse de retour.
	pop	a2		; depile le nom de la fonction.
	pop	dpfval(a2)	; restaure la f-val.
	pop	a5
	movb	a5,dpftyp(a2)	; restaure le p-typ.
	pop	pbind		; vers l'analyse du bloc suivant.

; ----- entry exit

exit::
	mov	pbind,p		; debut du bloc suivant.
	mov	(p),a2		; recupere l'adresse de retour.
	cmp	a2,#lmb		; est-ce un bloc-lambda ?
	bne	exit1		; non.
	jmp	progn		; oui.

exiter:				; erreur exit.
	push	a1
	mov	#erexit,a1
errmpB:	jmp	errmp

erexit: .asciz /* EXIT error : /
	.even



; ***** (LAMBDA LARG . L)  [FSUBR]  ramene la forme elle-meme.

lambdp::
	mov	form,a1
	return
; ****** fonctions de definition dynamiques et statiques.



; ----- fonctions de definition dynamique.

		; fabriquent un bloc de controle de la forme :
		;    pbind  ->  [ whr (adresse de retour)	]
		;		[ nom de la fonction		]
		;		[ ancienne f-val		]
		;		[ ancien  f-typ			]
		;		[ ancien pbind			]
		;		 --------------------------------

; ***** (WHERE (AT LARGS . CORPS) . L)  [FSUBR]

where::
	mov	#t.expr,a4	; bon f-typ.
	uncns
	mov	cdr(a2),a3
	mov	(a2),a2		; a1 = L, a2 = AT, a3 = nouvelle f-val.
where1:
	push	pbind		; sauve l'adresse du bloc precedent.
	movb	dpftyp(a2),a5
	push	a5		; sauve l'ancien f-typ.
	push	dpfval(a2)	; sauve l'ancienne f-val.
	push	a2		; sauve le nom de la fonction.
	movb	a4,dpftyp(a2)	; force le nouveau type.
	mov	a3,dpfval(a2)	; force la nouvelle f-val.
	push	#whr		; positionne l'adresse de retour.
	mov	p,pbind		; nouveau bloc.
	jmp	progn		; evalue le corps.
whr:
	pop	a4		; recupere le nom.
	pop	dpfval(a4)	; restaure l'ancienne f-val.
	pop	a5
	movb	a5,dpftyp(a4)	; restaure l'ancien f-typ.
	pop	pbind		; restaure pointeur de bloc precedent.
	return

; ***** (ESCAPE AT . L)  [FSUBR]

escape::
	mov	#t.escp,a4	; f-typ idoine.
	uncns			; a2 = nom fonction, a1 = corps a executer.
	mov	a2,a3		; f-val = le nom.
	br	where1
.page
; ----- fonctions de definition statique.


; ***** (DE A LARG . L)  [FSUBR]

de::
	mov	#t.expr,a5
de1:
	uncns			; a2 = le-nom, a1 = (params . body)
	mov	a1,dpfval(a2)
	movb	a5,dpftyp(a2)
	a2popj

; ***** (DF A LARG . L)  [FSUBR]

df::
	mov	#t.fxpr,a5
	br	de1

; ***** (DM A LARG . L)  [FSUBR]

dm::
	mov	#t.macr,a5
	br	de1


; ***** (DMC C LARGS . L)  [FSUBR]

dmc::
	call	df		; definit la fonction comme fexpr.
	push	a1		; sauve le caractere-fonction.
	mov	#clmac,a2
	call	typech
	pop	a1		; restaure le caractere-fonction.
	return

	.end			; ****** END OF VL4 ******
