.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 ; 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. seul (pour surimpression). br pcrlf2 1$: movb #cr,(a4)+ movb #lf,(a4)+ 2$: ; cas a5 > 0. emettre a5 fois . 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 . 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 ******