.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 ******