	.TITLE	VL8
	.psect	VL8

;	stored on:	VL8.MAC		last revised:	20-Dec-83

xx1	=	version
xx2	=	options
xx3	=	eis
xx4	=	fis
xx5	=	clock
xx6	=	i11.04
xx7	=	recor

	.globl	atastr,ateof,batom,blist,bnum,bstak,bufin,bufou
	.globl	cdr.p,crach,cranb,dski,dsko,dvd
	.globl	ebfodk,eval,evalfu,form,hstak,igc,impli,mrkmsk
	.globl	inarea,inbpt,iniodk,iniott,lcou,lmar,nblki,nblko,ncons,nicons
	.globl	nil,obase,opti,oubpk,oubpt,pbind,prcdp,prcln,prmdp,prmln,prnxt
	.globl	prompt,rdprd,reent,rmar,sava1,savpil,sign,soubpt,tabch,tem0
	.globl	valnb,vlas,writew,xpldi,xpldl

; MODULE	PAGE	CONTENTS

; VL8		9	****** inchb, inci.
;		12	****** outb, outs, erreurs.
;		17	****** prch, prspc, prstr.
;		19	****** prnum.
;		22	****** prflt.
;		28	****** prast, prato, probj.
;		31	****** print, pcrlf, prin, trfrdk.

; ****** inchb, inci		 ----- lecture sur terminal.

incp:				; entree sur terminal.
	push	a3		; on ne sait jamais.
	push	a5		; on imprime la valeur de l'atome prompt.
	push	opti
	bis	#1,opti		; pas d'espace avant.
	mov	prompt,a1	; prompt = .asciz  /? /
	call	probj		; editer.
	mov	#-1,a5
	call	pcrlf1		; (TERPRI -1)
	pop	opti
	pop	a5
	mov	rdprd,a3	; nb de "(" deja lues.
	cmp	a3,#7		; max 7 indentations.
	ble	1$
	mov	#7,a3
1$:	mov	#' ,a2		; preparer le padd.
	br	incp3
incp1:	call	outb
	call	outb		; 3 fois. caractere dans a2
	call	outb
.page
incp3:
	dec	a3
	bge	incp1
	pop	a3		; restaurer le on-ne-sait-jamais.
	mov	#bufin,a2

1$:	.ttyin	a1		; .ttyin lit dans a1 = r0.
	cmpb	a1,#3		; [PM] is it a control-C ?
	bne	4$		; [PM] jump if not.
	jmp	reent		; [PM] reenter if yes.
4$:	movb	a1,(a2)+
	cmpb	a1,#lf
	bne	1$
	clrb	(a2)		; forcer 0 en fin d'entree.

	.if	ne,recor

	tst	flgrcd		; est-on en mode record ?
	beq	incp4		; non.
				; oui. copier le buffer lu dans bfrdk.
	mov	#bufin,a1
	br	3$
2$:
	push	a1
	call	trfrdk		; caractere dans a2.
	pop	a1
3$:
	movb	(a1)+,a2	; byte zero ?
	bne	2$		; non. balancer

	.endc

incp4:
	mov	#bufin,a2
	br	inch1

; ----- inchb : met dans a1 le caractere suivant du buffer d'entree.

inchb::	mov	inbpt,a2	; recup point. courant ligne.

inch1:	movb	(a2)+,a1	; caractere dans a1.
	beq	inci		; si fin ligne : vers new line.
	mov	a2,inbpt	; on range le pointeur.
	return

; ----- inci : lecture d'une ligne entiere et stockage dans bufin.

inci::
				; used by (TEREAD).

	tst	dski		; est-ce une entree disque ?
	beq	incp		; non.
.page
; ----- lecture sur disque.

				; oui. lisons sur le disque.

	mov	#inarea,a1
	.readw
				; lire 256. mots sur le disque.

	bcs	finfic		; fin-de-fichier ?
	inc	nblki		; non. incrementons le no de bloc.
				; le compte de mots lus dans a1 est INUTILE.
				; on remplace tous les bytes 0 par 177(8).

; %%%%%% a accelerer : coller un flag dskin testable dans getch.

	movb	#177,a4		; 177 = del, typech: 0, a ignorer.
	mov	#512.,a1
1$:	tstb	bufin-1(a1)
	bne	2$
	movb	a4,bufin-1(a1)
2$:
	sob	a1,1$


	br	incp4		; et c'est tout.

finfic:				; admettons que c'etait le fin-de-fichier.
	tst	rdprd		; pas assez de ")" ?
	beq	1$		; non. T.V.B.
	mov	#erpar,a1	; erreur de lecture fichier.
	jmp	errp		; les erreurs se chargeront de tout.
