.TITLE VL6 .psect VL6 ; stored on: VL6.MAC ; last revised: 20-Dec-83 xx1 = version xx2 = options xx3 = eis xx4 = fis xx5 = clock xx6 = i11.04 xx7 = recor .globl apply,batom,blist,bnum,bstak,carry,catoc .globl erfm,erfn,erfs,erovfl,erplc,errmp,evca1 .globl false,freenb,gcspk .globl hcnst,hdato,hlist,hnum,hstak .globl igc,ndl,ngc,nil,nnl,opti,outs .globl pcrlf,probj,prstr,savnb,sign,tem0 .iif ne,fis .globl savnb2 ; MODULE PAGE CONTENTS ; VL6 10 ****** fonctions numeriques. ; 15 ****** fonctions flottantes. ; 18 ****** MAPC, MAP, MAPCAR, MAPLIST, MAPCONC. ; 22 ****** cons et garb. ; 26 ****** MARK ET GC. ; 29 ****** creation et valeurs de nombres. ; 31 ****** marquage des nombres, bits-tables et freres. ; 33 ****** multiplication et division: mult, dvd. .page ; ****** fonctions numeriques. ; ***** (ADD1 N) [SUBR 1] add1:: call valnb inc a1 jmp cranb1 ; [PM] ; ***** (SUB1 N) [SUBR 1] sub1:: call valnb dec a1 jmp cranb1 ; [PM] ; ***** (+ N1 N2 ... NN) [FSUBR] plus:: clr -(p) ; empiler 0 : identity. clr carry ; [PM] br 3$ 1$: push cdr(a1) ; sauver reste des arguments. call evca1 ; evaluer 1er argument courant. call valnb ; attraper sa valeur. mov 2(p),a4 ; la parano qui suit vise a ne pas laisser ; dans la pile un nb qui risque ; d'etre une adresse de CDR. ; [PM] cmp a4,#bnum ; est-ce un inum ? ; [PM] blo 2$ ; oui. ; [PM] mov (a4),a4 ; non. attraper sa valeur binaire. ; [PM] I dont see why it is risky to put the binary form of the number in ; the stack, so I will try it that way. 2$: add a4,a1 ; l'addition. adc carry ; [PM] accumulate the carry bits into carry ; [PM] call cranb ; re-envelopper si non-inum. mov a1,2(p) ; et remettre dans la pile. pop a1 ; recuperer le reste des arguments. 3$: jtlst a1,1$ ; yen a encore ? pop a1 ; non. on passe le bebe ; [PM] return jmp cranb ; [PM] .page ; ***** (* N1 N2 ... NN) [FSUBR] ; plus dur. ; %%%%%% a optimiser : pourquoi ne pas laisser a4 dans la pile ? ; completely rewritten by PM to fix bug with boxed numbers. now the sign is ; kept track of in the multiply routine instead of here. times:: push cdr(a1) ; save the rest of the arguments call evca1 ; evaluate the first argument call valnb ; get the binary value of the first argument mov a1,a4 ; save first arg in a4 pop a1 ; get the rest of the arguments 1$: push cdr(a1) ; push the rest of the arguments push a4 ; save the running product call evca1 ; evaluate the next argument call valnb ; get the binary value pop a2 ; retrieve the running product call mult ; a4 = a1 * a2 pop a1 ; retrieve the rest of the arguments jtlst a1,1$ ; jump back if there are any arguments left mov a4,a1 ; a1 is the product jmp cranb ; make it a number ; ***** (- N1 N2) [SUBR 2] ; plus facile. differ:: call valnb2 ; a1 = val(a1), a4 = val(a2). jfnil a4,1$ ; est-ce le cas (- N) ? mov a1,a4 ; oui. clr a1 ; preparer le (- 0 N) 1$: sub a4,a1 jmp cranb1 ; [PM] .page ; ***** (QUO N1 N2) [SUBR 2] ; si signes egaux alors + sinon -. .if eq,eis ; [PM] quo:: call valnb2 ; a1 = val(a1), a4 = val(a2). quo1: clr sign ; used by REM. mov a4,a2 ; debile. bge 1$ neg a2 com sign 1$: tst a1 bge 2$ neg a1 com sign 2$: call dvd ; a1=a1/a2, quotient dans a3. mov a1,a5 ; pour rem. mov a3,a1 .endc ; [PM] quo2:: tst sign beq 1$ ; non neg a1 ; oui. negativer le resultat subsequemment. 1$: jmp cranb ; voila une bonne chose de faite. .if ne,eis ; [PM] quo:: call diveis ; [PM] do divide using eis jmp cranb ; [PM] make it into a number diveis: call valnb2 ; [PM] a1=val(a1), a4=val(a2) mov a1,a2 ; [PM] r1= lsw clr a1 ; [PM] r0= msw div a4,a1 ; [PM] a1 = [msw,lsw] / a4 ; remainder in a2 return ; [PM] .endc ; [PM] ; ***** (REM N1 N2) [SUBR 2] ; signe = signe dividende. .if eq,eis ; [PM] rem:: call valnb2 ; a1 = val(a1), a4 = val(a2) push a1 ; sauver le diviseur. call quo1 mov a5,a1 ; que quo avait prepare. tst (p)+ ; recuperer le dividende. br abs2 ; [PM] .endc ; [PM] .if ne,eis ; [PM] rem:: call diveis ; [PM] use eis for the divide mov a2,a1 ; [PM] get the remainder into a1 jmp cranb ; [PM] make it into a number .endc ; [PM] .page ; ***** (LOGXOR N1 N2) [SUBR 2] logxor:: call valnb2 ; a1 = val(a1), a4 = val(a2) .if ne,i11.04 ; [PM] push a4 bic a1,(p) ; must do this, since 11/04 has no xor bic a4,a1 bis (p)+,a1 .endc ; [PM] .if eq,i11.04 ; [PM] xor a4,a1 ; [PM] .endc ; [PM] jmp cranb ; ***** (LOGAND N1 N2) [SUBR 2] logand:: call valnb2 ; a1 = val(a1), a4 = val(a2). com a4 bic a4,a1 jmp cranb ; ***** (LOGOR N1 N2) [SUBR 2] logor:: call valnb2 ; a1 = val(a1), a4 = val(a2). bis a4,a1 jmp cranb ; ***** (COMPL N) [SUBR 1] compl:: call valnb com a1 jmp cranb ; ***** (ABS N) [SUBR 1] abs:: call valnb tst a1 abs2: bge 1$ neg a1 1$: jmp cranb .page ; ***** (LSH N nbshifts) [SUBR 2] lsh:: push #cranb call valnb2 ; a1 = val(a1), a4 = val(a2). .if eq,eis ; [PM] tst a4 blt logsh2 br 2$ 1$: rol a1 clc 2$: dec a4 bge 1$ return logsh2: br 2$ 1$: ror a1 clc 2$: inc a4 ble 1$ return .endc ; [PM] .if ne,eis ; [PM] mov a1,a2 ; [PM] clr a1 ; [PM] ashc a4,a1 ; [PM] mov a2,a1 ; [PM] return ; [PM] .endc ; [PM] ; ***** (INCR V) [FSUBR] incr:: mov (a1),a1 ; variable dans a1 cmp a1,#hcnst ; [PM] is it restricted from modification? blos erplc2 ; [PM] jump if yes push a1 ; [PM] variable on stack mov (a1),a1 ; cval dans a1. call add1 ; [PM] incr2: pop a2 ; [PM] recover variable mov a1,(a2) ; stocker dans variable. return ; retourner le nombre. ; ***** (DECR V) [FSUBR] decr:: mov (a1),a1 ; variable dans a1 cmp a1,#hcnst ; [PM] is it restricted from modification? bhi .+6 ; [PM] no, its ok to modify erplc2: jmp erplc ; [PM] go tell user, cant modify constants push a1 ; [PM] variable on stack mov (a1),a1 ; cval dans a1. call sub1 br incr2 ; ****** fonctions flottantes. .if ne,fis ;%%%%%% a optimiser ; ***** (FLOAT N) [SUBR 1] float:: call valnb mov a1,a5 ; valeur de l'entier dans a5. clr a1 clr a4 tst a5 ; nb positif ? bgt 1$ ; oui. neg a5 ; non. negativer. ble 3$ ; c'est zero. bye. mov #100000,a1 ; coller bit de signe. 1$: bis #46000,a1 ; pre-exponent. 2$: asl a5 rol a4 sub #200,a1 ; soustraire 1 a l'exposant. bit #200,a4 beq 2$ bic #200,a4 bis a1,a4 3$: mov a4,a1 mov a5,a2 jmp cranf .endc .page .if ne,fis ; ***** (FIX F) [SUBR 1] fix:: mov 2(a1),a3 mov (a1),a1 mov a1,a5 beq 3$ ; si zero mov a1,a2 bic #177600,a2 ; a2 = high fraction. bis #200,a2 ; gives back high bit normalized. asl a1 swab a1 bic #177400,a1 ; a1 = exponent. sub #200,a1 ble 3$ ; smaller than 1. sub #30,a1 1$: asr a2 ror a3 inc a1 bne 1$ tst a5 bpl 2$ neg a3 2$: mov a3,a1 clr a2 jmp cranb 3$: clr a2 ; on ramene zero. clr a3 clr a1 return .endc .page .if ne,fis ; ----- fpre preparation des arguments flottants fpre: pop a4 ; catch return address push 2(a1) push (a1) push 2(a2) push (a2) push a4 ; stack return address return ; ***** ($+ F1 F2) [SUBR 2] fplus:: call fpre fadd p fplus2: pop a1 pop a2 jmp cranf ; ***** ($- F1 F2) [SUBR 2] fdiff:: call fpre fsub p br fplus2 ; ***** ($* F1 F2) [SUBR 2] ftimes:: call fpre fmul p br fplus2 ; ***** ($// F1 F2) [SUBR 2] fquo:: call fpre fdiv p br fplus2 .endc ; ****** MAPC, MAP, MAPCAR, MAPLIST, MAPCONC ; %%%%%% a revoir avec consl. ; ***** (MAPC F L) [SUBR 2] mapc:: mov #imapc,a5 ; l'argument de F sera chacun des CARs. br mapnil ; ***** (MAP F L) [SUBR 2] map:: mov #imap,a5 ; l'argument de F sera chacun des CDRs. br mapnil ; ***** (MAPCAR F L) [SUBR 2] mapcar:: mov #imapc,a5 ; l'argument de F sera chacun des CARs. br mapqqc ; ***** (MAPLIST F L) [SUBR 2] maplis:: mov #imap,a5 ; l'argument de F sera chacun des CDRs. br mapqqc .page ; ***** (MAPCONC F L) [SUBR 2] ; ex : (de leaves (x) ; (if (atom x) [x] ; (mapconc 'leaves x))) mapcon:: push a1 ; sauver F. push a2 ; sauver L. call nicons mov (p),a2 ; a2 = L. mov a1,(p) ; pile = hook:F:le-reste ... br mapco2 mapco1: push a1 ; sauver le last mov (a2)+,a1 mov (a2),a2 ; a1 = (car L), a2 = (cdr L). push a2 ; sauver le-reste-de-L. call ncons ; nconser l'argument de F. mov a1,a2 ; argument dans a2 pour apply. ; pile = L:last:hook:F:le-reste ... mov 6(p),a1 ; a1 = F. call apply ; appliquer. ca ramene une liste dans a1. pop a2 ; recuperer L. pop a3 ; recuperer last. jfnil a1,1$ ; a1 = nil ? mov a3,a1 ; oui. le last courant reste le last. br mapco2 1$: mov a1,cdr(a3) ; rplacder le last avec la liste a1. br 3$ ; le nouveau last doit etre 2$: ; le dernier doublet de a1. mov a3,a1 3$: mov cdr(a1),a3 jtlst a3,2$ mapco2: jtlst a2,mapco1 ; encore du L ? pop a1 ; non. recuperer le hook. mov cdr(a1),a1 ; ramener son cdr. tst (p)+ ; depiler F. return ; bye. .page ; ----- imapc : selection de l'argument de mapc et mapcar. imapc: mov (a2)+,a1 mov (a2),a2 return ; ----- imap : selection de l'argument de map et maplist. imap: mov a2,a1 mov cdr(a2),a2 return ; ----- mapnil : corps general de mapc et map. ramenent nil. ; a5 = adresse de la selection d'argument. mapnil: push a5 ; sauver la selection push a1 ; sauver F br 2$ 1$: push 2(p) ; colle argument de F dans a1, avance dans L. call @(p)+ ; coroutine ! push a2 ; sauver reste de L call ncons ; nconser l'argument dans a1 mov a1,a2 ; argument dans a2, pour apply. mov 2(p),a1 ; recuperer F call apply ; appliquer pop a2 ; recuperer reste de L 2$: jtlst a2,1$ ; encore ? cmp (p)+,(p)+ ; non. depiler F et la selection. jmp false ; et ramener nil. .page ; ----- mapqqc : corps general de mapcar et maplist. ramenent qqc. ; a5 = adresse de la selection d'argument. mapqqc: push a5 ; sauver la selection d'arguments. push a1 ; sauver F. push a2 ; sauver L call nicons mov (p),a2 mov a1,(p) ; a2 = L, hook empile et dans a1. br 2$ 1$: push a1 ; sauver last. ; pile = last:hook:F:selection:le-reste ... push 6(p) ; colle argument de F dans a1, avance dans L. call @(p)+ ; coroutine ! push a2 ; sauve reste-de-L. call ncons ; nconser l'argument dans a1. mov a1,a2 ; preparer a2 pour apply. mov 6(p),a1 ; atrapper F dans a1. call apply ; appliquer. call ncons ; nconser le resultat de l'application. pop a2 ; recuperer reste-de-L. pop a3 ; recuperer last. mov a1,cdr(a3) ; rplacder le last, a1 devient le nouveau last. ; pile = hook:F:selection:le-reste ... 2$: jtlst a2,1$ ; encore ? pop a1 ; non. recuper le hook. mov cdr(a1),a1 cmp (p)+,(p)+ ; depiler 2 fois. return ; et ramener a1. ; ****** cons et garb ; ----- qcons : ramene dans a4 l'adresse de cdr d'un doublet alloue. ; %%%%%% super gaffe : dans le cons on-line, verifier dans le trap4 ; la possibilite d'un 2d argument auto-increment. qcons:: tst free bne qcons1 call garb qcons1: mov free,a4 mov (a4),free return nicons:: ; (cons 0 nil) -> a1. Pour crochets. clr a1 ncons:: mov #nil,a2 ; (cons a1 nil) -> a1. ; ***** (CONS E1 E2) [SUBR 2] ; ----- entry cons cons:: tst free ; (cons a1 a2) -> a1. bne cons1 ; ya-t-il des doublets libres ? call garb ; non ; liste libre chainee par les CDRs. ; FREE et les CDR de doublets libres ; contiennent des adresses de CDR de doublets. cons1: jfnum a2,1$ push a2 ; coller le nombre coupable dans la pile. mov #ernbcd,a1 jmp errmp 1$: mov (free),a4 ; oui mov a2,(free) mov a1,-(free) mov free,a1 mov a4,free return ernbcd: .asciz /* Number in CDR :/ .even .page ; ----- garbage collecteur garb:: push a1 ; a1, a2, a3 : registres garbageables. push a2 push a3 inc ngc ; encore un garbage collecting ... inc igc ; nous sommes dans le GC. ; ----- balayage marquant de pile mov #bstak,a2 ; mark ne doit PAS toucher a a2. 1$: ; on attaque la pile PAR LE BAS (+ rapide). mov (a2),a1 call mark tst -(a2) cmp a2,p bhis 1$ ; ----- balayage marquant zone atomes: CVAL, PVAL, FVAL mov hdato,a2 asweep: mov (a2)+,a1 call mark mov (a2)+,a1 call mark mov (a2)+,a1 call mark ; a2 pointe sur ftyp/ptyp. tst (a2)+ ; pour que a2 pointe sur le pointeur-next. mov (a2),a2 ; attraper le prochain atome. bne asweep ; si non loop loop loop. .page ; ----- balayage recuperateur de zone liste mov hlist,a5 tst (a5)+ ; a5 = hlist + 2. mov #blist+2,a2 clr free clr a3 ; a3 compteur de doublets libres. 1$: mov (a2),a4 ror a4 bcc 2$ ; marked bic #1,(a2) ; oui unmark it br 3$ 2$: mov free,(a2) ; non: chainer a liste libre. mov a2,free inc a3 ; incrementer compteur doublets libres. ;3$: cmp (a2)+,(a2)+ ; attraper le doublet suivant. 3$: add #4,a2 ; [PM] above cheating doesnt work under TSX cmp a2,a5 ; apres le dernier ? blos 1$ ; si non loop loop loop. mov a3,ndl ; ranger nomb-doub-lib en memoire. ; ya-t-il des doublets libres ? bne nsweep ; si oui, on se paye les nombres. ; ----- desastre: yen a plus !!! jmp erfm ; ----- balayage recuperateur de zone nombres. nsweep: mov #bnum+npage,a2 ; 1ere page : petits negatifs [-1:-15]. clr a3 ; pointeur provisoire de nombres libres. clr a1 ; compteur de nombres libres. br 4$ 1$: mov (a2),a4 ; a4 = mark-mot : 1 marque, 0 non-marque. clr (a2)+ ; raz mark-mot. ; a2=adr type-mot (or first number if fis=0) mov #15.,a5 ; preparer boucle. (15 numbers per page) .iif ne,fis cmp (a2)+,(a2)+ ; [PM] se positionner sur un CDR de nombre. 2$: asl a4 ; on decale le mark-mot de la page courante. bcs 3$ ; si marque on ne fait rien. mov a3,(a2) ; cas non-marque : chainer. mov a2,a3 inc a1 ; R.A.J. compteur de nombres-libres. .page 3$: ; ......... .if ne,fis ; [PM] cmp (a2)+,(a2)+ ; se positionner sur un CDR de nombre. sob a5,2$ ; si non fin de page, boucler. tst -(a2) ; yes. se recaler sur le mark-mot page suivante. .endc ; [PM] ; ......... ; ......... .if eq,fis ; [PM] tst (a2)+ ; [PM] advance to next number sob a5,2$ ; si non fin de page, boucler. .endc ; [PM] ; ......... 4$: cmp a2,#hnum ; est-on encore dans la zone nombres ? blos 1$ ; oui. mov a3,freenb ; VRAI pointeur de nombres libres. mov a1,nnl ; nombre de nombres libres. bne 5$ ; si yen a. ; ----- desastre: ya plus de nombres !!! jmp erfn ; ----- a present, voyons un peu ou nous en sommes. 5$: jtnil gcspk,6$ call gc1 6$: pop a3 ; restituer les registres garbageables. pop a2 pop a1 dec igc ; on sort du GC. return ; ****** MARK ET GC. ; ----- routine de marquage de l'objet dans a1 ; ne PAS toucher a a2. ; Peut-etre ici : verifier que a1 ne contient pas ; une adresse de CDR. mark1: ; %%%%%% provisoire : en attendant de trouver le bug inevitable. ; [PM] mov a1,a3 ; [PM] sub #blist,a3 ; a3 doit etre un multiple de 4. ; [PM] bit #3,a3 ; [PM] beq mark11 ; ok. ; [PM] mov #ovnil,a1 ; [PM] marke: push a2 ; [PM] call outs ; [PM] pop a2 ; [PM] return ; [PM] ovnil: .asciz / ... OVNI L .../ ; [PM] ovnin: .asciz / ... OVNI N .../ ; [PM] .even ; [PM] mark11: ; [PM] the above lines did not seem neccessary ? mov (a1)+,a3 ; car a1 -> a3 mov (a1),a4 ; cdr a1 -> a4 ror a4 ; rotate bcs mark2 ; marked ? si oui bye. ckstk push (a1) ; non sauver le cdr. bis #1,(a1) ; marquer le cdr. bit poids faible. mov a3,a1 ; car intact dans a1 call mark ; marquer le sous-arbre gauche. pop a1 ; restituer le sous-arbre droit. .page ; ----- entry mark mark: cmp a1,hlist bhi mark2 ; si plus haut que liste bye. cmp a1,#blist bhis mark1 ; si c'est dans l'espace liste, marquer. cmp a1,#bnum blo mark2 ; si c'est plus bas que nombres-box bye. cmp a1,#hnum bhi mark2 ; si c'est plus haut que nombres-box bye. ; c'est un nombre en boite. le marquer. ; %%%%%% provisoire : en attendant de trouver le bug inevitable. ; [PM] bit #npage/16. - 1,a1 ; a1 multiple de 2 or 4 ? ; une adresse de nombres DOIT etre multiple de 2 or 4 ; [PM] beq mark12 ; ok. ; [PM] mov #ovnin,a1 ; [PM] br marke ; [PM] ; [PM] mark12: ; [PM] the above lines did not seem neccesary ? call mrkmsk ; a4 = adresse mark-mot, a5 = masque. bis a5,(a4) ; setter le bit idoine du mark-mot. mark2: return ; sinon rentrer tout de suite. .page ; ***** (GC [T]) [SUBR 1] gc:: clr a3 ; a2 contient le nom de la fonction. a3 seul ... call garb ; lancer le g.c. ; garb preserve a1. mov a1,gcspk jtnil a1,gc2 ; nil ? gc1: push opti ; sauver status print. bis #1,opti ; forcer bit 0 = 1 : pas d'espaces. mov #spkm6,a1 ; nb de g.c. depuis debut de session. call prstr mov ngc,a1 call gc3 ; [PM] mov #spkm4,a1 ; place restante en atomes en mots. call prstr mov #blist,a1 sub catoc,a1 asr a1 ; on divise par 2 pour taille en mots. call gc3 ; [PM] mov #spkm5,a1 ; nb de doublets libres. call prstr mov ndl,a1 call gc3 ; [PM] mov #spkm0,a1 ; nb de grands nombres libres. call prstr mov nnl,a1 call gc3 ; [PM] call pcrlf pop opti ; restituer le status print. gc2: mov ndl,a1 ; oui. ramener le nb de doublets libres. br cranb ; [PM] et bye. gc3: call cranb ; [PM] jmp probj ; [PM] spkm0: .asciz / Numbers=/ .even spkm4: .asciz / Atoms=/ .even spkm5: .asciz / Lists=/ .even spkm6: .asciz /### Nb.GC=/ .even ; ****** creation et valeurs de nombres. ; ----- cran: creation de nombre, valeur binaire dans a1. ; ramene dans a1 l'adresse du nombre created. ; %%%%%% a revoir lors de l'implementation des flottants. cran: tst a1 bge cran1 cmp #-15,a1 ; est-ce un "petit negatif" ? bgt cran1 ; non. mov a1,a4 ; oui. une cuillere pour Wertz. neg a1 ; une cuillere pour Perolat. asl a1 ; une cuillere pour Mathieu. ; ......... .if ne,fis ; [PM] asl a1 ; une cuillere pour les adresses d'octets. add #bnum,a1 ; une cuillere pour les chers zenfants. mov a4,(a1) ; et s'envolent les reves ... br mrkmsk ; [PM] ciel ... d'un VLISP orthogonal ... .endc ; [PM] ; ......... .if eq,fis ; [PM] add #bnum,a1 ; [PM] mov a4,(a1) ; [PM] return ; [PM] .endc ; [PM] ; ......... cran1: .iif ne,fis mov a2,savnb2 ; [PM] on sauve la 2d mot du flottant. tst freenb ; reste-t-il des nombres libres ? bne 1$ ; oui. mov a1,savnb ; pour ne pas laisser adresse, potentielle de CDR dans la pile. clr a1 ; pour gc. clr a2 ; pour gc. clr a3 ; pour gc. call garb ; garbager. mov savnb,a1 ; recuperer. 1$: mov freenb,a2 ; oui : creer nombre. mov (a2),freenb ; remise a jour pointeur de nombres-libres. ; ......... .if ne,fis ; [PM] mov savnb2,(a2) ; coller dans cdr : 2de partie flottant. mov a1,-(a2) mov a2,a1 ; ramener l'adresse du nombre dans a1. br mrkmsk ; a4 = adresse du mark-mot, a5 = masque. ; donc acces au type-mot par 2(a4). .endc ; [PM] ; ......... .if eq,fis ; [PM] mov a1,(a2) ; [PM] mov a2,a1 ; [PM] return the address of number in a1 return ; [PM] .endc ; [PM] ; ......... .page ; ----- cranb : creation d'entiers. ; prend dans a1 la valeur binaire du nombre (16 bits) a creer. cranb1: bvc cranb ; [PM] check for overflow erovf2: jmp erovfl ; [PM] integer overflow cranb:: tst a1 ; si negatif : en boite. ; ......... .if eq,fis ; [PM] blt cran ; [PM] if negative - box it cmp a1,#bnum ; [PM] bhis cran ; [PM] if to big - box it return ; [PM] dont need to box it .endc ; [PM] ; ......... ; ......... .if ne,fis ; [PM] blt 1$ cmp a1,#bnum ; est-ce un inum ? blo 2$ ; oui. 1$: clr a2 ; 0 dans 2d mot si entier. call cran bic a5,2(a4) ; bit.type-mot = 0 : entier. 2$: return ; ----- cranf : creation de flottants. ; prends dans a1-a2 la valeur binaire du flottant a creer. ; les temps sont venus ... cranf:: call cran1 ; pour eviter des tests genants. bis a5,2(a4) ; bit = 1 : flottant. return .endc ; [PM] ; ......... ; ----- valnb : ramene la valeur binaire d'un nombre dans a1, ; etant donnee son adresse dans a1. ; ----- valnb2 : ramene dans a1 et a4 les valeurs binaires des ; nombres dont l'adresse est dans a1 et a2. ; dans a4, pour eviter d'avoir des adresses de ; CDR dans le registre garbageable a2. valnb2:: mov a2,a4 cmp a4,#bnum blo valnb mov (a4),a4 valnb:: cmp a1,#bnum blo 1$ mov (a1),a1 1$: return ; ****** marquage des nombres, bits-tables et freres. ; ; - PRINCIPES - [PM]: the following is true if fis=1 (i.e. floating point allowed) ; ; Zone nombre calee sur une adresse absolue multiple de 64(10). ; i.e. xxxx00(8) ; 1 nombre en boite (entier ou flottant) tient sur 2 mots consecutifs. ; ; Zone nombre constituee de "pages" de 32 mots. ; 32 mots = en-tete de 2 mots + 15 nombres de 2 mots chacuns. ; Adresse de nombre : multiple de 4 i.e. bbbbbbbbbbbbbb00. ; ; L'en-tete se compose d'un "mark-mot" et d'un "type-mot". ; ; 1 mark-mot est la bit-table locale de la page (bits 0:14) ; 1 type-mot indique pour le nombre correspondant : ; 0 = entier, 1 = flottant. ; -------- ; mark-mot 0 1 mot (bits 0:14) ; type-mot 2 1 mot (bits 0:14) ; -------- ; nombre.1 4 2 mots ; nombre.2 8 2 mots ; ; ... ... ... ; ; nombre.14 56 2 mots ; nombre.15 60 2 mots ; --------- ; mark-mot 64 1 mot ; etc ; ; Pour le balayage du G.C. : progresser, et tous les 15 nombres, ; remettre le mark-mot a zero. ; ; positionner BNUM sur une adresse absolue multiple de 64(10). ; positionner HUM sur BNUM + taille - 4. ; avec taille = 64(10)k, k = nombres de pages de 15 nombres. ; ; exemple : 450 nombres = 30 pages de 32 mots (15 nombres par page). ; taille = 30*32 = 960 mots. ; ; La constante NPAGNB contient le nombre de pages. ; La taille de la zone a reserver a l'assemblage est donc (en mots) : ; NPAGNB*32(10) + offset de positionnement de 32(10). ; ; [PM] If fis=0 (integers only) then the following scheem is used: ; The zone of numbers is positioned at an abloslute address that is that is a ; multiple of 32. Each number page is 16 words long. The first word is the ; mark word in which bits 0 - 14 are used by the garbage collector to mark ; the 15 numbers in the rest of the page. HNUM is positioned at: ; BNUM + taille -2 where taille = 32k, k=# of pages of 15 numbers each. ; example: 450 numbers = 30 pages of 16 words (15 numbers/page), taille=30*16=480 words .page ; ---- mrkmsk ; prend une adresse de nombre dans a1. ; ramene dans a4 : adresse de mark-mot correspondant. ; dans a5 : adresse de masque correspondant. ; adresse mark-mot = a1 AND -npage (177700 or 177740) ; adresse de masque = (a1 ASR) AND 37(8) -> [2, 4, ... , 30] mrkmsk:: mov a1,a4 bic #npage-1,a4 ; adresse du mark-mot multiple de 32 or 64. mov a1,a5 .iif ne,fis asr a5 ; [PM] bic #177740,a5 ; adresse de masque. mov tabmsk-2(a5),a5 ; masque dans a5 return ; tables des 15 masques du G.C. nombres. tabmsk: .word 100000,040000,020000,010000 .word 004000,002000,001000,000400 .word 000200,000100,000040,000020 .word 000010,000004,000002 ; ****** multiplication et division: mult, dvd ; ----- multiplication (16 bits) de a1 et a2 dans a4. [PM - signed multiply] ; bonne vieille multiplication russe. .if ne,eis ; [PM] mult: mul a2,a1 ; [PM] bcs erovf2 ; [PM] mov a2,a4 ; [PM] return ; [PM] .endc ; [PM] .if eq,eis ; [PM] mult: clr a3 ; [PM] clear sign tst a1 ; [PM] is 1st argument positive? bge 1$ ; [PM] jump if yes com a3 ; [PM] compliment sign neg a1 ; [PM] make 1st arguement positive 1$: tst a2 ; [PM] is 2nd argument positive? bge 2$ ; [PM] jump if yes com a3 ; [PM] compliment sign neg a2 ; [PM] make 2nd argument positive 2$: clr a4 br 5$ 3$: bcc 4$ add a2,a4 ; si bit a 1: ajouter une dose de a2. bvs erovf2 ; [PM] 4$: asl a2 ; doubler. bvs erovf2 ; [PM] clc ; raz carry. 5$: ror a1 ; div a1 par 2 et test du low bit. bne 3$ ; ya + rien. bcc 6$ add a2,a4 ; der coup necessaire si low bit etait 1. bvs erovf2 ; [PM] 6$: clr a2 ; pour gc. tst a3 ; [PM] is the sign positive beq 7$ ; [PM] jump if yes neg a4 ; [PM] negate the product 7$: return .endc ; [PM] .page ; ***** (MUL32 A B) [SUBR 2] ----- written by [PM] ----- ; ; an unsigned integer multiply of A and B, returns the list (LSW MSW) ; where LSW is an integer containing the least significant 16 bits ; and MSW is an integer containg the most significant 16 bits of result mul32:: call valnb2 ; val a1 -> a1, val a2 -> a4. call mlt32 ; do the multiply mov a5,tem0 ; save LSW call cranb ; create number for MSW consl a1,#nil,-(p) ; push (MSW . nil) onto stack mov tem0,a1 ; get LSW call cranb ; create number for LSW consl a1,(p)+,a1 ; a1 = (LSW . (MSW . nil)) return ; bye ; ----- [PM] multiplication of the 2 unsigned 16 bit integers in a1 & a4. ; returns a 32 bit unsigned product in a1,a5 (a1=MSW) .if eq,eis ; [PM] mlt32: mov a1,a2 ; car: a3-a2 * a4 -> a1-a5. clr a1 clr a5 clr a3 br 3$ 1$: add a2,a5 ; addition 32 bits a3-a2 + a1-a5. adc a1 add a3,a1 2$: asl a2 ; a3-a2 <- a3-a2 * 2. rol a3 3$: clc ; razer carry. ror a4 ; a4 <- a4 / 2 bcs 1$ ; si old a2 impair. bne 2$ ; encore ? return ; [PM] .endc ; [PM] .if ne,eis ; this section is by [PM] mlt32: mov a1,a3 ; save multiplicand mul a4,a1 ; do signed multiply, result in tst a3 ; now do fix up to produce unsigned result bge 1$ ; branch if multiplicand was positive add a4,a1 ; fix up most significant word 1$: tst a4 bge 2$ ; branch if multiplier was positive add a3,a1 ; fix up most significant word 2$: mov a2,a5 ; leave 32 bit result in return .endc .page ; ----- division de a1 et a2, entier non-negatifs. ; reste dans a1, quotient dans a3. ; bonne vieille division russe chevelue. dvd:: mov a1,a5 ; a1-a5 : dividende high-low. clr a1 dvd1:: ; used by tolpv et par SCALE. .if eq,eis ; [PM] clr a3 mov #15.,a4 ; [PM] 1$: asl a3 rol a5 rol a1 cmp a2,a1 bgt 2$ sub a2,a1 inc a3 2$: dec a4 bge 1$ .endc ; [PM] .if ne,eis ; [PM] mov a2,a3 ; [PM] mov a5,a2 ; [PM] div a3,a1 ; [PM] a1=quotient, a2=remainder mov a1,a3 ; [PM] a3=quotient mov a2,a1 ; [PM] a1=remainder .endc ; [PM] clr a2 ; pour gc. return .page ; ***** (SCALE A B C) [SUBR 3] ; (A * B) / C ; multiplication 16 * 16 -> 32 ; division 32 * 16 -> 16 ; [PM] eliminated handling of the remainder scale:: call valnb2 ; val a1 -> a1, val a2 -> a4. .if eq,eis ; [PM] clr sign tst a1 bge 1$ neg a1 com sign 1$: tst a4 bge 2$ neg a4 com sign 2$: push a3 ; sauver C. call mlt32 ; [PM] do multiplication pop a2 ; restituer C. cmp a2,#bnum ; extraire la valeur. blo 3$ mov (a2),a2 3$: tst a2 bge 4$ com sign neg a2 4$: call dvd1 ; quotient dans a3, reste dans a1. mov a3,a1 ; [PM] a1 = unsigned quotient jmp quo2 ; [PM] go put the sign onto the quotient .endc ; [PM] .if ne,eis ; [PM] mul a4,a1 ; [PM] 32 bit product in (r0,r1) or (a1,a2) cmp a3,#bnum ; [PM] is the divisor a boxed number? blo 3$ ; [PM] jump if not mov (a3),a1 ; [PM] get the binary value of the divisor 3$: div a3,a1 ; [PM] (a1,a2) / a3 jmp cranb ; [PM] make it a number .endc ; [PM] .end ; ****** END OF VL6 ******