1$:

	mov	#nil,a1		; this allows redefinition of EOF
	mov	#ateof,a2	; lancement (EOF) automatique.
	call	evalfu
	br	inci		; et retourner lire sur dieu sait ou.


erpar:	.asciz	/** Input file has unmached parentheses /
	.even
; ****** outb, outs


; ----- outb : sort le caractere dans a2.
;		et le balance AUSSI dans le buffer record si
;		mode record actif.
;		recoit a2.
;		ne tue rien.
;		n'a rien a sauver.


outb::
	push	a1		; vache de .ttyout.

	.ttyout a2

	.if	ne,recor

	tst	flgrcd		; mode record ?
	beq	1$		; non.
	call	trfrdk		; oui. balancer.
1$:

	.endc

	pop	a1		; chien de .ttyout.
	return



; ----- outs : sort la chaine d'adresse a1 se terminant par 0

outs1:
	call	outb

; ----- entry outs

outs::	movb	(a1)+,a2
	bne	outs1
	return
	.page
; ****** erreurs

erlcm:	.asciz	/* Input error./
erlim:	.asciz	/* IMPLODE error./
	.even

; ----- erlec

erlec::	mov	#erlcm,a1
	tst	impli		; on etait dans implode ?
	bne	erimp		; oui.
	br	errp		; [PM] non. erreur normale.
erimp::	mov	#erlim,a1	; erreur implode.
	br	errm		; [PM]



; ----- erfs

erfs::
	tst	igc		; est-on dans mark ?
	bne	erfg		; oui. erreur fatale.
	mov	#erfsm,a1
	mov	#bstak+2,p	; reinitialisation de la pile.
	br	errm		; [PM]

erfsm:	.asciz	/* Stack full./
	.even


; ----- erato

erato::	mov	#eratm,a1
	br	errm		; [PM]

eratm:	.asciz	/* Atom area full./
	.even


; ----- erfm

erfm::	mov	#erfmm,a1
	br	errm		; [PM]

erfmm:	.asciz	/* List area full./
	.even

; ----- erfn

erfn::	mov	#erfnn,a1
	br	errm		; [PM]

erfnn:	.asciz	/* Number area full./
	.even
.page
; ----- erovfl

erovfl:: mov	#erovff,a1
	br	errm		; [PM]

erovff: .asciz	/* Integer Overflow./
	.even


; ----- erfg

erfg:	mov	#bstak+2,p
	mov	#merfg,a1
	br	errp		; [PM]

merfg:	.asciz	/* ad patres loco dolenti .../
	.even

; ----- erplc : constante modifiee.

erplc::
	push	a1
	mov	#erplm,a1
	br	errmp		; [PM]

erplm:	.asciz	/* Constant modified : /
	.even
.page
; ----- traitement des erreurs.
;	errp : imprime juste un message
;	errm : imprime un message et la derniere forme
;	errmp : imprime un message, la derniere forme, et l'objet

errp::
	call	tesdsk		; erreur disque ?
	call	pcrlf		; voila.
	br	reent2		; [PM] et c'est reparti pou un tour.

errm::
	call	tesdsk		; erreur disque ?
	call	pcrlf
	br	errmf

errmp::				; message dans a1, obj empile.
	call	tesdsk
	pop	a1		; recupere l'objet.
	call	probj
	call	pcrlf

errmf:
	clr	a5
	tst	pbind
	beq	1$
	mov	pbind,a5
	mov	2(a5),a5	; a5 = f-val.
1$:
	push	a5

	mov	#errml,a1
	call	prstr
	mov	form,a1
	call	probj
	call	pcrlf
	tst	(p)
	beq	2$
	mov	#errdfn,a1	; imprimer la derniere fonction.
	call	prstr
	mov	(p),a1
	call	probj
	call	pcrlf
2$:
	tst	(p)+		; depiler.
reent2:	jmp	reent

errml:	.asciz	/* Last form : /
	.even

errdfn:	.asciz	/* Last function : /
	.even
.page
; ----- tesdsk  :  teste si l'erreur est survenue
;		dans une entree-sortie disque.
;		si oui : ferme tout violemment et repasse en mode terminal.

tesdsk:
	tst	dski		; est-on en lecture disque ?
	bne	1$		; oui.
	tst	dsko		; est-on en sortie disque ?
	beq	2$		; non.
1$:
	push	a1		; les closes tuent surement a1.
	.close	#chani		; on ferme tout.
	.close	#chano
	clr	dski
	clr	dsko
	call	iniott		; reinitialiser buffer sortie TT.
	pop	a1		; retablir a1.
2$:
	call	pcrlf		; [PM] vide la derniere ligne
	call	outs		; [PM] ecrire la chaine.
	return
; ****** prch, prspc, prstr

; ----- prch : edite le caractere dans a1
;		dans le flux courant : print ou explode.
;		recoit a1. ne detruit rien.

; ----- pvch : id. prch (used in prato and prnum).
;		mais verifie et trappe que la longueur de ligne
;		licite d'impression n'est pas depassee.
;		si c'est le cas : trappe tout et repart au debut
;		de prato dans l'etat initial, apres avoir force un pcrlf.

pvch:
	tst	lcou
	bgt	prch

	mov	soubpt,oubpt
	mov	savpil,p	; retablir l'etat initial.
	mov	sava1,a1
	call	pcrlf		; forcer un pcrlf.
	jmp	prato		; et reessayer.

prch::
	tst	xpldi		; on est dans explode ?
	bne	prch1		; oui.

	dec	lcou
	push	a4
	mov	oubpt,a4
	movb	a1,bufou(a4)
	inc	a4
	mov	a4,oubpt
	pop	a4
	return

prch1:
	push	a2		; on sauve tout
	push	a3		; tout
	push	a4		; tout
	push	a5		; vraiment tout.

	call	crach		; cree l'atome mono-caractere
	call	ncons		; dans un doublet.
	mov	xpldl,a2	; recupere last.
	mov	a1,cdr(a2)	; (RPLACD last le-doublet).
	mov	a1,xpldl	; le-doublet devient le dernier last.

	pop	a5		; on restaure tout
	pop	a4		; tout
	pop	a3		; tout
	pop	a2		; vraiment tout
	return			; et on se casse vite fait.
.page
; ----- prspc : sort 1 espace ou 1 <cr>
;		ne detruit rien.

prspc:
	tst	lcou
	bgt	1$		; fin de ligne ?
	jmp	pcrlf		; oui. a la ligne.
1$:
	push	a1
	mov	#' ,a1		; non. un vrai espace.
	call	prch
	pop	a1		; restaurer a1
	return


; ----- prstr : sort la chaine pointee par a1.
;		ruine a2.
prst1:
	push	a1
	mov	a2,a1
	call	prchar		; [PM]
	pop	a1

; ----- entry prstr

prstr::
	movb	(a1)+,a2
	bne	prst1
	return

; ----- prchar : print a character with end of line test

prchar:	tst	lcou		; [PM] do we have space on this line?
	bgt	1$		; [PM] yes, go print the character
	call	pcrlf		; [PM] no, first print a cr,lf
1$:	br	prch
; ****** prnum

; ----- prnum : edite un nombre en decimal ou en octal selon le cas
;		argument dans a1.

prnum:
; .........
	.if	ne,fis

	cmp	a1,#bnum	; est-ce un inum ?
	blo	prnum3		; oui.
				; non.
	call	mrkmsk
	bit	a5,2(a4)	; est-ce un flottant ?
	beq	prnum2		; non. entier.
	jmp	prflt		; oui. flottant.


	.endc
; .........

prnum2:
	call	valnb
prnum3:
	mov	a1,a2		; a2 = valeur a convertir.


	mov	obase,a1	; obase est-elle une puissance de 2 ?
	push	a1		; i.e. ? obase AND (obase - 1) = 0 ?
	dec	a1
	bit	a1,(p)+
	bne	prdec		; non.



; ----- conversions en puissances de 2

	mov	#'#,a1		; marque de nombre en base non-10.
	call	pvch		; l'editer.
	tst	a2		; nombre = 0 ?
	bne	1$		; non.

	clr	a1		; editer "0" et bye.
	br	prndg
1$:
	clr	sign		; on n'imprime pas les zeros en tete.

	mov	obase,a1
	cmp	a1,#8.
	bne	2$

	clr	a1		; cas obase 8. on traite le bit 0.
	call	prnd2		; sinon imprimer le bit 0.
	push	#prnd8
	mov	#5,a1		; nb d'iterations de decalages obase 8 = 5.
	br	5$
.page
2$:
	cmp	a1,#16.
	bne	3$

	push	#prnd16		; cas obase 16.
	mov	#4,a1		; nb d'iterations de decalages obase 16 = 4.
	br	5$
3$:
	cmp	a1,#2
	bne	prdec		; si obase non = 2, 8, 16 alors sortie decimale.

	push	#prnd2		; cas obase 2.
	mov	#16.,a1		; nb d'iterations de decalages obase 2 = 16.
	br	5$
4$:
	push	a1
	clr	a1		; pour la conversion.
	push	2(p)		; empiler l'adresse du point d'entree.
	call	@(p)+		; coroutine.
	pop	a1
5$:
	dec	a1
	bge	4$
	tst	(p)+		; on depile l'adresse de la routine de decalage.

	return			; fini.

; ----- pour tous ces points d'entree, a1 = 0 imperativement.

prnd16:
	asl	a2		; entree obase 16.
	rol	a1
prnd8:
	asl	a2		; entree obase 8.
	rol	a1
	asl	a2		; entree obase 4. (non-implementee).
	rol	a1
prnd2:
	asl	a2		; entree obase 2.
	rol	a1
	beq	1$		; si resultat zero.

				; sign sera > 0.
	inc	sign		; a present on imprime les zeros.
1$:
	tst	sign		; zeros significatifs ?
	bne	finprn		; oui.
	return			; non, bye.
.page
; ----- conversion en obase non puissance de 2.

prdec:
	mov	a2,a1
	tst	a2
	beq	prndg		; = 0 ?

	bge	1$		; negatif ?
	mov	#'-,a1		; oui.
	call	pvch		; sortir "-".
	neg	a2
1$:				; preparer la division.

	mov	a2,a1
2$:
	mov	obase,a2
	call	dvd		; reste dans a1, quotient dans a3.
	push	a1		; sauver le reste.
	tst	a3		; quotient nul ?
	beq	3$		; si zero.
	mov	a3,a1
	call	2$		; appel recursif. hack.
3$:	pop	a1
finprn:
	cmp	a1,#9.		; chiffre superieur a 9. ?
	ble	prndg		; oui.

	add	#7,a1		; lettre : A, B, C, ...
				; idee : "0" = 60(8), "A" = 101(8).
prndg:	add	#'0,a1		; convertir en ascii.
	jmp	pvch		; outer.
; ****** prflt
; .........
	.if	ne,fis

; ----- prflt : impression de nombre flottant.

savprf:	.word	0

; ----- entry prflt

prflt:
	mov	p,savprf	; sauver la pile.
	mov	free,tem0

	clr	-(p)		; slot for decimal exponent
	clr	-(p)		; slot for sign
	push	2(a1)		; get argument low
	mov	(a1),a1		; get argument high
	rol	a1		; isolate sign in carry
	ror	2(p)		; save it in sign-slot 1 or 0.
	ror	a1		; clear it in high argument.
	push	a1		; and push its absolute value.
	bne	fnorm		; si pas zero.
	jmp	fprint		; si zero.

fnorm:
		; divide by powers of 10 to reduce the number to the range
		; 1 <= X < 10.
		; stack = abs-high:low:sign:dexp: ...

	cmp	(p),#040200	; is it < or >= than 1.0?
	blt	fsmal

				; here arg >= 1.0
fbig:
	cmp	(p),#046676	; > than 10**8?
	bgt	1$
	blt	2$
	cmp	2(p),#136040	; if ho ord = compare lo ord
	blo	2$
1$:
	pushf	1.0e8
	fdiv	p		; divide by 10**8
	add	#10,6(p)	; adjust decimal exponent
	br	fbig		; may have to do it again
	.endc
	.page
	.if	ne,fis

2$:	cmp	(p),#043434	; > than 10**4?
	blt	4$
	bgt	3$
	cmp	2(p),#40000	; check low order
	blo	4$
3$:	pushf	1.0e4
	fdiv	p		; divide by 10**4
	add	#4,6(p)		; adjust dexp
4$:	cmp	(p),#041710	; > than 10**2?
	blt	5$
	clr	-(p)
	push	#041710
	fdiv	p		; divide by 10**2
	add	#2,6(p)		; adjust dexp
5$:	cmp	(p),#041040	; > than 10?
	blt	6$
	clr	-(p)
	push	#041040
	fdiv	p
	inc	6(p)		; decimal exponent
6$:	br	fprint


fsmal:	cmp	(p),#032326	; < 10**-7?	we are here because the number
	bgt	2$		;		is less than 1.0
	blt	1$
	cmp	2(p),#137625	; compare lo order if necessary
	bhis	2$
1$:	pushf	1.0e8
	fmul	p		; mult by 10**8
	sub	#10,6(p)	; adjust dexp
	br	fsmal		; see if we need to again
2$:	cmp	(p),#035603	; < 10**-3?
	bgt	4$
	blt	3$
	cmp	2(p),#011157
	bhis	4$
3$:	pushf	1.0e4
	fmul	p		; mult by 10**4
	sub	#4,6(p)		; adjust decimal exponent
4$:	cmp	(p),#037314	; < 10**-1?
	bgt	6$
	blt	5$
	cmp	2(p),#146314
	bhi	6$
	.endc
	.page
	.if	ne,fis

5$:
	clr	-(p)
	push	#041710
	fmul	p		; mult by 10**2
	sub	#2,6(p)		; adjust decimal exponent
6$:
	cmp	(p),#040200	; < 1.0?
	bge	fprint
	clr	-(p)
	push	#041040
	fmul	p		; mult by 10
	dec	6(p)		; adjust decimal exponent

	; now arg is between 1 and 10, break it into 8 decimal digits
	; and put them in the stack.

fprint:
	pop	a1
	pop	a2		; put # into a1-2

	sub	#10.,p		; faire de la place dans la pile.
	mov	p,r5		; r5 will be a local pointer.
	clrb	(r5)+
	clr	r2
	mov	a1,r4		; start breaking apart number
	asl	r4
	bic	#100377,r4	; clear excess 200 bit and mantissa
	swab	r4		; binary exponent in r4.

	swab	a1
	beq	1$		; don't set hidden bit in zero
	bis	#100000,a1	; install hidden bit
1$:
	clrb	a1
	swab	a2
	bisb	a2,a1
	clrb	r1		; mantissa in r0-1, left adjusted

	asl	r1
	rol	r0
	rol	r2
	dec	r4
	bgt	1$
	push	#8.		; loop counter for pulling out dec digits.
2$:
	movb	r2,(r5)+	; integer part (first digit)
	.endc
	.page
	.if	ne,fis

;%%%%%%
;	push	r0
;	movb	r2,r0
;	add	#'0,r0
;	.ttyout r0
;	pop	r0
;%%%%%%

	CLR	R2
	MOV	R0,R3		;COPY HI ORDER
	MOV	R1,R4		;COPY LO ORDER
	call	tims2
	call	tims2
	ADD	R4,R1
	ADC	R0
	ADC	R2
	ADD	R3,R0
	ADC	R2		;TIMES 10
	call	tims2
	DEC	(p)		;WILL DO THIS 8 TIMES
	BGT	2$		; et recommencer.
	tst	(p)+		; virer compteur de la pile.
	mov	#8.,r3		; K nb de chiffres apres le point.
	add	12.(p),r3	; + dexp
	inc	r3
	blt	3$

	sub	#7,r3
	bge	3$
	add	r3,r5
3$:	cmpb	-(r5),#5	; decimal rounding
	blt	5$
4$:	clrb	(r5)
	incb	-(r5)
	cmpb	(r5),#10.
	bge	4$
5$:	mov	p,r5		; get ready to dump
	tstb	(r5)+
	beq	fp2
	dec	r5		; reculer.
	inc	12.(p)		; adjust decimal exponent.

fp2:	mov	#8.,r2		; get decimal places i.e. K

	tst	10.(p)		; put out sign
	beq	1$		; if dexp - put 0 then leading zeros
	mov	#'-,a1		; then #, up to space limit

	call	pvch
	.endc
	.page
	.if	ne,fis

1$:
	mov	#8.,r3		; if dexp	;, O  put # down to dp
	mov	12.(p),r4	; decimal exponent.
	bpl	2$		; si positif ou nul.
				; si negatif : outer "0."

	mov	#'0,a1		; le zero ...
	call	pvch
	br	4$		; puis le point.

2$:
	inc	r4		; then dp digits beyond
3$:
	call	dumpadig
	sob	r4,3$
4$:
	MOV	#'.,R0
	call	pvch
				; apres le point decimal.
				; r2 contient K.
	mov	p,r1
5$:
	dec	r2
	blt	flexit
	clr	r0
	inc	r4		; do we have 0's after the dp ?
	blt	6$

	dec	r3
	ble	flexit
	movb	(r5)+,r0
6$:
	push	r0		; sauver chiffre (en binaire).
	br	5$
	.endc
	.page
	.if	ne,fis

flexit:
1$:	tst	(p)+
	beq	1$
	tst	-(p)
	br	3$
2$:	mov	-(r1),r0
	add	#'0,r0
	call	pvch
3$:	cmp	r1,p
	bgt	2$

	mov	savprf,p
	mov	tem0,free
	clr	a1
	clr	a2
	clr	a3
	return


tims2:	asl	r1
	rol	r0
	rol	r2		;simple multiply by 2
	return


;%%%%%% a deproceduraliser.
dumpadig:
	clr	r0
	dec	r3
	ble	1$
	movb	(r5)+,r0
1$:	add	#'0,r0
	jmp	pvch		; jrst-hack


	.endc
; .........
; ****** prast, prato, probj

; ----- prast : edite l'atome * . prato doit suivre.

prast:	mov	#atastr,a1	; adresse de l'atome *.
				; prato doit suivre.

; ----- prato : edite l'atome en a1.
;		avec des / ou des "" suivant le cas.

prato:
				; preserver l'etat initial.
	mov	oubpt,soubpt
	mov	p,savpil	; preparer trappe.
	mov	a1,sava1

	jfnum	a1,1$
	jmp	prnum		; c'est un nombre.
1$:
	mov	a1,a4		; adresse d'atome dans a4 aussi.
	add	#dplpn,a1	; a1 : pointeur sur p-name.
	movb	(a1)+,a2	; plength -> a2.
	mov	a1,a3		; a3 pointe sur p-name reel.
	cmp	a2,lcou		; ca rentre ?
	ble	2$		; oui
	call	pcrlf		; non
2$:	bit	#4,opti		; bit 2. faut-il les "..." ?
	bne	prat4		;
prat2:				; a3 pointe sur vrai p-name.
	tst	a2		; p-name vide ?
	beq	prat30		; oui.
prat20:
	movb	(a3)+,a1	; le caractere.
	bit	#2,opti		; bit 1. faut-il les "/" ?
	beq	prat3		; non .
	movb	tabch(a1),a4	; a4 <- type caractere dans a1.

	cmp	a4,#clnor	; caractere normal ?
	beq	prat3		; oui.
	push	a1
	mov	#'/,a1
	call	pvch		; slashifions.
	pop	a1
prat3:
	call	pvch		; on sort le caractere.
	sob	a2,prat20	; si plength > 0, boucler.
prat30:
	return
				; sortie de chaine.
.page
prat4:
	cmpb	dpptyp(a4),#at.str	; est-ce une pseudo-chaine ?
	bne	prat2		; non.
	call	prat6		; edite le 1er ".
	tst	a2		; chaine vide ?
	beq	prat6		; oui. edite tout de suite le dernier ".
prat5:
	movb	(a3)+,a1	; caractere suivant
	call	pvch		; qui est edite.
	sob	a2,prat5	; si plength > 0, boucler.
prat6:
	mov	#'",a1		; le separateur de chaine lui-meme
	jmp	pvch		; est edite.



; ----- probj : edite l'objet LISP quelconque en a1.

probj::
	clr	prcdp		; initialisation profondeur courante.
	clr	prcln		; initialisation longueur courante.
	mov	opti,a2		; recupere l'indicateur de status print.
	bic	#177776,a2	; si bit 0 : debuter par 1 espace ?
prob0:
	mov	a2,prnxt
prob1:
	tst	prnxt		; faut-il un espace ?
	bne	probc		; non
	call	prspc		; oui
probc:
	jflst	a1,prato	; si a1 n'est pas une liste.

	inc	prcdp		; remise a jour profondeur courante.
	cmp	prcdp,prmdp	; on depasse la profondeur ?
	ble	1$
	br	prast		; [PM] oui. on edite un *.
1$:

	push	a1
	mov	#'(,a1
	mov	a1,prnxt	; le suivant est colle.
	call	prch
	pop	a1
.page
prob3:
	inc	prcln		; R.A.J. longueur courante.
	mov	prmln,a5
	cmp	a5,#bnum
	blo	1$
	mov	(a5),a5
1$:
	cmp	prcln,a5	; on depasse la longueur max ?

	ble	3$		; non.
				; on imprime " ...)" .
	call	prspc
	mov	#2$,a1
	call	prstr
	br	prob4

2$:	.asciz	/.../
	.even

3$:
	mov	(a1)+,a2
	push	(a1)		; sauve le cdr.

;	uncns			; a2 <- car a1, a1 <- cdr a1.
;	push	a1		; sauve le cdr.

	mov	a2,a1		; (car obj) -> a1.
	ckstk			; tester pile.
	call	prob1		; editer.
	clr	prnxt		; pour tous les autres elements: 1 pre-espace.
	pop	a1		; recuperer le cdr.
	jtlst	a1,prob3	; si liste, iterer sur les cdr.
	jtnil	a1,prob4	; si cdr = nil.
	push	a1
	call	prspc
	mov	#'.,a1
	call	prch
	call	prspc
	pop	a1
	call	prato
prob4:
	dec	prcdp		; remettre a jour la profondeur courante.
	mov	#'),a1
	jmp	prch
; ****** print, pcrlf, prin, prini, trfrdk

; ****** (print e1 ... en)  [fsubr]

print::
	call	prin

; ----- pcrlf
;		tue a5.

pcrlf::
	mov	#1,a5
pcrlf1:
	push	a1
	push	a2
	push	a4

	; tester a5 et prendre les mesures subsequentes.

	mov	#bufou,a4
	add	oubpt,a4	; a4 pointe sur une adresse d'octet.

	tst	a5
	blt	pcrlf2		; cas a5 < 0.
	bgt	2$

	movb	#cr,(a4)+	; cas a5 = 0. <cr> seul (pour surimpression).
	br	pcrlf2

1$:
	movb	#cr,(a4)+
	movb	#lf,(a4)+
2$:				; cas a5 > 0. emettre a5 fois <cr><lf>.
	dec	a5
	bge	1$

pcrlf2:
	clrb	(a4)		; forcer 0 en fin de buffer TT.

	; c'est ici qu'on va decider si on ecrit sur TT ou dans le buffer DSK.

1$:
	tst	dsko
	beq	pcrlf4		; cas ecriture TT.

	; ecriture dans buffer DSK.

				; transfert bufou -> bfodk.
	call	trnfrt
	br	pcrlf5
.page
	; impression sur TT

pcrlf4:				; il faut une boucle,
				; car .PRINT ferait un <cr><lf>.
	mov	#bufou,a4
	br	2$
1$:
	call	outb
2$:
	movb	(a4)+,a2
	bne	1$		; imprimer jusqu'a rencontre de 0.
				; pcrlf5 doit suivre.
pcrlf5:
	call	iniott	; reinitialiser buffer TT.
	pop	a4
	pop	a2
	pop	a1
	return




; ----- trfrdk  :  balance le caractere dans a2 dans BFRDK (buffer record).
;		  et si plein. le vide sur disque.
.if	ne,recor			; [PM]

trfrdk:
	push	a4		; on sauve a4 a tout hasard.
	mov	rcdpt,a4	; attraper le pointeur.
	movb	a2,(a4)+	; placer caractere.
	mov	a4,rcdpt	; ranger pointeur.
	cmp	a4,#ebfrdk	; buffer record plein ?
	bne	2$		; non.

	mov	#rearea,a1	; oui. vider.
	.writw			; ecrire le buffer sur disque.
	bcc	1$		; si OK.
	jmp	erwfic		; caramba ! encore rrrate !
1$:
	inc	nblkre		; incrementer no de bloc record.
	call	inirdk		; reinitialiser le buffer record.
2$:
	pop	a4		; restituer a4.
	return
.endc				; [PM]
.page
; ----- trnfrt  :  pour transferer buffer out TT -> buffer out DSK

trnfrt::
	mov	#bufou,a4
trnfr1:
	mov	oubpk,a5
	br	2$
1$:
	movb	(a4)+,(a5)+	; transferer.
2$:
	cmp	a5,#ebfodk	; buffer DSK plein ?
	beq	trnfr2		; oui.
	tstb	(a4)		; fin-de-transfert (byte 0) ?
	bne	1$		; non.
				; oui.
	mov	a5,oubpk	; ranger le pointeur buffer DSK.
	return

	; vider les 256. mots de bfodk sur disque.

trnfr2::
	push	a4		; on n'est jamais trop prudent.
	call	writew		; [PM] ecrire
	inc	nblko		; incrementer le numero de bloc.
	call	iniodk		; reinitialisation buffer DSK et son pointeur.
	pop	a4		; recuperer le jamais trop prudent.
	br	trnfr1		; et continuer le transfert.

.page
; ****** (prin e1 ... en)  [fsubr]

prin11:
	push	a1		; sauver le cdr.
	mov	a2,a1
	call	eval		; evaluer le car.
	call	probj		; editer le resultat de l'evaluation.
	pop	a1		; recuperer le cdr.

; ----- entry  prin.

prin::
	uncns			; a2 <- car a1, a1 <- cdr a1.
	jtlst	a1,prin11	; yen a encore.
	mov	a2,a1		; dernier element dans a1.
	call	eval		; l'evaluer.

	push	a1		; sauve cette valeur.
	call	probj		; l'editer.
	pop	a1		; restituer valeur.
	return			; bye.
.page
; ***** (PRINCH C [N])  [SUBR 2]  edite N fois le caractere C.
;				 par defaut N = 1.

princh::
	jfnil	a2,1$
	mov	#1,a2		; par defaut, N = 1.
1$:
	push	a2		; sauve le nombre.
	call	vlas		; a1 = le code ascii du caractere C.

	mov	a1,a2		; pour l'impression.
	mov	(p),a1		; prendre le nombre
	call	valnb		; coller sa valeur dans a1.

	mov	a1,a4		; a4 le compteur.
	mov	a2,a1
	br	3$

2$:	call	prchar		; [PM] imprime le caractere.

3$:	dec	a4		; encore ?
	bge	2$
	pop	a1		; ramener le nombre.
	return



; ***** (TERPRI [N])  [SUBR 1]

terpri::
	jfnil	a1,1$
	jmp	pcrlf		; (TERPRI) == (TERPRI 1).
1$:
	push	a1		; sauver le nombre.
	call	valnb
	mov	a1,a5
	call	pcrlf1
	pop	a1		; ramener le nombre en valeur.
	return
.page
; ***** (EXPLODE S)  [SUBR 1]

explod::
	inc	xpldi		; positionne l'indicateur explode.
	push	a1		; sauve l'argument.
	call	nicons		; cree le 1er (NIL . NIL) hook.
	mov	a1,xpldl	; sauve dans last-explode.


	xtopst	a1,via,a5	; a1 = l'argument, empile le hook.

	mov	#1,a2		; indic prind (la 1ere fois).
	call	prob0
	clr	xpldi		; indicateur explode = 0.
	pop	a1		; recupere le hook.
	jmp	cdr.p		; et ramener son cdr.


; ***** (PRINTLENGTH [N])  [SUBR 1]
;			  set/get la profondeur d'impression.

prlgn::
	jtnil	a1,1$
	call	valnb
	mov	a1,prmln
1$:
	mov	prmln,a1
	jmp	cranb


; ***** (PRINTLEVEL [N])  [SUBR 1]
;			 set/get la profondeur d'impression.

prlvl::
	mov	#prmdp,a2	; adresse de prmdp dans a2.
				; gtst doit suivre.

; ----- gtst : get/set  le mot d'adresse a2 avec la valeur a1.
;		a1 DOIT etre un inum.

gtst::
	jtnil	a1,gtst1	; si la valeur n'est pas fournie.

	bic	#177600,a1	; la valeur max est 128.
	mov	a1,@a2		; set.
gtst1:
	mov	@a2,a1		; get. C'EST un inum.
	return			; donc bye.
.page
; ***** (LMARGIN [N])   [SUBR 1]

lmargi::
	mov	#lmar,a2
	br	gtst


; ***** (RMARGIN [N])   [SUBR 1]

rmargi::
	mov	#rmar,a2
	br	gtst


; ***** (OUTPOS [N])	[SUBR 1]
;			connaitre ou modifier position courante dans bufou.

outpos::
	jtnil	a1,1$

	push	a1
	call	valnb
	mov	a1,a4
	call	tespos		; correctement place ?
	mov	rmar,a4
	sub	a1,a4
	inc	a4
	mov	a4,lcou		; R.A.J. lcou.
	pop	a1
1$:
	mov	#oubpt,a2
	br	gtst
.page
; ***** (OUTBUF N [C])  [SUBR 2]
;			connaitre ou placer le caractere
;			en position N dans bufou.

outbuf::
	push	a1
	call	valnb		; valeur nombre dans a1
	mov	a1,a4
	call	tespos		; position correcte ?
	tst	(p)+		; oui. depiler.
	jtnil	a2,1$
				; placer.

	push	a1		; sauver valeur.
	mov	a2,a1		; adresse atome mono-caractere dans a1.
	call	vlas		; ascii atome mono-caractere dans a1.
	pop	a4		; restaurer valeur.
	movb	a1,bufou(a4)	; forcer caractere.
	a2popj			; ramener atome mono-caractere en valeur.
1$:				; connaitre.
	movb	bufou(a1),a1	; attraper caractere.
	jmp	crach		; creer atome mono-caractere.



; ----- tespos  :  teste si a4 est dans l'intervalle [lmar:rmar]

tespos:
	cmp	a4,lmar
	blt	erpos
	cmp	a4,rmar
	bgt	erpos
	return


erpos:
	tst	(p)+		; nombre incorrect dans la pile.
	mov	#erposm,a1
	jmp	errmp

erposm: .asciz	/* Line beyond margin :/
	.even


	.end			; ****** END OF VL8 ******
