..DCOD=$0100 ..FCOD=$02FF ..DSTK=$0300 ..FSTK=$12FF ..DINT=$1300 ..FINT=$57FF ;..FINT=$3FFF ..DATO=$5800 ;..DATO=$4000 ..FATO=$7FFF ;..FATO=$6FFF ..DLST=$8000 ;..DLST=$7000 ..FLST=$FEFF ;..FLST=$D3FF .PAGE .SBTTL; Memoires de travail de l'interprete ;===== zone des buffers systeme ===== .IFNE TRSDOS BUF.IN=$6000 ; buffer systeme entree 256 bytes BUF.OU=$6100 ; buffer systeme sortie 256 bytes .ENDC ; TRSDOS .IFNE TRSDS2 BUF.IN=$7000 ; buffer systeme entree 256 bytes BUF.OU=$7100 ; buffer systeme sortie 256 bytes .ENDC ; de TRSDS2 ;===== zone de la pile =====; ; Cette zone contient a son debut : ; - la ligne de sortie (OUBUF) ; - la ligne d'entree (INBUF) ; - la ligne de sortie sur fichier (BUFOU) ; - les FCBs d'entree et de sortie ; qui fait office de 'tolerance pile' .=..DSTK ; description des lignes BUFOU: .BLKB $100 ; ligne de sortie Le_Lisp (256 octet) INBUF: .BLKB $80 ; ligne d'entree Le-Lisp OUBUF: .BLKB $80 ; ligne d'edition ; description du fichier d'entree (FCB.IN) .IFNE ISIS FCB.IN: ; BLOCK DE CONTROLE DISK IN .BLKB 2 ; DW 1 POUR :CI: .BLKB 2 ; DW INBUF .BLKB 2 ; DW 80 .BLKB 2 ; DW DATL .BLKB 2 ; DW DSTAT DACTL: .BLKB 2 ; ACTUAL COUNT. DSTAT: .BLKB 2 ; COMPTE RENDU. DIAFT: .BLKB 2 ; AFT DE DISKIN. .ENDC ; TRSDOS .IFNE TRSDOS FCB.IN=$6200 ; DCB d'entree TRSDOS .ENDC ; TRSDOS .IFNE CPM FCB.IN: .BLKB 36 ; FCB d'entree complet .ENDC .IFNE TRSDS2 FCB.IN=$7200 ; DCB (60 bytes) FPL.IN=FCB.IN+60 ; Parameter List (11 bytes) .ENDC ; de TRSDS2 ; description du fichier de sortie .IFNE ISIS FCB.OU: ; BLOCK DE CONTROLE DISKOUT .BLKB 2 ; AFTN DISK OUT .BLKB 2 ; DW BUFOUT (ADRESSE) .BLKB 2 ; DW COUNT (VALEUR) .BLKB 2 ; DW DSTAT (adresse). DOAFT: .BLKB 2 ; AFTN DE DISK OUT. .ENDC ; ISIS .IFNE TRSDOS FCB.OU=$6300 ; DCB de sortie TRSDOS .ENDC ; TRSDOS .IFNE CPM FCB.OU: .BLKB 33 ; FCB en sortie complet .BLKB 60 ; la vraie tolerance pile .ENDC ; CPM .IFNE TRSDS2 FCB.OU=$7300 ; DCB (60 bytes) FPL.OU=FCB.OU+60 ; FPL (11 bytes) .ENDC ; de TRSDS2 ; Fin de la tolerance pile HSTAK=. ^ .=..FSTK BSTAK= . + 1 ; DEBUT DE PILE. ;===== Zone ecran pour l'editeur video =====; .IFNE EDIT .=..DECR ECRAN=. HGECR=<..FECR + 1> ^ ; H max pour un ecran de N K .ENDC ; de EDIT .PAGE ;===== Zone des atomes litteraux =====; .=..DATO HATOM=. ^ HNIL=. ^ .NIL=. * 256 & $FF00 ! HNIL NIL=. .BLKB $10 ; POUR SAUTER L'ATOME. ;--------------------------------------------------- ; Zone des memoires de travail de l'interprete ; Elles sont dans la page de l'atome NIL ;--------------------------------------------------- OSTACK: .BLKB 2 ; SP de l'OS appelant ;----- V L 1 BTRAV=. ; DEBUT ZONE DE TRAVAIL OUBPT: .BLKB 2 ; pointeur ligne de sortie IPPI: .BLKB 1 ; =0 normal, #ad0 .TP .TR a la place de .CI .CO OPPI: .BLKB 1 ; = 0 si .CO #0 si .TP .IFNE FILE IDSK: .BLKB 1 ; INDICATEUR DISQUE SI # DE 0. ODSK: .BLKB 1 ; indicateur de sortie disque si #0. .ENDC ; de FILE .IFNE K7 IK7: .BLKB 1 ; #0 INPUT K7 OK7: .BLKB 1 ; #0 OUTPUT K7 .ENDC ; DE K7 .PAGE ;----- V L 2 FREEL: .BLKB 2 ; POINTEUR LISTE LIBRE. FREES: .BLKB 2 ; taille de la liste libre a chaque GC. SPKI: .BLKB 1 ; SPEAK GC (0:OFF 1:ON) GCNBR: .BLKB 2 ; GC NUMBER. .IFNE EDITRS CURSYS=$4020 ; curseur video du systeme TRS LEVEL II IEDIT: .BLKB 1 ; INDICATEUR LECTURE MEM VIDEO EDIPT: .BLKB 2 ; POIN MEM VIDEO. CURS: .BLKB 2 ; curseur video de l'editeur. CD.COM: .BLKB 1 ; contient la derniere commande de recherche. CD.ARG: .BLKB 1 ; contient le dernier argument de cette commande. WINREC: .BLKB 2 ; debut recepteur fenetre courante WINSIZ: .BLKB 2 ; taille fenetre courante. .ENDC ; de EDITRS .PAGE ;----- V L 3 RINGR: .BLKB 1 ; 0 SI YA RIEN. CATOC: .BLKB 2 ; debut zone atome encore libre BUFAT: .BLKB 2 ; C-VAL STD (.UNDF). .BLKB 2 ; P-LIST STD (.NIL). .BLKB 2 ; F-VAL STD (0). .BLKB 2 ; F-TYP,,P-TYP CATOL: .BLKB 2 ; A_LINK contient en permanence le dernier atome MBUF: .BLKB 1 ; NB DE CARACT DU P-NAME. MBFMZ=62 ; taille max d'un atome litteral .BLKB MBFMZ ; P-NAME. ; Type des caracteres CLNUL=0 ; Caract nulls a enlever CLSHL=1 ; Quote caractere (/) CLBCM=2 ; Debut commentaires ( ;) CLECM=3 ; Fin commentaires ('return') CLSEP=4 ; Separateurs (esp tab lf ... ) CLMAC=5 ; Macro-caracters (' et utilisateurs) CLSTR=6 ; Pseudo-chaines de caracteres (") CLHEX=7 ; Specificateur de nb hexa (#) CLNOR=8 ; Normal pour un P-name. CLDOT=9 ; . CLLRE=10 ; ( CLRPR=11 ; ) CLMNS=12 ; mono-symbole CCDEC=4 ; nb de DCR effectues par ; GETCH et GETCH sur TYPCH CCSTR=CLSTR-CCDEC CCNOR=CLNOR-CCDEC CCDOT=CLDOT-CCDEC .PAGE ;----- V L 4 BPTRA=. ; debut de la zone a reinitialisee en cas d'erreur RDCRD: .BLKB 1 ; READ profondeur courante ; (i.e. nb de "(" non fermees) INDENT: .BLKB 1 ; nombre d'espaces par "(" non fermees LBMIN: .BLKB 1 ; TAILLE DE LA MARGE GAUCHE (E.G. 1) LBMIX: .BLKB 1 ; taille max en entree LBMAX: .BLKB 1 ; taille max en sortie LBCIU: .BLKB 1 ; taille courante en entree LBCOU: .BLKB 1 ; taille courante en sortie (ce qu'il en est). XPLDI: .BLKB 1 ; INDIC EXPLODE=1,PRINT=0 XPLDL: .BLKB 2 ; dernier pointeur du EXPLODE. PRPMAX: .BLKB 1 ; profondeur max d'edition PRPCOU: .BLKB 1 ; profondeur restante PRLMAX: .BLKB 2 ; nombre max de lignes a editer PRLCOU: .BLKB 2 ; nombre restant PREMAX: .BLKB 2 ; nombre max d'elements a editer PRECOU: .BLKB 2 ; nombre restant PROMPT: .BLKB 2 ; prompt du READ ;----- V L 5 .IFNE ITEVAL ITVLP: .BLKB 1 ; indicateur de masque d'interruption dans EVAL .ENDC ; de ITEVAL TREVP: .BLKB 1 ; indicateur de traceval IPTI: .BLKB 1 ; indicateur de conversion des minuscules en entree OPTI: .BLKB 1 ; indicateur d'impression des quotes en sortie IMPLP: .BLKB 1 ; indicateur d'IMPLODE IBASE: .BLKB 1 ; INDICATEUR DE BASE DE SORTIE DES NOMBRES ; contient la base, entre 2 et 32 EPTRA=. ; fin de la zone a reinitialise'e en cas d'erreur .PAGE ;----- V L 6 FORM: .BLKB 2 ; pour les macros, et la fonction lambda LPARAM: .BLKB 2 ; PARAMETRES D'UNE FONCTION VESCA: .BLKB 2 ; VALEUR D'UN TAG A4: .BLKB 2 ; POUR SUBST QUI A 5 ARGUMENTS ;----- V L 7 SIGN: .BLKB 1 ; CALCUL du SIGNE EEXNC: .BLKB 1 ; INDICATEUR LIAISON EN UN TEMPS ;----- V L 8 MAPIN: .BLKB 2 ; parametre des MAP RDLAMB: .BLKB 2 ; RETOUR DES LIAISONS DLAMBDA PBIND: .BLKB 2 ; LIAISON DES BLOCS DE CONTROLE ENBLO: .BLKB 2 ; POUR LE TEST DE TAIL-REC SENBLO: .BLKB 2 ; sortie rapide du print ;----- V L 9 ; cette zone est marquee par le garbage collector SELFM: .BLKB 2 ; LA FONCTION EN COURS POUR SELF FONCT: .BLKB 2 ; fonction a evaluer. FNTEV: .BLKB 2 ; FONCTION A APPLIQUER ET ARGS DLAMBDA AL: .BLKB 2 ; A-LISTE DES DLAMBDA ETRAV=. ; FIN DONNEES DANS NIL ; test de la taille de la zone de travail RAM Z= - ETRAV .IF L Z .ERROR Z ; zone travail RAM trop grande .END ; tout est fini! .ENDC .PAGE ;----- ;----- SUITE DES OBJETS LISP (SANS NIL) ;----- DEBUT ZONE TRANSFERT INIT ;----- .=<<. + $100> & $FF00> - 64 - 8 ; ! cette formule se retrouve en IMEMS= ... BATOM=. FINPI: .BLKB 5 ; IN X, JMP CRANA FOUTI: .BLKB 3 ; OUT X, RET. TABCH: .BLKB 64 ; TABLE DES CARACTERES. HUNDF=. ^ .UNDF=. * 256 & $FF00 ! HUNDF UNDEF=. ;===== ZONE LISTE =====; .=..DLST HLIST=. ^ BLIST=. ;===== FIN ZONE LISTE =====; .=..FLST HELST=..FLST ^ .PAGE .SBTTL; Debut de l'interprete (zone a emplacement fixe) ; ---- DEBUT de L'INTERPRETE ; doit etre sur une frontiere de H (tables a adresses fixes) .IFNE CPM .=$100 JMP START .ENDC .=..DINT ;***** Debut de la memoire code qui peut etre en ROM CODEB=. ; Le code doit partir sur une frontiere de H (cf: EVAL) EVALT: .ADDR EVUN ; 0 NIE WIEM. .ADDR POPJ ; 2 0SUBR .ADDR EV1A ; 4 1SUBR .ADDR EV2A ; 6 2SUBR .ADDR EV3A ; 8 3SUBR .ADDR EVNA ; 10 NSUBR .ADDR XPOPJ ; 12 FSUBR .ADDR EVEXP ; 14 EXPR .ADDR EVFEX ; 16 FEXPR .ADDR EVMAC ; 18 MACRO .ADDR EVNM ; 20 NSUBR ASSOCIATIVE .ADDR EV1V ; 22 VARIABLES-FONCTIONS 1 .ADDR EV2V ; 24 VARIABLES-FONCTIONS 2 .PAGE ;----- ADRESSE DE START .=..DINT + $20 ; adresse du START JMP START JMP REENM CI: JMP .CI ; entree console. CS: JMP .CS ; test console. CO: JMP .CO ; sortie console. TR: JMP .TR ; entree perfo. TP: JMP .TP ; sortie perfo. .IFNE EDIT JMP EDF ; pour tester l'editeur seul .ENDC ; de EDIT .IFNE DDT JMP DBUG ; pour les tests TRS .ENDC ; de DDT ;?!?!?!?! ; le nouveau code pour le 8086 ;?!?!?!?!? BDOS: INT 224 ; it soft de CP/M86 RET .SBTTL; Depart de l'interprete ;***** ;***** DEPART A FROID DE L'INTERPRETE ;***** START: ; sauve le pointeur de pile de l'appel LXI H,0 ; ya pas d'autre moyen DAD SP ; sur 8080! SHLD OSTACK ; et on le sauve LXI SP,BSTAK ; pile Le_Lisp ; init tampon de sortie CALL RAZBUF ; init tampon d'entree CALL ZARBUF ; init zone trav. RAM (avec des 0 toujours!) LXI H,BTRAV ; DEBUT ZONE MVI B,ETRAV-BTRAV ; TAILLE ONE CALL RAZ0 ; ca remt tout a zero ; init FREEL et freelist. .IFNE CPM ; [jer] CALL ADJST0 ; calcule la taille .ENDC ; de CPM LXI B,NIL ; A METTRE EN CAR. LXI H,BLIST ; C'EST PARTI. SHLD FREEL ; c'est le premier STR1: MOV M,B INR L MOV M,C INR L ; FORCE CDR MOV D,H ; prend le doublet courant MOV E,L ; voila INR E INX D ; passe au suivant MOV M,D INR L MOV M,E INX H ; ACHTUNG! FRONTIERE. MOV A,H ; C'EST FINI. CPI HELST ADROV1=. - 1 JC STR1 XRA A ; il fallait mettre le dernier a zero DCX H ; sur le CDR du precedent MOV M,A DCX H MOV M,A ; voila ; autres init des RAMs LXI H,.UNDF ; le buffer atome SHLD BUFAT ; C-VAL STD. LXI H,.NIL SHLD BUFAT+2 ; P-LIST STD. LXI H,EATOM SHLD CATOC LXI H,LATOM SHLD CATOL ; DERNIER LINK. ; transfert des zones ROM vers les zones RAM ! ; 1) l'atome NIL lui-meme .IFNE ROM LXI H,ZBNIL ; DEBUT ATOME NIL LXI D,NIL ; VRAI ADRESSE DE L'ATOME NIL .IFNE ZILOG LXI B,ZENIL-ZBNIL ; TAILLE TRANSF LDIR ; on balance le tout. .IFF ; ZILOG MVI B,ZENIL-ZBNIL ; TAILLE TRANSERT STAR3: MOV A,M ; RECUP E EMETTRICE STAX D ; RANGE EN RECEPT. INX H ; AVANCE EN EMET INX D ; AVANCE EN RECEP DCR B ; ENCORE ? JNZ STAR3 ; OUAIP. .ENDC ; ZILOG .IFF ; ROM ; rien a faire car ZBNIL=NIL .ENDC ; ROM ; 2) les constantes litterales .IFNE ROM LXI H,IMEMS ; DEBUT SOURCE LXI D,BATOM ; DEBUT RECEPT .IFNE ZILOG LXI B,IMEM1-IMEMS ; taille zone litterale LDIR ; on transfert .IFF ; ZILOG STAR4: MOV A,H CPI IMEM1 ^ JNZ STAR5 MOV A,L CPI IMEM1 & $FF JZ STAR6 ; C'EST DONC FINI. STAR5: MOV A,M STAX D INX H INX D JMP STAR4 .ENDC ; ZILOG .IFF ; ROM ; rien a faire car IMEMS=BATOM .ENDC ; ROM ; 3) les autres atomes STAR6: .IFNE ROM LXI H,IMEM1 ; DEBUT 2EME ZONE LXI D,BATO1 ; DEBUT 2EME ZONE RECEP .IFNE ZILOG LXI B,IMEME-IMEM1 ; taille transfert LDIR ; on transfert .IFF ; ZILOG STAR7: MOV A,H CPI IMEME ^ JNZ STAR8 ; CONTINUE MOV A,L CPI IMEME & $FF JZ STAR9 ; FIN TRANSFERT STAR8: MOV A,M STAX D INX H INX D JMP STAR7 STAR9: NOP .ENDC ; ZILOG .IFF ; ROM ; rien a faire car IMEM1=BATO1 .ENDC ; ROM .PAGE ;---------- ; Initialisations speciales (conditionnelles) ;---------- .IFNE EDITRS ; r a z la sauvegarde de l'ecran. LXI H,ECRAN MVI M,' ' LXI D,ECRAN+1 LXI B,1023 LDIR ;;; init le systeme de fenetrage. MVI L,2 ; suppose (WINDOW 2) au debut CALL WIND ; on la positionne. LXI H,$3C00 ; la 1ere ligne LE LISP sera quand meme SHLD CURSYS ; ecrite en haut : donc elle restera! .ENDC ; de EDITRS .IFNE SOR MVI C,$0C ; pour effacer tout l'ecran CALL TYO ; et faire un home. MVI A,8 ; echo standard de l'ecran STA IPTI ; ca evite le (STATUS READ 8) initial .ENDC ; de SOR .IFNE TRS80+TRC80 DI ; masque l'horloge .ENDC ;;; INIT des RSTs .IFNE I1RST MVI A,$C3 ; code du JMP STA AD1RST ; fabrique le saut du RST LXI H,FUNCNS ; adresse de lancement du UNCONS SHLD AD1RST+1 ; termine le JMP AD1RST .ENDC ; de I1RST .IFNE I2RST MVI A,$C3 ; code du JMP STA AD2RST ; fabrique le saut du RST LXI H,ERRMS ; adresse de lancement de la routine d'erreura SHLD AD2RST+1 ; termine le JMP AD2RST .ENDC ; de I2RST .IFNE I3RST MVI A,$C3 ; code du JMP STA AD3RST ; fabrique le saut du RST LXI H,PCRLF ; adresse de lancement de PCRLF SHLD AD3RST+1 ; termine le JMP AD3RST .ENDC ; de I3RST ;;; PREPARE LE NMI OU LE RST 3 .IFNE MZ80 LXI H,$66 ; ADRESSE NON MASKABLE INTERRUPT MVI A,$C3 ; "JMP" MOV M,A INR L MVI M,REENI & $FF INR L MVI M,REENI ^ .ENDC ; MZ80 .IFNE MDS IN $FC ; LECTURE DU REG D'I ANI $F7 ; PERMET LES ITS DE NIVEAU 3 OUT $FC ; ECRIT LE NOUVEAU RG D'IT. LXI H,$18 ; ADR RST 3 MVI A,$C3 ; "JMP" MOV M,A INR L MVI M,REENI & $FF INR L MVI M,REENI ^ .ENDC ; MDS .IFNE TRSII LXI B,-1 ; 80 car/ligne mode normal MVI A,7 ; SVC VDINIT RST 1 ; RST 8 Zilog MVI A,3 ; BREAK fonction LXI H,0 ; recupere l'ancienne adresse RST 1 ; disable ! MVI A,3 ; BREAK fonction LXI H,REENM ; reent avec message RST 1 ; RST 8 Zilog .ENDC ; de TRSII .IFNE LAP LXI H,..DCOD; fabrique :BCODE CALL FADRES LXI D,.BCOD CALL ASETX ; setq LXI H,..FCOD CALL FADRES LXI D,.ECOD CALL ASETX ; setq .ENDC ; de LAP .PAGE CALL OUTSS ; On sort la 1ere partie du header. .ASCII '**** Le_Lisp 80 (de l' .BYTE $27 .ASCII 'INRIA) 31/Mai/83 ' VERSNB=12 ; le numero de la version (VERSION) .IFNE MDS32 .ASCII 'MDS 32k' .ENDC .IFNE MDS64 .ASCII 'MDS 64k' .ENDC .IFNE MZ80 .ASCII 'MZ80' .ENDC .IFNE TRS80 .ASCII 'TRS80 (8K PROM)' .ENDC .IFNE TRC80 .ASCII 'TRS 80 (K7)' .ENDC .IFNE TRE80 .ASCII 'TRS 80, 32K RAM (TRSDOS)' .ENDC .IFNE TRD80 .ASCII 'TRS 80, 48K RAM (TRSDOS)' .ENDC .IFNE SDK80 .ASCII 'systeme J.P. MOULIN' .ENDC .IFNE SOR80 .ASCII 'Sorcerer (K7)' .ENDC .IFNE SOM80 .ASCII 'Sorcerer (CP/M)' .ENDC .IFNE IMSAI .ASCII 'IMSAI 8080 (CP/M) "a la Rob"' .ENDC .IFNE TRSII .ASCII 'TRS model II, 48k RAM' .ENDC .IFNE H89CPM .ASCII 'H89 CP/M' .ENDC .IFNE Z89CPM .ASCII 'H89 CP/M' .ENDC .IFNE LEBLAN .ASCII 'Systeme special Philippe LEBLANC 48k' .ENDC .IFNE MICRAL .ASCII 'MICRAL CP/M ' .ENDC .IFNE SILZ .ASCII 'SILZ CP/M ' .ENDC .IFNE LOGAX .ASCII 'LOGABAX CP/M' .ENDC .BYTE $0D,$0A,0 ; et fin de message .IFNE FILE ; initialisation du fichier initial XRA A ; pas de mode disque STA IDSK ; en entree STA ODSK ; et en sortie LXI H,.VINI ; nom du fichier initial CALL DIOI ; et on l'ouvre .ENDC ; de FILE JMP REENT ; et on reentre. ;----- TOP-LEVEL SYSTEME ; le principal probleme est la capture des echappements. ; ceci est realise par la simulation d'un bloc verrou ; (DE REENT () ; (LOCK 'CB ; (WHILE T (TOPLEVEL)) ) ) ; que doit faire la fonction CB ? ; si c'est la fonction identite, l'erreur "echappement indefini" ; serait rattrapee mais pas signalee. ; mais le declenchement de cette erreur a lieu a l'exterieur du ; bloc verrou precedent. Il faut donc mettre un bloc verrou dans ; CB, avec CB elle-meme comme fonction de verouillage. ; (et c'est une recursivite terminale !) ; (DE CB (E V) ; (IF (EQ E 'SYSERROR) ; (REENT) ; (LOCK 'CB ; (SYSERROR 'EXIT "Echappement indefini" E) ) ) ) FVACB: POP D ; seul l'echappement nous interesse LXI B,ERUDT ; a priori c'est pas l'echappement standard MOV A,D CPI .SYSER ^ ; y avait eu une erreur ? JNZ SIMVR1 ; nan; c'est un echappement indefini MOV A,E ; rebelotte faible CPI .SYSER & $FF JNZ SIMVR1 ; et on construit le bloc ;;; REENT doit suivre .PAGE ;----- Le reenter REENT: LXI B,REENTV ; prepare le retour SIMVR1: LXI SP,BSTAK LXI H,.ATCB ; la fonction de verrouillage JMP SIMVER ; construit le bloc et execute ce qui suit REENTV: LXI H,BPTRA ; debut de la petite zone MVI B,< EPTRA - BPTRA > ; sa taille CALL RAZ0 ; on la remt a zero MVI A,10 STA IBASE ; init base de sortie MVI A,4 STA INDENT ; nombre d'espace par "(" pour prettyread .IFNE TRS MVI A,63 .IFF MVI A,76 .ENDC STA LBMAX ; TAILLE LIGNE COURANTE. MVI A,20 STA PRPMAX ; init profondeur. LXI H,100 ; init nombre de lignes SHLD PRLMAX LXI H,1000 ; init nombre d'elements SHLD PREMAX LXI H,.CHINT ; le prompt "?" SHLD PROMPT .IFNE FILE LDA IDSK ORA A ; NE PaS Y TOUCHER JNZ REEN0 ; SI C'EST UN DISQUE. .ENDC ; de FILE LXI H,INBUF ; init line editor MVI M,0 ; RAZ LE BUFFER. MOV A,L ; position courante STA LBMIX ; fin de l'entree REEN0: LXI H,$FFFF ; init SELF SHLD SELFM .IFNE COLOR CALL CLRIN ; INIT COLORIX .ENDC ; COLOR ;----- BOUCLE DU TOPLEVEL STANDARD REEN1: XRA A ; A <- 0. STA RDCRD ; RAZ LE BN DE ( POUR P.P. LXI H,.TOPL ; ADRESSE ATOME TOP-LEVEL CALL EVRPN ; APPEL (TOPLEVEL NIL) JMP REEN1 ; = (WHILE T (TOPLEVEL)) .PAGE ;----- NON MASQUABLE INTERRUPT = .REE (MZ80) ; OU RST 3 (MDS) REENI: LXI H,REENM PUSH H ; EMPILE REENM .IFNE MZ80 .BYTE $ED,$45 ; RETN ZILOG ! .ENDC .IFNE MDS DI ; ATTENTION : C'EST CRUCIAL. MVI A,$20 ; POUR REARMER LES ITS. OUT $FD EI ; REVALIDE. RET .ENDC REENM: .IFNE FILE LDA IDSK ORA A ; si un fichier disque est ouvert CNZ DIO0 ; on le ferme LDA ODSK ORA A ; idem en sortie CNZ DOO0 .ENDC ; de FILE .IFNE CPM .IFF CALL OUTSS .IFNE FRANZ .ASCII '**** Le_Lisp 80 : ca repart' .IFF .ASCII '**** Le_Lisp 80 : reenter' .ENDC .BYTE 0 CALL LMRGRI ; pret a lire JMP REENT ; ca ne suit plus maintenant! .ENDC ; de CPM .PAGE ;***** (TOPLEVEL) [SUBR 0] TOPLV: CALL READU ; (PRINT (EVAL (PRINT (READ)))) XCHG ; DE <- la forme lue LXI B,.READ ; pointe sur la c-val LXI H,.TOPL ; pointe sur la c-val MOV A,M ; precedente forme lue STAX B ; sauvee dans .READ MOV M,D ; forme en cours d'evaluation INR L ; aux poids faible INR C MOV A,M STAX B MOV M,E XCHG CALL EVAL XCHG ; DE <- resultat LXI H,.EVAL ; pointe sur la c-val de l'atome eval MOV M,D ; y met la valeur de l'evaluation INR L MOV M,E XCHG MVI B,'=' ; le prompt du toplevel TOPL3: PUSH H ; sauve la valeur CALL PRCHTS ; sort le prompt et un espace POP H ; la valeur JMP PRINI ; qu'on imprime .PAGE .SBTTL; Declenchement des erreurs ;***** (SYSERROR F M A) [3SUBR] ERRSTD: POP D ; MSG en clair POP B ; fonction PUSH H ; P:: BADARG] CALL TCVMS ; charge la c-val du message si besoin MSGD: PUSH D ; P:: BADARG MSG] PUSH B ; P:: BADARG MSG FCT] .IFNE FILE ; si le fichier de sortie est ouvert CALL DOO0 ; on le ferme .ENDC CALL COLEOL MVI B,'*' ; tres joli CALL PRCH2S ; deux fois, et avec un espace POP H ; FCT en clair CALL COLUMN ; on l'edite suivie de " : " POP H ; MSG en clair CALL COLUMN ; on l'edite suivie de " : " POP H ; BADARG en clair CALL PRINI ; on l'imprime et on passe a la ligne CALBR: LXI H,.BREAK ; appel de la fonction BREAK redefinissable JMP EVRPN ; PAS D'ARG, Donc pas besoin d'APPLY COLUMN: CALL PROBJ ; edite la forme CALL PRSPC ; un espace MVI B,':' JMP PRCHTS ; un deux-points et un espace .PAGE ;---- CALSR : appel de la fonction redefinissable SYSERROR ; au moyen de FUNCALL ; BC = la fonction ; DE = le message ; HL = l'argument incrimine CALSR: SHLD A4 ; fait de la place LXI H,POPJ ; pour empecher le traitement des rec_term PUSH H ; mais il vaudrait mieux "ERRBR" LXI H,$FFFF ; le marqueur PUSH H ; place LXI H,.SYSER ; la fonction SYSERROR PUSH H ; place PUSH B ; la fonction fautive PUSH D ; le message LXI H,8 ; pour pointer avant le marqueur DAD SP ; voila PUSH H ; place LHLD A4 ; recupere l'arg qui est le dernier JMP FUNCAL ; avec P :: ... $FFFFF SYSERROR FCT MSG pointe] ;----- FATAR : declenchement d'une erreur fatale ; HL = fonction ; DE = message ; y a pas d'arg FATAR: PUSH D ; sauve le message PUSH H ; sauve la fonction CALL EOL ; vide le buffer, sans appeler EOL POP H ; recupere la fonction CALL LCOPH ; sort la fonction sur la console MVI C,' ' ; sort un espace CALL COPHT2 MVI C,':' ; sort le deux-points CALL COPHT2 MVI C,' ' ; sort un espace CALL COPHT2 POP D ; recupere le message CALL TCVMS ; charge la c-val si besoin XCHG ; dans HL CALL LCOPH ; la sort CALL RETLF ; passe a la ligne ;;; ERRBR doit suivre ;***** (BREAK) [SUBR 0] ; la fonction d'arret de calcul: provoque un echappement en standard BREAK : ERRBR: LXI H,.SYSER ; charge l'atome SYSERROR ESCSTD: MOV B,H ; BC <- le nom de l'echappement MOV C,L LXI D,XPOPJ ; faut seulement retourner le nom apres JMP REXIX ; on l'active .PAGE ;----- TCVMS : teste si DE a un bon message en c-val TCVMS: XCHG ; HL <- message MOV D,M ; il faut prendre la c-val INR L MOV E,M DCR L ; au besoin JTNIL D,MSGH ; NIL est peu significatif MOV A,H ; [jer] JTNIL ne le fait pas! CPI HUNDF ; UNDEF encore moins RNZ ; c'est bon MOV A,E CPI UNDEF & $FF RNZ ; une constante, pourquoi pas MSGH: XCHG ; faut prendre l'arg de depart RET ;----- RIOMP : charge READ ou IMPLODE pour une erreur RIOMP: LXI B,.READ ; a priori c'est READ LDA IMPLP ; n'est-ce pas ? ORA A RZ ; oui LXI B,.IMPLD ; nan RET .PAGE .SBTTL; ERREURS FATALES ;----- ERFS : pile pleine ERFSE: LXI H,.EVAL ; ca vient d'EVAL JMP ERFS ERFSG: LXI H,.GC ; old error "requiescat in pace" ERFS: LXI D,.MSFS JMP FATAR ; 2 - 1000l$$1000t ERFSR: LXI D,.MSFS FRIOMP: CALL RIOMP ; charge READ ou IMPLODE MOV H,B ; dans HL MOV C,L JMP FATAR ;----- ERATO : zone atome pleine ERATO: LXI D,.MSATO JMP FRIOMP ;----- ERFM : zone liste pleine ERFM: LXI H,.GC LXI D,.MSFM JMP FATAR .PAGE .SBTTL; ERREURS NORMALES ;----- ERBST : secteur disque defectueux INDR: ; erreur de lecture disque CALL DIO0 ; ferme tout LXI B,.INPUT ; la fonction fautive JMP ERBST ; vers l'erreur "bad sector" ERDWR: XRA A ; remise a 0 STA ODSK ; de l'indic disque LXI B,.OUPUT ; la fonction fautive ERBST: LXI D,.MSBST ; le message LXI H,NIL ; il faudrait plutot ramener le nom du fichier JMP CALSR ; vers l'appel de SYSERROR ;----- ERPLC : l'argument doit etre une variable ;----- TPLST : TEST SI HL EST UN ATOME LITTERAL A P-LIST TPLST: JTLST H,ERPLC MOV A,H ; car JTLST ne le fait pas CPI HNIL+1 ; tout sauf NIL et les nombres RNC XCHG ; mieux que JMP ERPLCX: XCHG ERPLC: LXI D,.MSPLC ; charge le message JMP CALSR ; appel de SYSERROR ;----- ERARI : ERREUR DANS FONCTION ARITHMETIQUES TOVF: CALL RIOMP ; charge READ ou IMPLODE TOVFA: MOV A,H ; ON EN FAIT UN VRAI NB. ANI VNBM ; enleve les bits en trop MOV H,A ERDIV: LXI D,.MSARI ; le message JMP CALSR .PAGE ;----- ERUDT : echappement indefini ERUDT: LXI B,.EXIT ; nom de la fonction LXI D,.MSUDT JMP CALSR ;----- ERUDF : fonction indefinie ERMAP: LHLD FNTEV ; recupere la MAPxxx MOV B,H MOV C,L JMP ERUDFF SELFR: LXI B,.SELF ; l'atome SELF ERUDFF: LXI H,NIL ; pas de fonction JMP ERUDFL ; et vers l'impression du message ERBIND: LXI B,.BIND ; l'atome JMP ERUDFL ERAPP: LXI B,.APPLY JMP ERUDF ERFNC: LXI B,.FNCL JMP ERUDF EVRFN: SHLD FNTEV ; pour etre compatible avec la suite ERA9: LXI B,.EVAL ERUDF: LHLD FNTEV ; RECUPERE LE NOM ERUDFL: LXI D,.MSUDF JMP CALSR ;----- ERLEC : erreur de syntaxe ERLC1: MVI L,1 ; erreur de p-name trop long ERLEC: XRA A ; A <- 0 STA RINGR ; efface tout trace de la lecture MOV H,A ; complete le numero de l'erreur PUSH H ; c'est le type de l'erreur CALL DIO0 ; fait (INPUT) CALL ZARBUF ; efface le reste du tampon CALL RIOMP ; charge READ ou IMPLODE XRA A ; A <- 0 STA IMPLP ; pour eviter de boucler dans implode POP H ; type de l'erreur, c'est l'arg LXI D,.MSLEC JMP CALSR .PAGE ;----- ERCONS : cdr numerique ERBONS: MOV H,B ; le nombre fautif MOV L,C LXI B,.CONS ; ca venait du g.c. JMP ERCONS ; vers le message ERRONS: CALL RIOMP ; ca venait de la lecture ERXONS: XCHG ; HL <- le nombre fautif ERCONS: LXI D,.MSCNS JMP CALSR ;----- ERRTAP : trop d'arguments ERRTAM: MOV D,M ; LES ARGUMENTS EN TROP INR L MOV E,M ERRTAL: LXI B,.EVAL ; C'EST DANS LES EXPRS ERRTA: XCHG ; ERRTAP DOIT SUIVRE ERRTAP: LXI D,.MSTAP JMP CALSR ;----- ERLIP : liaison impossible LETERR: LXI B,.LETR JMP ERLIP ERLBH: MOV D,B ; DE <- param MOV E,C XCHG ; DE <- arg ERLHD: CALL NEXONS ; reunit APTRA: LXI B,.EVAL ; LA FONCTION FAUTIVE ERLIP: LXI D,.MSLIP JMP CALSR .PAGE ;----- OUTMRG : desinterne un nombre et verifie >0 et <128 ; ; HL = nombre ; BC = nom de la fonction si erreur ; DE n'est pas de'truit ; ; au retour A = L OUXMRG: XCHG OUTMRG: CALL VALNB ; prend la valeur ORA A ; test 0< ou >256 JNZ EROOB ; n'importe quoi MOV A,L ; le petit ORA A RP ; 128 max MOV H,A ; pour etre compatible EROOB: ANI VNBM ; reprend la representation externe MOV H,A ; voila OUTMAX: LXI D,.MSOOB ; le message JMP CALSR ; vers l'impression du message .PAGE ;----- traitement des erreurs de types ;----- VARCAR : HL <- CDR HL DE <- CAR HL et erreur si pas une variable RTATOX: XCHG RTATO: ; retour si HL est un atome litteral JTLST H,ARGNAT; c'est une liste ! MOV A,H ; car JTLST ne le fait pas CPI HNIL RNC ; ok JMP ARGNAT VARCAX: XCHG VARCAR: .UNCNS VARCAP: JTVAR D,ARGNAX ; n'importe quoi RFLST D ; c'est bon ARGNAX: XCHG ARGNAT: ; l'argument doit etre un atome litteral LXI D,.MSNAT JMP CALSR ARGNNB: ; l'argument doit etre un nombre LXI D,.MSNNB JMP CALSR ERCDR: LXI B,.CDR JMP ARGNLS ERPL3: LXI B,.RPLC3 XCHG ; mieux que JMP ARGNLX: XCHG ARGNLS: ; l'argument doit etre une liste LXI D,.MSNLS JMP CALSR .PAGE .SBTTL; I/O physiques, CI: CS: CO: ;****************************************************** ; I/O PHYSIQUES et interfaces systeme ; ; Definitions des sous-programmes : ; ; - CI : lecture d'1 caractere dans A ; - CS : TTY SNEAK ; si un caractere est present idem a CI ; sinon rentre de suite avec 0 dans A ; - CO : imprime le caractere contenu dans C ; ; Ces sous-programmes ne doivent rien detruire ;****************************************************** .IFNE MDS .CI=$F803 ; CONSOLE INPUT .CS=$F812 ; CONSOLE SNEEK .CO=$F809 ; CONSOLE OUTPT .TR=.CI ; paper-tape read .TP=.CO ; paper-tape punch STATI=$0F7 ; STATUS ENTREE CRT STAOU=$0F7 ; STATUS SORTIE CRT. TTYIN=$0F6 ; PORT ENTREE CRT. TTYOU=$0F6 ; PORT SORTIE CRT. .ENDC ; MDS .IFNE MZ80 STATI=$DD ; STATUS ENTREE STAOU=$DD ; STATUS SORTIE. STATR=$DE ; TAPE READER TTY. TTYIN=$DC ; PORT ENTREE. TTYOU=$DC ; PORT SORTIE. .CI: LDA IPTI ; recupere l'indicateur de bande. ANI 2 ; test tape reader ? JZ CI2 ; si clavier simple. MVI A,7 ; code du start reader. OUT STATR ; qui est envoye. CIW: IN STATR ; test du start bit RLC ; (plus rapide que ANI 1) JNC CIW ; du lecteur de ruban. MVI A,3 ; code du stop reader OUT STATR ; qui est envoye. PUSH B ; boucle d'attente MVI B,100 ; de 100mS (sinon ca merde) WWI1: MVI C,$70 ; pour 1mS. WWI2: DCR C JNZ WWI2 DCR B JNZ WWI1 POP B ; et voila j'ai perdu 100mS. CI2: IN STATI ; lecture du statut d'entree. ANI $40 ; caractere pret ? JZ CI2 ; nan : j'attend. IN TTYIN ; ouaip : je le lis. RET ; c'est tout bon. .CS: IN STATI ; lecture du status d'entree. ANI $40 ; caractere pret ? RZ ; nan : je retourne avec 0 dans A. IN TTYIN ; ouaip : je le lis. RET ; et voila. .CO: IN STAOU ; lecture du status d'entree. RLC ; imprimeur pret ? JNC CO ; nan : j'attend. MOV A,C ; charge le caractere a imprimer. OUT TTYOU ; on le sort. RET ; vers de nouvelles aventures. .TR=.CI ; paper-tape read .TP=.CO ; paper-tape punch .ENDC ; MZ80 .IFNE TRS STATI=0 STAOU=0 TTYIN=0 TTYOU=0 .CI: MVI A,$E ; caractere underline (curseur) CALL $33 ; qui est affiche. CIW: CALL $2B ; test caractere pret. ORA A ; alors ? JZ CIW ; ya rien encore, j'attend. RET ; il est dans A : bravo. .CS=$2B ; SEEK CHAR .CO: PUSH D ; car $0033 l'utilise PUSH H ; pour travailler egalement. LHLD CURSYS ; recupere le curseur systeme. INX H ; que se passe-t-il si on ajoute 1 caractere ? MOV A,C ; A <- le caractere a envoyer. CPI $0D ; c'est return ? CZ CD.CR ; ouaip : vers calcul adresse speciale MOV A,H ; y-a-t-il un scrolling ? CPI $40 ; (car on sortirait de l'ecran) JC CO4 ; nan : traitement normal. ;;; scrolling manuel pour traiter les fenetres LE LISP PUSH B ; pour travailler sauve BC LHLD WINSIZ ; recupere la taille de la fenetre MOV B,H MOV C,L ; BC <- la taille. LHLD WINREC ; HL <- adresse de la zone receptrice XCHG ; maintenant dans DE LXI H,64 ; taille d'une ligne DAD D ; HL <- adresse emettrice du scrolling LDIR ; scrolling effectif! LXI H,$3FFF-64 ; debut ligne blanche. MVI M,' ' ; efface le 1er caractere de la ligne LXI D,$3FFF-63 ; recept ligne blanche LXI B,63 ; de 63 caracteres LDIR ; roulez jeunesse... LHLD CURSYS ; pointeur courant MVI M,' ' ; efface le curseur. LXI D,-64 ; DAD D ; on recule d'1 ligne. SHLD CURSYS ; devient la position courante. POP B ; restaure BC CO4: ;;; sortie normale du caractere dans C MOV A,C ; A <- le caractere a sortir. CALL $0033 ; appel de la routine systeme LEVEL II POP H ; restaure tout POP D ; encore RET ; et voila. .IFNE BIG .TR: ; paper-punch read de test. PUSH B ; sauve BC MVI C,'=' ; pour l'imprimer CALL .CO ; on l'imprime POP B ; voila JMP .CI ; et apres c'est pareil. .TP: ; paper-punch print PUSH B ; pour rigoler MVI C,'!' ; pour voir CALL .CO ; on affiche. POP B ; recupere le C a imprimer. JMP .CO ; et apres c'est idem. .IFF ; de BIG .TR=.CI .TP=.CO .ENDC ; de BIG .ENDC ; TRS .IFNE SDK80 STATI=$FB STAOU=$FB TTYIN=$FA TTYOU=$FA .CI: IN STATI ; lecture du registre d'etat. ANI 2 ; caractere pret ? JZ CI ; nan : j'attend IN TTYIN ; ouaip : on le lit vraiment. RET .CS: IN STATI ; lecture du registre d'etat ANI 2 ; isole le bit pret. RZ ; il n'y a rien de pret. IN TTYIN ; sinon je lis RET ; et je le retourne dans A .CO: IN STAOU ; lecture du registre d'etat RRC ; imprimeur pret ? JNC CO ; nan : j'attend MOV A,C ; recupere le caractere a imprimer OUT TTYOU ; qui esr sorti. RET .TR=.CI ; paper-tape read .TP=.CO ; paper-tape punch .ENDC ; SDK80 .IFNE SOR .CI: CALL $E018 ; appel de la routine moniteur JZ CI ; rien de pret j'attends RET ; sinon le caractere est dans A .CS: JMP $E018 ; c'est vraiment equivalent ; mais on laisse l'adresse pour pouvoir ; faire des patches commodemment. .CO: MOV A,C ; lui il marche avec A JMP $E01B ; mais c'est tout. .TR=.CI ; paper-tape read. .TP=.CO ; paper-tape prunch. .ENDC ; SOR .IFNE IMSAI STATI=$03 STAOU=$03 TTYIN=$02 TTYOU=$02 .CI: IN STATI ; lecture du registre d'etat. ANI 2 ; caractere pret ? JZ CI ; nan : j'attend IN TTYIN ; ouaip : on le lit vraiment. RET .CS: IN STATI ; lecture du registre d'etat ANI 2 ; isole le bit pret. RZ ; il n'y a rien de pret. IN TTYIN ; sinon je lis RET ; et je le retourne dans A .CO: IN STAOU ; lecture du registre d'etat RRC ; imprimeur pret ? JNC CO ; nan : j'attend MOV A,C ; recupere le caractere a imprimer OUT TTYOU ; qui est sorti. RET .TR=.CI ; paper-tape read .TP=.CO ; paper-tape punch .ENDC ; IMSAI .IFNE TRSII .CI: PUSH H ; il faut tout sauver PUSH D PUSH B CI1: MVI A,4 ; code du read RST 1 ;RST 8 Zilog; ; appel SVC JNZ CI1 ; c'est pas pret. MOV A,B ; le resultat doit etre dans A POP B POP D POP H ; voila c'est propre RET ; et c'est tout. .CS: PUSH H ; il faut tout sauver PUSH D PUSH B MVI B,0 ; prepare la valeur de retour MVI A,4 ; code lecture caractere RST 1 ;RST 8 Zilog; MOV A,B ; le resulta est dans A POP B ; on restaure tout POP D POP H RET ; et voila .CO: PUSH H ; on sauve tout PUSH D PUSH B MOV B,C ; la chose a imprimer doit etre dans B MVI A,8 ; code ecriture caractere RST 1 ;RST 8 Zilog; ; appel SVC POP B ; retaure tout POP D POP H RET ; et voila .TR=.CI ; entree auxiliaire = entree normale .TP: PUSH H ; il faut tout sauver PUSH D PUSH B MOV B,C ; pour le SVC MVI A,18 ; PRCHAR RST 1 ; appel de SVC POP B POP D POP H ; restaure tout RET .ENDC ; de TRSII .IFNE CPM2 .CI: PUSH H ; il faut tout sauver PUSH D PUSH B CI1: MVI C,6 ; direct console I/O MVI E,$FF ; en entree CALL BDOS ; appel de FDOS ORA A ; alors ? JZ CI1 ; pas encore pret. POP B POP D POP H ; voila tout est restaure RET .CS: PUSH H ; il faut tout sauver PUSH D PUSH B MVI C,6 ; direct console I/O MVI E,$FF ; en entree CALL BDOS ; appel de FDOS CS1: POP B POP D POP H ; voila tout est restaure RET .CO: PUSH H ; il faut tout sauver PUSH D PUSH B MOV E,C ; pour FDOS MVI C,6 ; direct console I/O CALL BDOS ; appel FDOS POP B POP D POP H ; voila tout est restaure RET .TR: ; paper tape read PUSH H ; il faut tout sauver PUSH D PUSH B MVI C,3 ; READER INPUT CALL BDOS ; appel de FDOS POP B ; il faut tout restaurer POP D POP H RET ; et voila .TP: ; paper tape punch PUSH H ; il faut tout sauver PUSH D PUSH B MOV E,C ; le car doit etre dans E MVI C,4 ; PUNCH OUTPUT CALL BDOS ; appel de FDOS POP B ; il faut tout restaurer POP D POP H RET ; et c'est tout .ENDC ; de CPM2 .IFNE LEBLAN .CI=0 ; tout est fait par lui .CS=0 .CO=0 .TR=.CI .TP=.CO .ENDC ; de LEBLAN .PAGE .SBTTL; Fnts physiques : (TYI) (TYS) (IN n) (OUT n1 n2) ;***** (TYI) [SUBR 0] TYI: .IFNE EDITRS PUSH H ; a cose d'EDL LHLD CURSYS ; CALL CLIGN ; et ca blink POP H ; voila! .IFF CALL CI ; caractere suivant normal. .ENDC ; de EDITRS TYI1: ANI $7F ; enleve la parite JMP CRANA ; et interne sa valeur. ;***** (TYS) [SUBR 0] tty sneaks TYS: CALL CS ; on teste. ORA A ; ya quelquechose ? JNZ CRANA ; oui : retourne la valeur JMP FALSE ; non : retourne NIL ;***** (IN ) [SUBR 1] FINP: MOV A,L ; recup le numero de la porte STA FINPI+1 ; creation de l'instruction IN. JMP FINPI ; et va l'executer. ;***** (OUT ) [SUBR 2] FOUT: POP D XCHG MOV A,L ; recup le numero de la porte STA FOUTI+1 ; creation de l'intruction OUT. MOV A,E ; recup la JMP FOUTI ; execution du OUT X, RET. .PAGE .SBTTL; Entree physique caractere : CINC SPCHR: ; CINC : LIT LE CARACTERE SUIVANT DS C ; ET ENLEVE LA PTY. CINC: LDA IPPI ; type de terminal CI ou TR ORA A ; c'est CI ? JZ INB01 ; ouaip. CALL TR ; sinon c'est TR. JMP INB02 ; c'est vraiment pas beau ces trucs ... INB01: CALL CI ; lecture CI. INB02: ANI $7F ; enleve la parite. JZ CINC ; et saute tous les nulls. MOV C,A ; valeur de retour dans A & C. RET ; SPCHR : TESTE SI A EST UN CARACTERE CONTROL (^X) ; QUI DOIT S'IMPRIMER AVEC 2 CARACTERES. CARRY SI OUI. SPCHR: CPI 6 ; 1 DES 6 1ERS CTRL CARACT ? RC ; RETOUR CARRY DE SUITE. CPI $0E ; TEST : BS TAB CMC ; LF VT FF CR ? RNC ; RETOUR NON-CARRY. CPI $20 ; TEST TOUS LES AUTRES. RET ; RET AVEC CARRY POSITIONNE. ; SSPCHR : TESTE SI A EST UNE CARCTERE CONTROL ; SI NON CY = 0 ; SI OUI CY = 1 A = A + $40 C = PREFIXE A ENVOYER SSPCHR: CALL SPCHR ; test du caractere RNC ; rien a faire .IFNE TRS MVI C,$5B .IFF MVI C,'^' .ENDC ADI $40 ; equivalent lettre STC ; repositionne CY RET ; et voila .PAGE .SBTTL; Entree physique buffer : INCHB: INCI: ; INCHB : met dans B le caractere suivant du buffer d'entree INCHB: PUSH H ; ne doit rien detruire. .IFNE EDIT LDA IEDIT ; il faut lire la ORA A ; memoire de l'editeur ? JNZ INCH2 ; oui : ben on y va. .ENDC ; de EDIT INCH0: LDA LBCIU ; recup le pointeur courant ligne. MOV L,A ; c'est faible MVI H,INBUF ^ ; les forts INCH1: LDA LBMIX ; recupere la derniere position CMP L ; on est arrive ? JZ COLBOL ; ouaip : vers la lecture d'une nouvelle ligne. MOV B,M ; charge le caractere MVI M,0 ; l'efface INR L ; actualise le pointeur MOV A,L ; pour la suite : STA LBCIU ; on le range. POP H ; restaure H&L. RET ; et voila. .IFNE EDIT INCH2: LHLD EDIPT ; RECUP POINT VIDEO MOV A,M ; CAR SUIVANT. MOV B,A ; QUI DOIT ETRE dans B CPI $20 ; ESPACE ? JZ INCH5 ; OUAIP INX H ; POURSVANT. MOV A,H ; TEST FIN DE MEM ECRAN CPI HGECR ; ? JNC INCH4 ; OUI : TERMINE ECRAN INCH3: SHLD EDIPT ; RNGE L POINT POP H ; CLEN CLEAN CLEAN RET INCH4: XRA A ; FORCE L'INDICATEUR STA IEDIT ; LIRE LA MEM VIDEO. JMP INCH0 ; VA LIRE UN CARACTERE NORMAL. INCH5: INX H ; POISITION SUIVANT MOV A,L ; FIN DELIGNE ? ANI $3F ; (YA 64 CARACTERES / LIGNE) MVI B,$0D ; POUR LE CAS FIN DE LIGNE ECRAN JZ INCH3 ; ON RAMENE RETURN. MOV A,M ; PEEKCH NEXT CAR CPI $20 ; ENCORE DES ESPCES ? JZ INCH5 ; OUAIP : ON LES SAUTENT. MVI B,$20 ; C'EST DONC UN ESPACE SIMPLE JMP INCH3 .ENDC ; de EDIT .PAGE ;----- INCI : LECTURE D'UNE LIGNE ENTIERE ET STOCKAGE ; dans INBUF. Fait office de line editor. INCI: LXI H,INBUF ; adresse du buffer de ligne. .IFNE FILE LDA IDSK ; I/O SUR DISQUE ? ORA A ; ON TESTE. JNZ INDI ; OUAIP : vers le traitement disque .ENDC ; de FILE .IFNE K7 LDA IK7 ; I/O SUR K7 ? ORA A JNZ INKI ; OUAIP. .ENDC ; de K7 PUSH H ; sauve l'adresse du buffer CALL LMRGRI ; envoie la marge LHLD PROMPT ; le prompt CALL LCOPH ; on sort l'atome sur la console INPRM9: POP H ; recup l'adresse du buffer INCI0: ; pretty-read : LDA RDCRD ; SAUVE LE NB DE ( EN TETE DE ANI 7 ; MAX DE 7 INDENTAIONS. JMP INCP3 ; en voiture .PAGE ;----- ENVOI DES ESPACES EN DEBUT DE LIGNE DE READ INCP1: PUSH PSW ; sauve le cpt. CALL TABU ; envoie indent fois espace POP PSW ; recup le compteur. INCP3: DCR A ; IL EN FAUT encore ? JP INCP1 ; ouiap. ;;;INCI1 DOIT SUIVRE ;----- INCI1 : BOUCLE DE LECTURE DES CARACTERES INCI1: CALL CINC ; caractere physque suivant INCI2: CPI $D ; return ? JZ INCRT CPI $15 ; ^U (efface la ligne) ? JZ INCU CPI $18 ; ^X (= ^U) ? JZ INCU LXI D,INCI1 ; prepare le retour, c'est pas la fin PUSH D CPI $08 ; BACKSPACE ? JZ INCD ; = RUBOUT pour l'instant CPI $09 ; TAB ? JZ TABU ; dimensionne au prettyread ! .IFNE TRS ! TRSII CPI 1 ; BREAK ? JZ REENM ; on recommence tout .IFF CPI $7F ; RUBOUT ? JZ INCD CPI $12 ; ^R JZ INCR .ENDC ECHO: ; normal MOV M,C ; range dans le buffer ECHO1: ; pour ceux ou c'est deja range INX H ; qui est plus petit ECHO2: ; pour ceux qui range pas ECHO3: ; pour ceux qui ont teste l'echo (obsolete) MOV A,C ; charge le caractere .IFNE TRS ! TRSII CPI $A ;c'est LF ? RZ ; on l'envoie pas car RC = RC + LF .ENDC CALL SSPCHR ; s'il faut 2 caracteres en sortie JNC COPHT2 ; nan PUSH PSW ; sauve le deuxieme CALL COPHT2 ; sort le prefixe POP PSW MOV C,A ; comme si de rien n'etait JMP COPHT2 ; et c'est tout .PAGE ;----- INCT1 : fin de lecture d'une ligne INCRT: ; RETURN, fin de la boucle CALL ETLF ; envoie R/LF INCT1: MOV A,L ; derniere position STA LBMIX ; indiquera la fin de l'entree RET ; et voila ;----- ENVOI DE "INDENT" ESPACES POUR DEBUT DE LIGNE ET TAB. TABU: LDA INDENT ; le nombre qui faut MVI C,$20 ; l'espace MOV B,A JMP TABU1 ; en voiture TABU2: CALL ECHO ; envoi et stocke TABU1: DCR B ; compteur JP TABU2 ; ca roule RET ;----- LCOPH : envoie l'atome HL sur la console LCOPH: LXI D,10 ; P-len DAD D ; HL <- adresse P-length MOV B,M ; B <- P-length INR B ; en positif strict JMP INPRM3 ; ca roule INPRM2: MOV C,M ; C <- caractere suivant CALL COPHT2 ; on le sort INPRM3: INX H ; avance dans le p-name DCR B ; compte p-length JNZ INPRM2 RET .PAGE ;----- RETLF : envoie RC/LF sur la console RETLF: ; envoie CR/LF sur la console MVI C,$0D ETLF: CALL ECHO ; envoie le CR MVI C,$0A ; LF JMP ECHO ;----- LMRGRI : ENVOIE LA MARGE GAUCHE SUR CONSOLE LMRGRI: LDA LBMIN ; la marge gauche MOV B,A ; dans B MVI C,$20 ; l'espace de la marge JMP LMRGRT ; en voiture LMRGRL: CALL COPHT2 ; sort l'espace LMRGRT: DCR B ; decremente le compteur JP LMRGRL ; ca roule RET .PAGE ;----- TRAITEMENT DES CARACTERES D'EFFACEMENT INCD: ;;; YA EU 'DELETE' OU 'RUB-OUT' ou BACKSPACE. MOV A,L ; ON EST EN DEBUT DE LIGNE ? ORA A RZ ; SI OUI ON FAIT RIEN. DCX H ; RECULE D'UN CARACTERE. .IFNE TRS ! TRSII CALL COPHT2 ; envoie le rubout MOV A,M ; c'est quoi ce caractere ? CALL SPCHR ; c'est un caractere special ? RNC ; non on peut rentrer de suite. MVI C,$08 ; il faut un deuxieme rubout CALL COPHT2 ; voila RET ; et rentre. .IFF INCD1: MOV A,M ; charge le precedent caractere CALL SPCHR ; c'est un double ? CC ERASE ; ouaip efface le deuxieme ERASE: CALL BKSP ; envoie bakspace MVI C,$20 ; un espace CALL COPHT2 ; l'envoie BKSP: MVI C,$08 ; backspace JMP COPHT2 ; on efface tout et on recommence .ENDC ; de TRS .PAGE ;----- TRAITEMENTS DES FIN DE LIGNES .IFNE TRS ! TRSII .IFF INCR: ;;; YA EU ^R. PUSH H ; SAUVE LA POSITION COURANTE CALL INEW ; CHANGE DE LIGNE. POP D ; RECUPERE LA POSITION COURANTE INCR1: MOV A,L ; ON EST ARRIVE AU CMP E ; MEME POINT ? RZ ; OUI: CONTINUE LA lecture. MOV C,M ; nan : recupere le caractere la CALL ECHO1 ; envoie et avance JMP INCR1 ; AU SUIVANT. .ENDC ; de TRS INCU: ;;; YA EU UN ^U. CALL INEW ; CHANGE DE LIGNE JMP INCI0 ; REPASSE EN DEBUT DE LIGNE. ; INEW : change de ligne avec un autre prompt. INEW: CALL ECHO2 ; envoie le caractere de break CALL RETLF ; passe a la ligne CALL LMRGRI ; envoie la marge MVI C,'!' ; le prompt de break CALL COPHT2 ; l'envoie MVI C,$20 ; un espace CALL COPHT2 ; l'envoie LXI H,INBUF ; repasse en debut de buffer RET .PAGE .SBTTL; Entree physique buffer : INDI: INKI: ; INDI : LECTURE DE L'ENREGISTREMENT SUIVANT DISQUE ; sous n'importe quel systeme ; ca met dans INBUF les caracteres. ; on rentre avec HL pointant sur le 1er emplacement libre de INBUF ; au moyen d'un JMP INCT1 !! .IFNE FILE INDI: .IFNE ISIS MVI C,3 ; CODE ISIS READ LXI D,FCB.IN ; BLOCK DE CONTROL CALL $40 ; APPEL ISIS LDA DSTAT ; RECUP STATUS ORA A ; qui EST TESTE. JNZ INDR ; ERREUR LECTURE. LHLD DACTL ; RECUP NB OCTETS TRANSMIS. MOV A,H ORA L ; TEST SI 0 TRANSMIS JZ INDEOF ; SI OUI = E.O.F. LXI D,INBUF ; POUR L'ADR DU DERNIER M DAD D JMP INCT1 ; FIN NORMALE. .ENDC ; de ISIS .IFNE TRSDOS LXI D,FCB.IN ; adresse DCB entree CALL $4436 ; module TRSDOS READ JNZ INDI1 ; ya une erreur LXI H,INBUF+64 ; j'ai toujours lu 64 caracteres JMP INCT1 ; fin lecture buffer INDI1: ;;; ya eu une erreur CPI $1C ; EOF ? JZ INDEOF ; ouaip. CPI $1D ; NRN trop grand ? JZ INDEOF ; ouaip. ;;; vraie erreur. JMP INDR ; traitement commun des erreurs. .ENDC ; TRSDOS .PAGE .IFNE CPM LXI D,$0080 ; adresse par defaut du DMA MVI C,26 ; code du SET DMA CALL BDOS ; re CP/M LXI D,FCB.IN ; adresse FCB d'entree MVI C,20 ; code READF CALL BDOS ; appel de CP/M ORA A ; teste le code retour. JNZ INDI3 ; il y a eu une erreur. LXI H,INBUF ; adr emet LXI D,$0080 ; buff std de CP/M INDI1: LDAX D ; 1 car MOV M,A ; dans la zone recept INX H ; avance dans la zone recept INX D ; avance dans la zone emettrice MOV A,D ; teste les poids forts ORA A JZ INDI1 ; qui doit toujous etre = 0 ; HL = INBUF + 128 (c'est parfait) JMP INCT1 ; fin lecture buffer INDI3: ;;; ya eu une erreur CPI $1 ; EOF ? JZ INDEOF ; ouaip. ;;; vraie erreur. JMP INDR ; traitement commun des erreurs .ENDC ; de CPM .IFNE TRSDS2 LXI H,0 ; "reserved for future use" LXI D,FCB.IN MVI A,34 ; code du READNX RST 1 ; appel SVC JNZ INDI1 ; ca va pas tout seul. LXI H,INBUF+1 ; je lis toujours 128 car JMP INCT1 ; retour normal INDI1: ;;; ya une erreur ; 3 - 1000l$$1000t$$ CPI 28 ; attempt to read past eof ? JZ INDEOF ; ouaip CPI 29 ; read attempt outside of file limits ? JZ INDEOF ; ouaip. JMP INDR ; c'est donc une vraie erreur. .ENDC ; de TRSDS2 .PAGE ;----- TRAITEMENT E.O.F. (pour tous les systemes) INDEOF: LXI H,.EOF ; adresse de l'atome EOF CALL EVRPN ; appel de (EOF) JMP INCI ; et on recommence a lire. .ENDC ; de FILE ; INKI : LECTURE ENREG SUIVANT K7 .IFNE K7 INKI: XRA A ; NO DRIVE CALL $0212 ; DEFINE DRIVE CALL $0296 ; FIND SYNC BYTE INKI1: PUSH H ; CLEAN CALL $0235 ; READ BYTE POP H ; RECUP POINT BUFFER MOV M,A ; RANGE DANS LE BUFFER INX H ; ACTUAL POINT. ANI $7F ; enleve la parite. CPI $D ; RC ? (FIN LIGNE) JNZ INKI1 ; NAN CALL $01F8 ; STOP CASSETTE JMP INCT1 ; VERS FIN DE LECTURE LIGNE. .ENDC ; de K7 .PAGE .SBTTL; Sortie physique caractere : OUTB: OUTBS: OUTS: OUTSS: ; OUTB : sort le caractere dans B, ; EN TRAITANT LES CNTRL CARACTERES en (^X) ; ET EN TRAPPANT LES 'HOLDING' : ; - en appelant ITEVAL pour MICRAL, TRS, z89, silz ; - ^Q ^S sur MDS MCS MZ IMSAI ; ET LES BREAKS : ; - ^C sur MDS MCS MZ IMSAI LOGAX ; - par ITEVAL pour les autres .IFNE ITEVAL COVLIT: PUSH B ; sauve le caractere PUSH D ; faut etre sympa avec les copains CALL CEVLIT POP D ; restaure POP B RET .IFF OUTB0: CALL CI ; on le lit vraiment. ANI $7F ; enleve la PTY. CPI 3 ; ^C ? JZ ASTOP ; ouaip. CPI $11 ; ^Q ? JNZ OUTB0 ; nan : je l'attends .ENDC ; de ITEVAL OUTB: ;;; test du holding. .IFNE ITEVAL TESTIT ; test le port, en fonction de la machine CNZ COVLIT .IFF ; de ITEVAL CALL CS ; ya un caractere ORA A ; DE TAPE ? JZ OUTB2 ; nan CALL CI ; on le lit vraiment ANI $7F ; enleve la parite CPI 3 ; ^C ? JZ ASTOP ; on arrete tout CPI $11 ; ^S ? JZ OUTB0 ; en attente .ENDC ; de ITEVAL .PAGE OUTB2: MOV A,B ; A _ le caractere. .IFNE TRS ! TRSII CPI $A ; Il faut sauter RZ ; tous les LF (car RC = RC+LF) .ENDC ; de TRS PUSH B ; sauve B (pour le retour) CALL SSPCHR JNC OUTB3 ; caractere simple PUSH PSW ; sauve l'equivalent lettre CALL COPH POP PSW ; recup le caractere. OUTB3: MOV C,A ; pour CO. CALL COPH ; sort C sur console. POP B ; restaure tout. RET ; voila. ; OUTBS : appel de OUTB mais le caractere argument ; est place juste SOUS l'appel : ; CALL OUTBS / DB 'X' / RETOUR ICI OUTBS: XTHL ; POINT SUR ARG ET SAUVE HL MOV B,M ; RECUP LE CARACTERE A EDITER INX H ; POINT SUR LE RETOUR XTHL ; REST HL ET PREPARE LE RET. JMP OUTB ; VERS EDITION. ; OUTS : sort la chaine d'adresse H&L ; se terminant par 00H. OUTS: MOV A,M ; CAR SUIV INX H ORA A ; 0 ? RZ ; OUAIP : C'EST FINI. MOV B,A CALL OUTB ; SORTIE ET TEST. JMP OUTS ; ca roule. ; OUTSS : sort la chaine situee sous l'appel lui-meme ; et retourne en sequence (apres le 0) OUTSS: POP H ; HL <- l'adresse de la chaine. CALL OUTS ; sort la chaine PCHL ; et rentre .PAGE .SBTTL; Sortie physique buffer : COPH: ; COPH : CO physique du caractere dans C ; traite les sorties disque/K7/ et TTY COPH: ; sortie physique de C .IFNE K7 LDA OK7 ; ON EST EN MODE K7 ? ORA A JZ COPHT1 ; nan : vers le test FILE. PUSH H ; TRES CLEAN. LHLD OUBPT ; RECUP POINT BUFFER MOV M,C ; RANGE LE CARACTERE INX H ; ACTUALISE LE POINT. SHLD OUBPT ; pour le prochain coup. MOV A,C ; POUR LES CPIS CPI $D ; C'EST UN 'RETURN' ? JNZ PHRET ; nan : retour MVI M,0 ; FORCE UN 0 (FIN DE BUFFR) XRA A ; A _ 0 : NUMERO DRIVE CALL $212 ; DEFINE DRIVE. CALL $287 ; WRITADER. LXI H,BUFOU ; AD DEBUTFFER DE SORTIE. SHLD OUBPT ; QUI REINIT LE POINT. JMP COPH2 ; CA ROuleE COPH1: PUSH H ; sauve le pointeur CALL $264 ; ECRIT le byte POP H ; RECUp le point. INX H ; INCR POINT SUR LE BUFFER. COPH2: MOV A,M ; A<- LE CARACTERE SUIV E FE ASSETTE0FF. ORA A ; 0 ? fin buffer JNZ COPH1 ; nan : vers l'ecriture K7 CALL $1F8 ; cassette OFF POP H ; CLEAN CLEAN RET .ENDC ; de K7 COPHT1: .IFNE FILE LDA ODSK ; DISK ? ORA A JZ COPHT2 ; nan : vers la suite des tests. ;;; Sortie d'1 caractere sur fichier (dependant de l'O/S) .IFNE ISIS PUSH H ; DOIT TOUT SAUVER LHLD OUBPT ; RECUP POINT SUR BUFOU MOV M,C ; CHARGE LE CARACTERE INX H ; INCLE PO SHLD OUBPT ; QUI EST RANGE. MOV A,C ; A <- L CARACT A IMPRIMER CPI $D ; C'EST RETURN ? JNZ PHRET ; NAN : C'EST TOUT BON. LXI D,-BUFOU ; POUR CALCULER LE NB DAD D ; D'OCTETS A ECRIRE. SHLD FCB.OU+4 ; CE NB EST RANGE DANS LE FCB LXI H,BUFOU ; R.A.J. DU POINT COURANT. SHLD OUBPT MVI C,4 ; CODE ISIS WRITE. LXI D,FCB.OU ; FCB CALL $40 ; APPEL DE ISIS LDA DSTAT ; RECUP LE COMPTE RENDU ORA A JZ PHRET ; TOUT VA BIEN. LXI H,DSTAT SHLD FCB.OU+2 ; POUR LE CLOSE MVI C,1 ; CODE CLOSE. LXI D,FCB.OU ; ADR FCB CALL $40 ; APPEL DE ISIS .ENDC ; de ISIS .IFNE TRSDOS PUSH H ; ca fait ca proprement. LHLD OUBPT ; pointeur sur le buffer ligne. MOV M,C ; on y range le caractere. INX H ; incremente le pointeur SHLD OUBPT ; qui est range. MOV A,L ; poids faibles du pointeur. CPI BUFOU & $FF + 64 ; ya 64 caracteres JC PHRET ; de rentre ? non : retour de suite. LXI H,BUFOU ; re-initialise le pointeur sur le buffer. SHLD OUBPT ; qui est range. LXI D,FCB.OU ; adresse du FCB de sortie. CALL $4439 ; appel de WRITE de TRSDOS. JZ PHRET ; tout c'est bien passe. LXI D,FCB.OU ; re pour le CLOSE CALL $4428 ; on essaie de fermer! .ENDC ; de TRSDOS .IFNE CPM PUSH H ; ca fait ca proprement. LHLD OUBPT ; pointeur sur le buffer ligne. MOV M,C ; on y range le caractere. INX H ; incremente le pointeur SHLD OUBPT ; qui est range. MOV A,L ; poids faibles du pointeur. CPI BUFOU & $FF + 128 ; ya 128 caracteres JC PHRET ; de rentre ? non : retour de suite. LXI H,BUFOU ; re-initialise le pointeur sur le buffer. SHLD OUBPT ; qui est range. LXI D,BUFOU ; nouvelle adresse du DMA MVI C,26 ; code set DMA adresse CALL BDOS ; appel CP/M LXI D,FCB.OU; adresse du FCB de sortie. MVI C,21 ; code du WRITE CALL BDOS ; appel de CP/M ORA A ; et on le teste. JZ PHRET ; tout c'est bien passe. LXI D,FCB.OU; pour tenter de fermer le fichier MVI C,16 ; code du CLOSE CALL BDOS ; CP/M .ENDC ; de CPM .IFNE TRSDS2 PUSH H ; ca fait ca proprement LXI H,BUFOU ; adresse du caractere MOV M,C ; range le caractere en memoire LXI H,0 ; "future use of TRSDS2" LXI D,FCB.OU; prepare le write MVI A,43 ; code du WRITE RST 1 ; appel SVC JZ PHRET ; tout c'est bien passe LXI D,FCB.OU; pour la tentative de fermeture MVI A,42 ; code du CLOSE RST 1 ; appel SVC .ENDC ; de TRSDS2 JMP ERDWR ; VERS L'ERREUR .ENDC ; DE FILE COPHT2: ; suite des tests s'il y a LDA OPPI ; indicateur console/paper-tape. ORA A ; alors ? JZ CO ; c'est la console. ;;; test du paper-tape. ; PUSH B ; sauve le caractere. ; MVI C,'!' ; avant tout caractere. ; CALL CO ; on le sort ; POP B ; puis le caractere normal. JMP TP ; sinon c'est TP. .PAGE .SBTTL; Fnts file : (INPUT f) (EOF) (OUTPUT f) ;***** (INPUT file/NIL/T) [SUBR 1] ; selecte un fichier en entree. DIOI: MOV A,H ; test de l'argument CPI .T ^ ; c'est T JNZ DIO01 ; nan a suivre. MOV A,L CPI .T & $FF ; encore ? JNZ DIO01 ; nan MVI A,1 ; indicateur : paper-tape STA IPPI ; que l'on range. JMP DIO0 ; et apres c'est comme un terminal. DIO01: XRA A ; indicateur console pure. STA IPPI ; qui est forcee. .IFNE FILE MOV A,H ; l'argument est fourni ? CPI HNIL JNZ DIO1 ; OUAIP : vers le traitement fichier. DIO0: ;;; pas de fichier = ouvre la TTY ; appele par EOF donc gaffe. LDA IDSK ; on etait sur disque ? ORA A ; hein ? JZ TRUTH ; nan : donc c'est tout bon. ;;; Fermeture du fichier disque ouvert (en fnt des OS) .IFNE ISIS LXI H,DSTAT ; prepare le SHLD FCB.IN+2 ; FCB du close. MVI C,1 ; code du CLOSE ISIS. LXI D,FCB.IN CALL $40 ; appel de ISIS .ENDC ; ISIS .IFNE TRSDOS LXI D,FCB.IN ; adresse du FCB d'entree CALL $4428 ; appel du CLOSE de TRSDOS .ENDC ; TRSDOS .IFNE CPM LXI D,FCB.IN; adresse du FCB d'entree MVI C,16 ; code du CLOSE CALL BDOS ; et appel de CP/M .ENDC ; CPM .IFNE TRSDS2 LXI D,FCB.IN; adresse du DCB d'entree MVI A,42 ; code du CLOSE RST 1 ; appel SVC TRSDS2 .ENDC ; TRSDS2 XRA A ; dans tous les cas STA IDSK ; on est plus sur disque. JMP TRUTH ; et on retourne vrai. ;;; Ouverture d'un fichier disque (dependant de l'O/S) DIO1: .IFNE ISIS LXI D,11 ; offset P-name. DAD D ; HL <- pointe sur le P-name du nom de fichier. DIO2: SHLD FCB.IN+2 ; FABRIQUE FCB LXI H,DIAFT ; ADRESSE AFT SHLD FCB.IN ; FABRIQUE FCB LXI H,1 ; AST READ SHLD FCB.IN+4 ; FABRIQUE F LXI H,0 ; YA PAS D'ECHO SHLD FCB.IN+6 ; FABRIQUE FCB LXI H,DSTAT ; ADRESS SHLD FCB.IN+8 ; FABRIQUE FCB MVI C,0 ; CODE ISIS = OPEN LXI D,FCB.IN ; ADRESSE CALL $40 ; APPEL DE ISIS II LDA DSTAT ; RECUP LE COMPTE RENDU. ORA A ; = 0 ? JZ DIO4 ; TOUT EST OK : VERS FABRIQUE FCB READ. XRA A ; SI ERREUR PASSE STA IDSK ; SUR :CI: (NON DISQUE) JMP FALSE ; ET RAMENE NIL. DIO4: LHLD DIAFT ; PREPAPRE LE FCB DU READ SHLD FCB.IN ; L'AFT LXI H,INBUF SHLD FCB.IN+2 ;RESS DU BUFFER LXI H,80 SHLD FCB.IN+4 ; LONGEUR DE L'ECHANGE LXI H,DACTL SHLD FCB.IN+6 ; TAILLE ACTUELLE LXI H,DSTAT SHLD FCB.IN+8 ; COMPTE RENDU .ENDC ; de ISIS .IFNE TRSDOS LXI D,10 ; offset P-LEN DAD D ; HL <- pointe sur P-LEN MOV B,M ; B <- le P-LEN INX H ; HL <- pointe sur P-NAM MVI C,32 ; taille max du filename. LXI D,FCB.IN ; adresse du filename XCHG ; HL <- filename, DE <- P-name DIO2: LDAX D ; transfert le P-name MOV M,A INX D ; avance dans P-name INX H ; avance en filename DCR C ; compte filename DCR B ; compte P-name JNZ DIO2 ; comtinue MVI M,$0D ; force un return (veut TRSDOS) DIO3: MVI M,' ' ; et padd avec des espaces DCR C JP DIO3 LXI H,BUF.IN ; adresse buffer systeme entree LXI D,FCB.IN ; adresse du FCB d'entree MVI B,64 ; taille enreg logique. CALL $4424 ; OPEN du TRSDOS JZ DIO9 ; si tout va bien. ; ORI $80 ; pour un message entier ; CALL $4409 ; imprime l'erreur XRA A ; indique pas d'entree STA IDSK ; sur disque. JMP FALSE ; et retourne faux = erreur INPUT. .ENDC ; de TRSDOS .IFNE CPM LXI D,10 ; offset P-LEN DAD D ; HL <- pointe sur P-LEN MOV B,M ; B <- le P-LEN INX H ; HL <- pointe sur P-NAM MVI C,11 ; taille max du filename + ext LXI D,FCB.IN+1 ; adresse du filename XCHG ; HL <- filename, DE <- P-name DIO2: LDAX D ; transfert le P-name MOV M,A INX D ; avance dans P-name INX H ; avance en filename DCR C ; compte filename JZ DIO3 ; le P-name est fini DCR B ; compte P-name JNZ DIO2 ; comtinue DIO3: XRA A ; numero du disque STA FCB.IN ; = 0 (i.e. A:) STA FCB.IN+12 ; idem pour file ext STA FCB.IN+13 ; -- STA FCB.IN+14 ; -- STA FCB.IN+15 ; -- STA FCB.IN+32 ; numero du 1er enreg. LXI D,FCB.IN; adresse du FCB MVI C,15 ; code du OPEN CALL BDOS ; appel de CP/M CPI 255 ; -1 si erreur. JZ DIO8 ; ca va pas ... DIO6: XRA A ; 0 = numero du 1er STA FCB.IN+32 ; enregistrement a lire. JMP DIO9 ; vers le retour OK. .ENDC ; de CPM .IFNE TRSDS2 LXI D,10 ; offset P-len DAD D ; HL pointe sur le P-len MOV B,M ; B <- P-len INX H ; HL pointe sur le P-name MVI C,60 ; taille max du filename LXI D,FCB.IN; adresse du filename XCHG ; HL <- filename, De <- Pname DIO2: LDAX D ; transfert du P-name MOV M,A INX D ; avance dans p-name INX H ; avance en filename DCR C ; compte filename DCR B ; compte p-name JNZ DIO2 ; continue MVI M,$0D ; le veut TRSDS2 DIO3: MVI M,' ' ; et padd avec des espaces DCR C ; tout le filename JP DIO3 ; ca boucle. LXI H,BUF.IN; adresse du buffer physique SHLD FPL.IN ; prepare le FPL LXI H,INBUF ; adresse du buffer logique SHLD FPL.IN+2 LXI H,0 ; indique pas de traitement SHLD FPL.IN+4; speciaux en EOF MVI A,'R' ; access type STA FPL.IN+6; read only MVI A,1 ; taille d'un enregistrement STA FPL.IN+7 MVI A,'F' ; enreg fixe STA FPL.IN+8 LXI H,0 ; open old + 0 en user attribute SHLD FPL.IN+9 LXI D,FCB.IN; prepare l'appel LXI H,FPL.IN; avec les 2 blocs MVI A,40 ; code du OPEN RST 1 ; appel SVC JZ DIO9 ; tout c'est bien passe. JMP DIO8 ; ya un pb! .ENDC ; de TRSDS2 DIO8: ;;; final commun a tous les systemes si OPEN KO. XRA A ; indique entree STA IDSK ; non sur disque (sur terminal) JMP FALSE ; et retourne toujours faux. DIO9: ;;; final commun a tous les systemes si OPEN OK. MVI A,1 ; indique entree STA IDSK ; sur disque LXI H,INBUF ; init le buffer d'entree MVI M,0 ; 1er caractere = 00 MOV A,L STA LBCIU ; pointe sur le 1er caractere. JMP TRUTH ; et retourne T. .IFF ; de FILE DIO0: JMP TRUTH ; ya rien a faire. .ENDC ; de FILE ;***** (EOF) [SUBR 0] .IFNE FILE FEOF: CALL DIO0 ; appel de (INPUT) i.e. un CLOSE LXI H,.EOF ; l'atome EOF JMP ESCSTD ; et provoque l'echappement .ENDC ; de FILE ;----- (OUTPUT FILE) [SUBR 1] ; selecte le fichier de sortie. DOOI: MOV A,H ; test arg = T CPI .T ^ ; OK ? JNZ DOO01 ; nan MOV A,L ; encore ? CPI .T & $FF ; JNZ DOO01 MVI A,1 ; indicateur paper-tape. STA OPPI ; qui est range. JMP DOO0 ; et apres c'est comme une console. DOO01: XRA A ; indicateur console. STA OPPI ; indic console ou reader. .IFNE FILE MOV A,H ; Le 1er argument est fourni ? CPI HNIL ; (i.e. # de NIL) JNZ DOO1 ; ouaip : vers le traitement des files. DOO0: ;;; si pas de fichier = ouvre la TTY LDA ODSK ; on etait sur disque ? ORA A ; hein ? JZ TRUTH ; oui : on rentre tout est bon. ;;; nan : on ferme le fichier ouvert. .IFNE ISIS LXI H,DSTAT ; POUR LE FCB DU CLOSE SHLD FCB.OU+2 ; DU FICHIER PRECEDEMENT OUVERT. MVI C,1 ; CODE CLOSE ISIS. LXI D,FCB.OU ; FCB. CALL $40 ; APPEL DE ISIS .ENDC ; de ISIS .IFNE TRSDOS DOO10: LHLD OUBPT MOV A,L ; c'est une fin de buffer ? CPI BUFOU & $FF +1 ; (le ptr est reinitialise) ? JC DOO11 ; ouaip : c'est fini, on ferme. MVI C,$20 ; force un nouvel espace. CALL COPH ; on le sort. JMP DOO10 ; et ca roule. DOO11: LXI D,FCB.OU ; adresse du FCB de sortie CALL $4428 ; appel du CLOSE de TRSDOS .ENDC ; de TRSDOS .IFNE CPM JMP DOO11 ; en voiture DOO10: MVI C,26 ; force un ^Z CALL COPH ; on le sort DOO11: LHLD OUBPT MOV A,L ; c'est une fin de buffer ? CPI BUFOU & $FF +1 ; (le ptr est reinitialise) ? JNC DOO10 ; et ca roule. LXI D,FCB.OU; adresse du FCB d'entree MVI C,16 ; code du CLOSE CALL BDOS ; et appel de CP/M .ENDC ; de CPM .IFNE TRSDS2 DOO11: LXI D,FCB.OU; adresse du FCB de sortie MVI A,42 ; code du CLOSE RST 1 ; appel SVC .ENDC ; de TRSDS2 XRA A ; et dans tous les cas STA ODSK ; on est plus sur disque JMP TRUTH ; et on retourne toujours T ;;; Ouverture d'un fichier disque (dependant des O/S) DOO1: .IFNE ISIS LXI D,11 ; OFFSET P-NAME DAD D ; HL <- POINT SUR P-NAME. SHLD FCB.OU+2 ; FORCE LE FILENAME LXI H,DOAFT ; ADR DU AFTN OUT SHLD FCB.OU ; FORCE DANS LE FCB LXI H,2 ; ACCESS WRITE SHLD FCB.OU+4 LXI H,0 ; PAS D'ECHO AFTN SHLD FCB.OU+6 LXI H,DSTAT ; ADR DU COMPTE RENDU. SHLD FCB.OU+8 MVI C,0 ; CODE ISIS OPEN LXI D,FCB.OU ; ADR FCB CALL $40 ; APPEL DE ISIS LDA DSTAT ; RECUP COMPTE RENDU. ORA A JNZ DOO8 ; ca va pas : indic non et ret NIL LHLD DOAFT ; PREPARE LE FCB DES WRITES FUTURES SHLD FCB.OU ; FORCE L'AFTN LXI H,BUFOU SHLD FCB.OU+2 ; ET L'ADRESSE DU BUFFER LXI H,DSTAT SHLD FCB.OU+6 ; ET L'ACR DU COMPTE RENDU JMP DOO9 ; vers le retour OK. .ENDC ; de ISIS .IFNE TRSDOS LXI D,10 ; offset P-LEN DAD D ; Hl <- pointeur P-LEN MOV B,M ; B <- P-LEN INX H ; HL <- pointeur P-name MVI C,32 ; taille max filename LXI D,FCB.OU ; adresse filename XCHG ; HL <- filename, DE <- P-name DOO2: LDAX D ; transfert P-name MOV M,A INX H ; avance en filename INX D ; avance en P-name DCR C ; compte filename DCR B ; compte P-name JNZ DOO2 ; encore. MVI M,$0D ; force un dernier return (pour TRSDOS) DCR C ; compte filename DOO3: MVI M,' ' ; padde avec des espaces (pour TRSDOS itou) DCR C ; compte filename JP DOO3 ; remplit tout. LXI H,BUF.OU ; adresse buffer systeme LXI D,FCB.OU ; adresse FCB de sortie MVI B,64 ; taille du buffer logique. CALL $4420 ; appel de INIT file de TRSDOS. JZ DOO9 ; tout c'est bien passe. ; ORI $80 ; pour un message d'erreur clair. ; CALL $4409 ; impression du message d'erreur. JMP DOO8 ; indic pas sur disque et ret NIL .ENDC ; de TRSDOS .IFNE CPM LXI D,10 ; offset P-LEN DAD D ; HL <- pointe sur P-LEN MOV B,M ; B <- le P-LEN INX H ; HL <- pointe sur P-NAM MVI C,11 ; taille max du filename + ext LXI D,FCB.OU+1 ; adresse du filename XCHG ; HL <- filename, DE <- P-name DOO2: LDAX D ; transfert le P-name MOV M,A INX D ; avance dans P-name INX H ; avance en filename DCR C ; compte filename JZ DOO3 ; le P-name est fini DCR B ; compte P-name JNZ DOO2 ; comtinue DOO3: XRA A ; numero du disque STA FCB.OU ; = 0 (i.e. A:) STA FCB.OU+12 ; idem pour file ext STA FCB.OU+13 ; -- STA FCB.OU+14 ; -- STA FCB.OU+15 ; -- LXI D,FCB.OU; adresse du FCB MVI C,19 ; code DELETE CALL BDOS ; on detruit le fichier s'il existait deja. LXI D,FCB.OU; adresse du FCB MVI C,22 ; code du CREATE CALL BDOS ; appel de CP/M CPI 255 ; -1 si erreur. JZ DOO8 ; ca va pas (ret NIL et non disque). XRA A ; 0 = numero du 1er STA FCB.OU+32 ; enregistrement a ecrire. JMP DOO9 ; vers le retour OK. .ENDC ; de CPM .IFNE TRSDS2 LXI D,10 ; offset p-len DAD D ; HL <- pointeur P-len MOV B,M ; B <- P-len INX H ; Hl <- pointeur P-name MVI C,60 ; taille max filename LXI D,FCB.OU; adresse filename XCHG ; Hl <- filename, DE <- p-name DOO2: LDAX D ; transfert p-name MOV M,A INX H ; avance en ffilename INX D ; avance en pname DCR C ; compte filename DCR B ; compte p-name JNZ DOO2 ; il en reste MVI M,$0D ; force un dernier return (dixit TRSDS2) DOO3: MVI M,' ' ; padd avec des spaces (dixit TRSDS2) DCR C ; compte filename JP DOO3 ; remplit tout. ;;; prepare le OPEN (FPL.OU) LXI H,BUF.OU; adresse du buffer physique SHLD FPL.OU LXI H,BUFOU ; adresse du buffer logique SHLD FPL.OU+2 LXI H,0 ; pas de traitement special SHLD FPL.OU+4; en cas de EOF MVI A,'W' ; access type STA FPL.OU+6; en ecriture MVI A,1 ; taille de l'enregisstrement STA FPL.OU+7; logique MVI A,'F' ; en format fixe STA FPL.OU+8 MVI A,2 ; OPEN NEW STA FPL.OU+9 XRA A ; user attribute STA FPL.OU+10 LXI D,FCB.OU; prepare le OPEN LXI H,FPL.OU; avec ses 2 blocs MVI A,40 ; code du OPEN RST 1 ; appel SVC JZ DOO9 ; tout c'est bien passe. JMP DOO8 ; ca va pas! .ENDC ; de TRSDS2 ;;; Si le fichier n'a pas ete correctement ouvert DOO8: XRA A ; indique pas de sortie STA ODSK ; sur disque JMP FALSE ; et retourne NIL (indique une erreur). ;;; Si le fichier a ete corrctement ouvert DOO9: MVI A,1 ; indique sortie sur STA ODSK ; disque. LXI H,BUFOU ; adresse debut du buffer SHLD OUBPT ; dans le pointeur courant. JMP TRUTH ; et retourne vrai! .IFF ; de FILE DOO0: JMP TRUTH; c'est un terminal. .ENDC ; de FILE .PAGE .SBTTL; Fnts K7 : (INTAPE i) (OUTPUTAPE i) (CLOAD) (CSAVE) ;***** (INTAPE I) [SUBR 1] ; SI I=T SELECTE LA K7 EN ENTREE .IFNE K7 KIOI: LXI D,IK7 ; ADR INDIC K7 INPUT KIOI0: MVI B,0 ; INDIC = FAUX (NIL) MOV A,H CPI HNIL ; TEST 1ER ARG ? JZ KIOI1 ; C'EST = A NIL. INR B ; B#0 = # DE NIL KIOI1: MOV A,B ; A <- LA VAL DE L'INDIC STAX D ; ARNGE L'INDIC RET .ENDC ; de K7 ;***** (OUTPUTAPE I) [SUBR 1] ; SI I=T SELECTE LA K7 EN SORTIE .IFNE K7 KOOI: LXI D,OK7 ; ADR INDIC K7 OUTPUT JMP KIOI0 ; LE RESTE EST IDEM. .ENDC ; de K7 .PAGE ;***** (CLOAD) [SUBR 0] ;***** (CSAVE) [SUBR 0] .IFNE K7 ; TEST POINT MEM DUMP TELST: INX H ; POINT SUR MOT SUIVANT MOV A,H CPI HELST ; C'EST LA FIN ? RNZ ; NAN MOV A,L CPI ..FLST & $FF ; VRAIMENT LA FIN ? RNZ ; NAN XRA A ; 0 <- A CALL $1F8 ; CASSETTE OFF. JMP REENM ; REENT AVEC MSG ;----- CHARGE UNE IMAGE MEMOIRE CLOAD: XRA A ; NO DE DRIVE CALL $212 ; DEFINE DRIVE CALL $296 ; FINF SYNC BYTE LXI H,NIL ; DEBUT RECEPTION CLOA1: PUSH H ; SAUVE LE POINT CALL $235 ; READ BYTE POP H ; RECUP LE POINT MOV M,A ; CHARGE LA MEMOIRE CALL TELST ; FIN ZONE ? JMP CLOA1 ; NAN ;----- SAUVE UNE IMAGE MEMOIRE CSAVE: XRA A ; NO DE DRIVE CALL $212 ; DEFINE DRIVE CALL $287 ; WRITE LEADER LXI H,NIL ; DEBUT ZONE SOURCE CSAV1: PUSH H ; SAUVE L'@ MOV A,M ; OCTET A ECRIRE CALL $264 ; ECRITURE SUR K7 POP H ; RECUP L'ADRESSE CALL TELST ; C'EST LA FIN ? JMP CSAV1 ; NAN .ENDC ; de K7 .PAGE .SBTTL; Fnts systeme : (CALL adr a1 a2) (EXECUTE l) ;----- CALAD : calcul la valeur reelle d'une adresse sous la forme (high low) ; HL <- (h l); CALL CALAD; detruit BC CALAD: RFLST H ; l'adresse n'est pas une liste. INR L ; saute high de high MOV B,M ; A <- val de high INR L ; MOV A,M INR L MOV L,M MOV H,A ; HL <- (low) INR L ; sauet high de low MOV L,M ; L <- val de low MOV H,B ; H <- val de high RET ;***** (LOC s) [SUBR 1] ; retourne l'adresse de l'objet s ; dans sa forme etendue (high low) systematiquement. FADRES: PUSH H ; sauve H MOV A,L ; poids faibles CALL CRANA ; conversion entieres CALL NCONS ; fabrique (low) XTHL ; H <-> (low) MOV A,H ; poids forts CALL CRANA POP D ; HL = high, DE = (low) JMP CONS ; et retourne (high low) ;***** (VAG adr) [SUBR 1] ; retourne l'objet lisp d'adresse adr ; (VAG (LOC x)) == x FVAG=CALAD ; et oui c'est tout .PAGE ;***** (CALL adr . VALS) [SUBR N] FCAL: LXI B,.CAL ; en cas d'erreur MOV A,H ; test 0 arg INR A JZ ERRTA ; n'importe quoi XCHG ; DE <- le premier arg POP H ; le pointeur sur la fin, on n'en a pas besoin POP H ; au suivant MOV A,H ; test 1 arg INR A JZ EXAD ; c'est une 0subr, l'execute MOV B,D ; BC <- le premier arg MOV C,E XCHG ; DE <- le deuxieme POP H ; au suivant MOV A,H ; test 2 args INR A JZ EXAD1 ; c'est une 1SUBR XCHG ; DE <- arg 3 HL <- arg 2 XTHL ; au suivant MOV A,H ; test 3 args INR A JZ EXAD2 ; c'est une 2subr XCHG ; DE <- arg 4 HL <- arg 3 SHLD A4 ; fait de la place POP H ; recupere arg 2 XTHL ; le re-echange MOV A,H ; test 4 args INR A JZ EXAD3 ; c'est une 3subr LXI B,.CAL ; c'est quoi, on se le demande LXI H,NIL JMP ERRTAP ; vers l'erreur EXAD3: LHLD A4 ; recupere l'avant-dernier XTHL ; c'est le premier de la subr PUSH H ; le deuxieme EXAD2: EXAD1: PUSH B ; sauve le premier arg (commun) XCHG ; HL <- l'adresse CALL CALAD ; calcule l'adresse XTHL ; place le premier arg RET ; et execute la subr EXAD: ; appel d'une 0subr XCHG CALL CALAD ; calcule l'adresse PCHL ; l'execute .PAGE ;***** (CALLN adr ) [SUBR 2] ; ; appelle une NSUBR avec la liste en arguments CALLN: XCHG ; DE <- la liste POP H ; l'adresse CALL CALAD ; la desinterne MOV B,H ; dans BC MOV C,L JMP APNS ; et c'est un apply d'une NSUBR ;***** (EXECUTE liste-d'octets) [SUBR 1] ; charge du code en zone atome et lance l'execution. ; le code doit se terminer par l'instruction RET (#C9) .IFNE BIG XCT: RFLST H ; Il faut absolument une liste. XCHG ; DE _ listinstrcut LHLD CATOC ; HL _ @ fin zone atome courante. PUSH H ; qui sera l'adresse de lancement. MOV B,H ; TRANSFEREE DANS MOV C,L XCHG ; HL <- LA XCT1: INR L MOV A,M ; A- L'OCT DE VALEU STAX B ;RGE EMEMOIRE INX B ; MEMOIRE SUIVANTE INR L MOV A,M INR L MOV L,M MOV H,A ; HL <- CDR HL CPI HNIL ; IL EN RESTE ? JNZ XCT1 ; OUAIP. MVI A,$C9 ; CODE DE L'INSTRUCTION 'RETURN' STAX B ; on sait jamais. RET ; tombe sur CATOC et GO. .ENDC ; de BIG .PAGE ;***** (CSTACK n) [SUBR 1] CSTAK: PUSH H ; sauve le nombre CALL NCNSN ; doublet d'init POP D ; recupere le nombre PUSH H ; pour le retrouver a la fin XCHG ; HL <- nombre presume', DE <- doublet LXI B,$7FFF ; a priori c'est NIL JTNIL H,CSTAS ; si c'est nil on prend tout LXI B,.CSTAK ; en cas d'erreur CALL VALNB ; prend la valeur MOV B,H ; dans BC MOV C,L CSTAS: LHLD PBIND ; pointe sur dernier bloc XCHG ; dans DE CALL CSTAB ; ca roule, en zone P POP H ; recupere le premier doublet JMP CDRNT ; et l'oublie .PAGE .SBTTL; Fnts systeme : (SYSTEM) (VERSION) (END) ;***** (VERSION) [SUBR 0] VERSF: LXI H,VERSNB ; numero de l aversion JMP CRANB ; et on l'interne ;***** (SYSTEM) [SUBR 0] ; retourne la famille de l'interprete .IFNE BIG SYSTM: LXI H,.SYSTM ; ato .ENDC ; de BIG RET .ENDC ; [Jerome] ;***** (END) [SUBR 0] ; termine l'interprete. ASTOP: CALL COLEOL ; vidage de la derniere ligne. CALL OUTSS .IFNE FRANZ .ASCII 'Que Le_Lisp soit avec vous' .BYTE $D,$A,0 .IFF .ASCII 'Let Le_Lisp be with you.' .BYTE $D,$A,0 .ENDC .IFNE MDS MVI C,9 ; EXIT SYSTEM CALL. LXI D,EXBLK ; BLOCK DE CONTROLE DU EXIT. CALL $40 ; APPEL DE ISIS. HLT ; ON SAIT JAMAIS. EXBLK: .ADDR EXSTT ; BLOCK DE CONTROLE (ISIS) EXSTT: .BLKB 2 ; STATUS. ; 4 - 1000l$$1000t$$ .ENDC ; de MDS .IFNE MZ80 JMP $E127 ; RETOUR A DDT 80 .ENDC ; de MZ80 .IFNE TRS .IFNE TRSDOS JMP $402D ; retour tiede de TRSDOS .ENDC .IFEQ TRSDOS JMP 0 ; vers le >READY froid .ENDC .ENDC ; de TRS .IFNE SDK80 JMP 8 ; RETOUR DU MONITEUR .ENDC ; de SDK80 .IFNE SOR JMP $E003 ; WARM start du Moniteur .ENDC .IFNE TRSII MVI A,3 ; fonction BREAK LXI H,0 ; inactive. RST 1 ; RST 8 Zilog MVI A,36 ; fonction JP2DOS RST 1 ; RST 8 Zilog; HLT ; on sait jamais .ENDC .IFNE CPM MVI C,0 ; le code du system reset MVI E,0 ; le code retour (indique tout est ok) CALL BDOS ; et voila!. .ENDC .IFNE LEBLAN JMP 0 .ENDC HLT ; des fois qu'il manque un IF .PAGE .SBTTL; CONS et Garbage Collector et (GC) ;-------------------------------- ; LES CONSEURS DE LISTES ;-------------------------------- NCNSN: ; (CONS NIL NIL) LXI H,NIL NCONS: ; (CONS HL NIL) LXI D,NIL CONS: ; (CONS HL DE) XCHG XCONS: ; (CONS DE HL) MOV B,H ; RANGE LE CDR DANS BC MOV C,L BCONS: ; (CONS DE BC) JTNUM B,ERBONS ; LE CDR NE PEUT PAS ETRE ACTUELLEMENT ; UN NOMBRE ... BNCNS: LHLD FREEL ; RECUP LE POINT DE LISTE LIBRE. MOV A,H ; TEST FIN LISTE LIBRE (00) ORA L ; H&L = 0. CZ GCOL ; VERS LE G.C. PUSH H ; SAUVE LE RESULTAT DU CONS. MOV M,D ; CHARGE CAR. INR L MOV M,E INR L MOV D,M ; CHARGE LE CDR ET RECUPERE MOV M,B ; le nouveau FREEL INR L MOV E,M MOV M,C XCHG ; L <- NEW FREEL. SHLD FREEL ; QUE L'ON RNGE. POP H ; RECUP LE RESULT DU CONS. RET ; VOILA. .PAGE ;------------------------------ ; GARBAGE - COLLECTING ;------------------------------ GCOL: PUSH D ; Sauve les arguments du CONS. PUSH B LHLD SELFM ; sauve les pseudo-registres PUSH H LHLD FONCT PUSH H LHLD FNTEV PUSH H LHLD AL PUSH H ;----- MARQUAGE DE LA PILE LXI H,0 DAD SP ; HL <- SP. GCOL1: MOV E,M INX H MOV D,M ; DE <- element suivant de la pile. INX H ; attention aux frontieres de HL. MOV A,D ; c'est un indicateur qui est empile ? INR A ; (ils commencent toujours pas $FF) CNZ MARK ; nan : on marque donc. MOV A,H CPI < BSTAK ^ > ; fin pile ? JC GCOL1 ; nan : continue. .PAGE ;----- MARQUAGE DE L'OBLIST LHLD CATOL ; premier atome GCOL2: MOV D,M INR L MOV E,M ; DE <- C.VAL CALL MARK INR L MOV D,M INR L MOV E,M ; DE <- P.LIST. CALL MARK ; QUE L'ON MARQUE. INX H ; ACHUNG : FRONTIERE DE H MOV E,M ; DE <- LA F-VAL INR L ; QUI EST TOUJOURS MOV D,M ; E A L'ENVERS ,, H). CALL MARK ; que l'on marque. INR L ; pointe sur le F-TYP INR L ; pointe sur le P-TYP INX H ; pointe sur le A-LINK MOV A,M ; LSB A-LINK INR L ; MOV H,M ; MSB A-LINK MOV L,A ORA H ; fin OBLIST ? JNZ GCOL2 ; nan. ;;; CREATION NOUVELLE LISTE LIBRE. LXI H,BLIST ; DEBUT ZONE LISTE. LXI D,0 ; NEW FREEL. JMP GCOL4 ; en voiture .PAGE ;----- CREATION DE LA NOUVELLE LISTE LIBRE GCOL7: MOV M,E ; RPLACD HL AVEC DE DCR L MOV M,D INR L MOV D,B MOV E,C ; DE <- NEW FREEL. INX H ; frontiere ADROV2=. + 2 JTOVN H,GCOL6 ; c'est fini GCOL4: MOV B,H ; BC <- HL MOV C,L ; i.e. doublet courant INR L INR L INR L MOV A,M RAR ; MARQUE ? JNC GCOL7 ; NAN. CMC ; CY <- O RAL ; POSITIONNE LE 0 MOV M,A ; C'EST DEMARQUE. GCOL5: INX H ; ACHTUNG : FRONTIERE DE H. ADROV3=. + 2 JFOVN H,GCOL4 ; SI PAS FIN ZONE LISTE. .PAGE ;----- ACTUALISATION DES VARIABLES DU GC GCOL6: LHLD GCNBR INX H SHLD GCNBR ; ACTUALISE LE NB DE GC. XCHG ; HL <- new freel SHLD FREEL ; tete de la liste libre. CALL LENGT ; calcul sa longeur SHLD FREES ; rangee dans FREES. LXI D,GCOLF ; prepare le retour LXI B,.GCALR ; la fonction GCalarm JMP CLFC1 ; appel de funcall avec 1 arg pour la fonction GCOLF: POP H ; RESTAURE LES PSEUDO REGISTRES SHLD AL POP H SHLD FNTEV POP H SHLD FONCT POP H SHLD SELFM ; ET VOILA POP B ; RECUP LES RGS DU CONS. POP D LHLD FREEL ; new freel MOV A,H ; on en a recupere ? ORA L RNZ ; oui: continue le CONS. JMP ERFM ; nan : erreur terrible. .PAGE ;----- MARK D&E DOIT SAUVER H&L MARK: RFLST D ; RETURN SI DE N'EST PAS UNE LISTE. XCHG ; faut le mettre dans HL ADROV4=. + 1 CPI HELST ;c'est un OVNI ? JNC MARK9 ; oui ! PUSH D ; SAUVE OLD H&L CALL MARK2 ; MARQUE LA LISTE. POP H ; RESTAURE H&L RET ; VOILA. MARK9: ;;; OBJET LE LISP NON IDENTIFIE (dans H)! PUSH H ; sinon sauve tout PUSH D ; encore CALL PRHEX ; imprime l'OVNI en hexa POP D ; recupere tout. POP H ; encore RET ; et voila. .PAGE ;------ MARQUAGE D'UNE LISTE MARK0: PUSH H ; SAUVE LE CDR. CKSTK ERFSG ; LA PILE NE RESISTE PAS!!!!! XCHG ; HL <- LE CAR CALL MARK2 ; ON LE MARQUE. POP H ; RECUP LE CDR. MARK1: ;;; MARQUE HL (N'IMPORTE QUOI). RFLST H ; UN ATOME NE SE MARQUE PAS. ADROV5=. + 1 CPI HELST ; c'est un OVNI ? JNC MARK9 ; oui ! MARK2: ;;; MARQUE LA LISTE H&L. MOV D,M ; DE <- (CAR HL) INR L MOV E,M INR L MOV B,M ; BC <- (CDR HL) INR L MOV C,M MOV A,C ; POUR TEST BIT MARK. RAR ; CARRY <- BIT MARK. RC ; IL EST DEJA MARQUE. STC ; PREPARE LE BIT DE MARK RAL ; QUE L'ON MET EN POSITION. MOV M,A ; ON LE RANGE EN MEMOIRE. MOV H,B ; HL <- BC (I.E. LE CDR DE HL) MOV L,C JFLST D,MARK1 ; LE CAR EST ATOMIQUE, ITERE SUR CDR. ADROV6=. + 1 CPI HELST ; c'est un OVNI ? JC MARK0 ; nan, ok. MARK8: ;;; OBJET LE LISP NON IDENTIFIE (dans D)! XCHG ; pour utiliser MARK9 CALL MARK9 XCHG RET ; et voila. .PAGE ;**** (GC) [SUBR 0] RAMENE LE NB DE DOUBLETS LIBRES. GCF: LXI B,0 ; remet a 0 les 2 arg du CONS ! LXI D,0 ; Merci Gerard. CALL GCOL ; PUIS ON RAMASSE. LHLD FREES ; ce qu'on a recupere RET ; on le retourne ;***** (GCALARM e) [SUBR 1] ; cette fonction n'existe que pour etre redefinie ; elle retourne son argument en standard GCALR: JMP FALSE .IFNE TGC SPKM1: .ASCII '(GC1)' .BYTE 0 SPKM2: .ASCII '(GC2)' .BYTE 0 SPKM3: .ASCII '(GC3)' .BYTE 0 .ENDC ; de TGC ;***** () [SUBR1] ; ;----- ajustement de la taille de la zone liste .IFNE CPM ADJST: ; entree de la fonction de RESET MOV A,H ; test d'un argument CPI HNIL MOV A,L ; a priori oui JNZ ADJST1 ; oui ADJST0: LDA 7 ; adresse du bas de cp/M ADJST1: DCR A ; a cause de JC STA ADROV1 ; et on modifie le code ! STA ADROV2 STA ADROV3 STA ADROV4 STA ADROV5 STA ADROV6 RET ; retourne son arg .ENDC ; de CPM .PAGE .SBTTL; Manip des nbs : VALNB: VALN2: CRANB: CRANA: ;------------------------------------- ;----- MANIPULATIONS DES NBS ENTIERS. ;------------------------------------- .IFNE MZ80 ! SDK80 ; 0000 SXXX XXXX XXXX (+- 2048) VNBS=$08 ; SIGN VNBX=$F8 ; SIGN EXTEND VNBM=$0F ; MASK VALUE VNBH=$00 ; HIGH VAL .ENDC ; de MZ80!SDK80 .IFNE SOR ; 000S XXXX XXXX XXXX (+- 4096) VNBS=$10 ; SIGN VNBX=$F0 ; SIGN EXTEND VNBM=$1F ; MASK VALUE VNBH=$00 ; HIGH VAL .ENDC ; de SOR .IFNE MICRAL!MDS32!TRS80!TRC80!IMSAI!H89CPM!Z89CPM!SILZ!LOGAX ; 00SX XXXX XXXX XXXX (+- 8192) VNBS=$20 ; SIGN VNBX=$E0 ; SIGN EXTEND VNBM=$3F ; MASK VALUE VNBH=$00 ; HIGH VAL .ENDC ; de MDS32 ! TRS80 ! TRC80 ! IMSAI ! H89CPM ! Z89CPM .IFNE MDS64 ! TRE80 ! TRD80 ! TRP80 ! TRSII ! LEBLAN ; 0SXX XXXX XXXX XXXX (+- 16192) VNBS=$40 ; SIGN VNBX=$C0 ; SIGN EXTEND VNBM=$7F ; MASK VALUE VNBH=$00 ; HIGH VAL .ENDC ; de MDS64 ! TRE80 ! TRD80 ! TRP80 ! TRSII ! LEBLAN ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;!!! ATTENTION : IL NE DOIT PLUS Y AVOIR !!! ;!!! DE CONDITIONNELS DE TYPE MAP-MEMOIRE !!! ;!!! (I.E. MDS, MZ, MCS, TRS ...) !!! ;!!! APRES CETTE LIMITE. !!! ;!!! !!! ;!!! TOUT LE CODE SUIVANT EST DONC COMMUN !!! ;!!! A -TOUS- LES SYSTEMES. !!! ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! .PAGE ;----- Recuperation de la valeur d'un pointeur numerique. ; HL <- valeur(HL) & A <- les poids forts de cette valeur. ; BC contient le nom de la fonction quidemande ; la conversion, ca sert pour les erreurs. ; VALNB : fait ca pour HL ; VALNX : fait ca pour DE, resultat dans HL ; VALN2 : fait ca pour les 2 VALN2: XCHG ; VALEURS DE (DE) & (HL) VALN2X: CALL VALNB VALNX: XCHG VALNB: JFNUM H,VALNIT ; faut un nombre ou NIL ANI VNBS ; test du bit de signe MOV A,H ; recharge A pour le retour. RZ ; NB >= 0 : le pointeur est pret ORI VNBX ; sinon on propage le signe. MOV H,A ; dans H RET ; et c'est tout! VALNIT: CPI HNIL ; c'est bien NIL ? JNZ ARGNNB ; nan VALNIL: XRA A ; NIL = 0 dans toutes les operations arithmetiques! MOV H,A MOV L,A ; A=0, HL=0. RET ;----- Creation d'un pointeur numerique (internement d'un nb) ; CRAZR: interne la valeur 0 ; CRANA: interne l'octet A ; CRANX: interne la valeur DE dans HL ; CRANB: interne la valeur de HL dans HL ; BC contient le nom de la fonction si debordement ; (c'est souvent sur que ca n'arrive pas) CRAZR: XRA A ; A <- 0. CRANA: MOV L,A ; creation de l'octet dans A MVI H,VNBH RET CRANX: XCHG ; CREATION DE LA VAL DS D&E. CRANB: MOV A,H ; CREATION DE LA VAL DS H&L. ANI VNBX ; NB >= 0 (SS OVFL) ? RZ ; OUSIP. CPI VNBX ; OVFL ? CNZ TOVFA ; OUAIP. MOV A,H ANI VNBM ; ENLEVE LES N DERNIERS BITS. MOV H,A ; DANS H. RET .PAGE .SBTTL; Fonctions numeriques ;----- Complement de DE : DE <- -DE .IFNE ZILOG .IFF CMPDE: MOV A,D CMA MOV D,A MOV A,E CMA MOV E,A INX D ; Pour le complement a 2 RET .ENDC ;----- Complement de HL : HL <- -HL CMPHL: MOV A,H CMA MOV H,A MOV A,L CMA MOV L,A INX H ; pour le complement a 2 RET ;----- calcule le signe de 2 termes : -> SIGN ; BC contient le nom de la fonction si erreur CSGNX: XCHG CSGN: XRA A ; signe = 0 STA SIGN CALL CSGN1 LDA SIGN ANI 1 ; calcule le OUX. STA SIGN ; on le range RET CSGN1: XCHG CALL CSGN2 ; POUR H&L XCHG ; PUIS POUR D&E CSGN2: CALL VALNB ; RECUP LA VAL DU NB ORA A ; TEST D RP ; SI >= 0. LDA SIGN INR A STA SIGN JMP CMPHL ; vers negate .PAGE ;----- HL <- HL * DE sans signe (SUR 16 BITS) .IFNE ZILOG MLT: MVI B,16 ; nb d'iterartions MOV C,D ; A,C <- *TEUR MOV A,E XCHG ; DE - *AND. LXI H,0 ; raz result MLT1: .BYTE $CB,$39 ; SRL C .BYTE $1F ; RR A .BYTE $30,$01 ; JRC MLT2 DAD D ; sinon additionne MLT2: XCHG DAD H ; decal XCHG .BYTE $10,$F5 ; DJNZ MLT1 RET .IFF MLT: MOV B,H ; B,C <- *teur MOV C,D ; A,C <- *teur MVI H,0 ; 0. MVI A,16 ; compteur de boucle. MLT1: PUSH PSW ; sauve le compteur. MOV A,B RAR MOV B,A ; DOUBLE SHIFT RIGTH BC. MOV A,C RAR MOV C,A JNC MLT2 DAD D MLT2: XCHG DAD H ; DE <- DE SHIFT LONG LEFT XCHG POP PSW ; RECUP LE compteur DCR A ; encore ? JNZ MLT1 ; ouiap. RET .ENDC ; ZILOG .PAGE ;----- HL <- HL/DE DE <- HL\DE (SS SIGNE SUR 16 BITS) DVD: MOV B,H ; BC <- DIVIDEND. MOV C,L .IFNE ZILOG LXI H,0 ; POUR LA SOUSTRACT ORA A ; CARRY <- 0 .BYTE $ED,$52 ; SBC DE (ZILOG) XCHG ; DE <- - DE .IFF CALL CMPDE ; QUO <- - QUO. .ENDC ; ZILOG LXI H,0 MVI A,17 ; LOOP COUNTER. DVD0: PUSH H ; SAUVE LE RESTE. DAD D ; SOUSTRAIS LE DIVISEUR. JNC DVD1 ; UNDERFLOW, RESTAORE HL. XTHL DVD1: POP H ; RECUPERE LE RESTE. PUSH PSW ; sauve loop counter MOV A,C RAL MOV C,A MOV A,B ; CY -> C -> B -> L -> H. RAL MOV B,A MOV A,L RAL MOV L,A MOV A,H RAL MOV H,A POP PSW ; RECUP COMPTEUR. DCR A ; IL EN FAUT ENCRE ? JNZ DVD0 ; OUSIP ORA A ; CARRY <- 0. MOV A,H ; ARRANGE LE RESTE. RAR MOV D,A MOV A,L RAR MOV E,A MOV H,B ; POSIT LE QO. MOV L,C RET .PAGE .SBTTL; Fnts graphiques : (CLEAR n) (DISPLAY n l) (POINT x y t) (WINDOW n) .IFNE EDITRS ;***** (CLEAR n) [SUBR 1] efface tout l'ecran avec n CLS: MOV A,L ; A <- le caractere a forcer dans l'ecran! LXI H,$3C00 ; debut ecran. MOV M,A ; force le 1er caractere LXI D,$3C01 ; debut recept. LXI B,1023 ; nb de caracteres restants LDIR ; efface tout. JMP TRUTH ; et retourne toujours T! ;***** (DISPLAY N L) [SUBR 2] ; envoie la liste de code interne L sur l'ecran a la position N ; si l est un atome, il est simplement PRINee ... ; (qui commence a 0) DISPL: PUSH H ; sauve tout MVI A,$F ; cursor off! CALL $33 ; on le donne au systeme. POP D ; restaure tout. POP H ; et voila. MOV A,H CPI HNIL ; ya un 1er argument. JRNZ DISP1 ; ouaip. LHLD CURSYS ; nan : alors on prend le curseur systeme JMPR DISP3 DISP1: PUSH D ; sauve la liste. MOV A,H ANI 3 ; adresse modulo 1024 MOV H,A LXI D,$3C00 ; debut de la memoire video. DAD D ; HL <- @ reelle POP D ; recupere L DISP3: SHLD CURSYS ; force la nouvelle adresse du curseur. XCHG ; DE <- @, HL <- L MOV A,H CPI HNIL ; ya rien ? JRZ DISP7 ; c'est donc fini : retourne le pointeur. JTLST H,DISP5 ; c'est une liste de code internes. ;;; c'est donc un atome. LDA LBCOU ; pour ne pas toucher a LBCOU, PUSH PSW ; on le sauve. CALL PROBJ ; appel de l'impression interne. POP PSW ; pour restaurer STA LBCOU ; apres comptage. LHLD CURSYS ; retourne le pointeur courant. JMPR DISP8 ; et c'est fini. DISP5: JFLST H,DISP7 ; fin de la liste des codes. INR L MOV A,M ; recup la valeur numerique. STAX D ; qui est rangee de suite, INR L MOV A,M INR L ; HL <- CDR HL MOV L,M MOV H,A INX D ; avance en memoire video. PUSH D CALL CS ; test du hold : qch de frappe ? POP D ORA A JNZ REENM ; ya eu qch de frappe : j'arrete tout. MOV A,D CPI $40 ; fin mem video ? JRC DISP5 ; nan : on peut continuer. DISP7: XCHG ; HL <- la prochaine adresse DISP8: SHLD CURSYS ; rangee dans le curseur systeme LXI B,-$3C00; pour retourner l'adresse relative DAD B JMP CRANB ; conversion numerique. ;**** (POINT X Y T/NIL) [3SUBR] ----------- ; utilise le pseudo-graphique du TRS80 / do / d1 / ; si T : allume le point X,Y / d2 / d3 / ; si NIL : etteint le point X,Y / d4 / d5 / ; forme d'un mot memoire : 1 x d5 d4 d3 d2 d1 d0 ----------- ; @ de mot = (Y/3)*64+(X/2) POINT: XCHG ; type <-> Y XTHL ; pile <- T/NIL, HL <- X, DE <- Y XCHG ; HL <- Y, DE <- X MOV A,L ; poids faibles de Y ANI $3F ; modulo 64 CPI 48 ; Y max = 47 (16*3) JRC PNT1 ; ca gaze. MVI A,47 ; Y max si on sort. PNT1: MVI L,-1 ; L <- Y / 3 le quotient PNT2: INR L SUI 3 ; division par 3 JRNC PNT2 ; par soustractions succesives. ADI 3 ; repasse en positif MOV B,A ; B <- Y \ 3 le reste. MOV A,E ; poids faibles X ANI 1 ; modulo 2 MOV C,A ; C <- X \ 2 le reste. MOV A,E ; poids faibles de X RRC ; division par 2 ANI $3F ; modulo 64 MOV E,A ; E <- X / 2 le quotient. ;;; calcul @ du mot de la zone ecran. MVI H,0 ; HL <- Y/3 MOV D,H ; 2 high = 0 DAD H ; * 2 DAD H ; * 4 DAD H ; * 8 DAD H ; * 16 DAD H ; * 32 DAD H ; * 64 DAD D ; (Y/3)*64+(X/2) LXI D,$3C00 ; debut de la zone ecran DAD D ; HL <- adresse reelle. ;;; calcul du masque MVI A,1 ; debut du masque DCR C ; bit gauche ou droit JRNZ PNT6 ; touche pas. RAL JMPR PNT6 PNT5: RAL ; change de ligne. RAL ; 2 points / lignes PNT6: DCR B ; ancien reste. JP PNT5 ; 1 ou 2 fois. MOV D,A ; D <- le masque pret. POP B ; recup l'indicateur T/NIL MOV A,B ; poids forts CPI HNIL ; c'est NIL JRZ PNT8 ; oui : vers l'effacement. ;;; allumage du point. MOV A,M ; A <- l'ancien mot de l'ecran. ORA D ; force le nouveau bit. PNT7: ORI $80 ; reforce le bit graphique! MOV M,A ; range en memoire ecran. JMP TRUTH ; et retourne T ;;; eteindre le point. PNT8: MOV A,D ; A <- le masque. CMA ; A <- non A ANA M ; enleve le bit! JMPR PNT7 ; le reste est identique. ;***** (WINDOW n) [1SUBR] ; reserve n lignes au debut de l'ecran. WIND: MOV A,L ; A <- le nb de lignes a preserver LXI B,64 ; taille d'une ligne LXI H,$3C00 ; adresse du debut de l'ecran ANI $0F ; modulo 16 lignes. JRZ WIND3 ; pas de modifications. WIND2: DAD B ; adresse + 1 ligne DCR A ; encore ? JRNZ WIND2 ; ouiap. WIND3: SHLD WINREC ; sauve l'adresse du vrai debut de l'ecran. SHLD CURSYS ; qui devient la position courante du systeme LXI D,$3FFF-64 ; taille du transfert XCHG ; HL <- la taille, DE <- adresse ORA A ; CY = 0 .BYTE $ED,$52 ; SBC DE de ZILOG SHLD WINSIZ ; sauve la taille du transfert de la fenetre MVI L,$80 ; caractere graphique null! JMP CLS ; et efface tout l'ecran. .ENDC ; de EDITRS .PAGE .SBTTL; Editeur Video : (EDITV) ou & ;************************** ;*** EDITEUR VIDEO *** ;************************** .IFNE EDITRS EDSTR=. ; debut du code de l'editeur video ;----- EDSW : swap la memoire de l'ecran et sa sauvegarde. EDSW: LXI H,$3C00 ; adresse de la memoire ECRAN LXI D,ECRAN ; adresse de la sauvegarde EDSW1: LDAX D ; A <- mot de la sauvegarde MOV B,M ; sauve dans B MOV M,A ; A <- le mot de l'ecran MOV A,B STAX D ; met dans la sauvegarde l'ancien ecran INX H ; avance dans l'ecran INX D ; avance dans la sauvegarde MOV A,H ; test de fin CPI $40 ; de la memoire ecran. JRC EDSW1 ; nan : continue. RET ; c'est fini. ;***** (EDITV n) [SUBR 1] ; si n = -1 doit editer l'ecran LE LISP EDF: INR L ; l'argument = -1 ? JRNZ EDF1 ; nan : normal. LXI H,$3C00 ; adresse emet. LXI D,ECRAN ; adresse recept. LXI B,1024 ; taille page LDIR ; ecran LE LISP -> memoire de sauvegarde. EDF1: CALL EDSW ; swap sauvegarde et ecran. LXI H,$3C00 ; position actuelle du pointeur SHLD CURS ; en position HOME. ;;; le top-level doit suivre. ; TOP-EVEL EDITEUR EDTOP: CALL EDL ; LIRE UNE COMMANDE LHLD CURS ; POUR PREPARER LES APPELS CALL ED0 ; VERS LES DECODAGES. MOV A,H ; VERIF DU NOUVEAU CURSEUR. CPI $3C ; SORT VERS HAUT ? CC CD.H ; oui : position HOME CPI $40 ; SORT VERS LE BAS ? JRC EDS3 ; NAN LXI H,$3FFF ; OUAIP : EN BAS. EDS3: SHLD CURS ; RANGE LE POINTEUR. JMPR EDTOP ; CA ROULE ... ; FIN DE L'EDITEUR (APPELLE PAR shift/V, shift/E ou BREAK) EDFS: POP B ; enleve l'adresse de retour de ED0: CALL EDSW ; sauve l'ecran et la sauvegarde. JMP TRUTH ; (EDITV) RAMENE T ? AH BON ? ;----- LECTURE D'UN CARACTERE DE COMMANDE EDL: LHLD CURS ; RECUP LE CURSEUR ; clignote en HL (utilise par TYI si EDITRS) CLIGN: MOV A,M ; SAUVE LE CARACTERE COURANT MVI M,$F0 ; AFFICHE UN CURSEUR CPI $20 ; C'est un espace ? JRZ EDL2 ; ouaip : il faut pas blinker! CPI $1F ; C'est le curseur standard ? JRZ EDL2 ; idem. MVI B,50 ; POUR LE VOIR UN PEU EDL1: DCR B JRNZ EDL1 ; C'EST VU. MOV M,A ; REMET L'ANCIEN CARACTERE PUSH H ; sauve la position CALL $002B ; YA UN CARACTERE DE PRET ? POP H ; recupere la position. ORA A ; ? JRZ CLIGN ; NAN : J'ATTENDS EN CLIGNOTANT LE CURSEUR RET ; A <- CONTEINT LE CARACTERE. EDL2: PUSH H ; sauve le curseur courant. CALL CIW ; lecture et attente d'un caractere. POP H ; reprend le curseur. MVI M,' ' ; et recharge l'espace. RET ; voila .PAGE .SBTTL; Editeur : decodage des commandes : EDTC: ED0: et ED.TBL: ;----- EDTC : TEST SI LE CAR SUIV EST UNE COMMANDE EDTC: SHLD CURS ; SAUVE LE CURSEUR (EN CAS DE RETOUR ED0) CALL EDL ; LECTURE DU CARACTERE SUIVANT CPI $20 ; CNTRL ? JRC EDTC1 ; OUAIP. CPI $5B ; SHIFT ? RC ; NAN : JE RENTRE EDTC1: POP B ; retire l'adresse de retour de EDTC: ;;; ED0 DOIT SUIVRE .... ;----- DECODAGE DES COMMANDES ED0: CPI 1 ; c'est BREAK ? JRZ CD.E ; equivalent a shift/E CPI $20 ; control caractere ? JRC ED03 ; ouaip : vers le BRINX CPI $5B ; speciaux & shift ? JRC ED07 ; nan : vers le traitement normal. SUI $3B ; pour une table continue de codes. ED03: CPI 8 ; les 8 1ers codes RC ; correspondent a des POPJ! SUI 8 ; la table debute a 8! LXI D,CD.TBL ; adresse de la table. EDBINX: ; branchement indirect (par DE) indexe (par A simple) ; ne touche pas a BC ni a HL! ADD A ; table de mots. EDBIND: ; branchement indirect (par DE) indexe (par A double) ; ne touche pas a BC ni a HL! PUSH H ; sauve HL XCHG ; HL <- adresse de la table, MOV E,A ; low adress MVI D,0 ; high adress DAD D ; calcul de l'adresse en table MOV A,M ; low branch adress INX H ; avance dans la table MOV H,M ; high branch adress MOV L,A ; construit l'adresse. XTHL ; HL <- l'ancien, adresse empilee. RET ; tombe sur l'adresse de lancement! ED07: ;;; caractere normal a inserer. MOV M,A ; charge le caractere INX H ; position suivante. RET CD.TBL: ; control commands ; 00 ... 07 NULL BREAK STX ETX EOT ENQ ACK BEL popj .ADDR CD.BS ; 08 BS : recule d'1 position a gauche .ADDR CD.TB ; 09 TAB : avance d'1 position a droite .ADDR CD.LF ; 0A LF : descend d'1 ligne .ADDR POPJ ; 0B VT : .ADDR POPJ ; 0C FF : .ADDR CD.CR ; 0D CR : debut de nouvelle ligne. .ADDR POPJ ; 0E CURON : .ADDR POPJ ; 0F CUROFF : .ADDR POPJ ; 10 DLE : .ADDR POPJ ; 11 DC1 : .ADDR POPJ ; 12 DC2 : .ADDR POPJ ; 13 DC3 : .ADDR POPJ ; 14 DC4 : .ADDR POPJ ; 15 NAK : .ADDR POPJ ; 16 SYN : .ADDR POPJ ; 17 ETB : .ADDR CD.CA ; 18 CAN : DELETE + left arrow .ADDR CD.EM ; 19 EM : end of line. .ADDR CD.SU ; 1A SUB : trou de 64 caracteres .ADDR CD.ES ; 1B ESC : enleve 1 ligne .ADDR POPJ ; 1C HOME : .ADDR POPJ ; 1D BOL : .ADDR POPJ ; 1E EREOL : .ADDR CD.CL ; 1F EREOF : (CLEAR) efface tout l'ecran ; shift commands .ADDR CD.UP ; 5B up arrow : 1 line up. .ADDR POPJ ; 5C print left arrow : .ADDR POPJ ; 5D print down arrow : .ADDR POPJ ; 5E print right arrow : .ADDR POPJ ; 5F print underline : .ADDR POPJ ; 60 shift @ : .ADDR CD.A ; 61 shift A : AGAIN = encore un recherche .ADDR CD.B ; 62 shift B : BACKWARD = recherche arriere .ADDR POPJ ; 63 shift C : .ADDR CD.D ; 64 shift D : DELETE = detruit 1 caractere .ADDR CD.E ; 65 shift E : EXIT = retour sans rien faire .ADDR POPJ ; 66 shift F : .ADDR CD.G ; 67 shift G : enter GRAPHIC mode .ADDR CD.H ; 68 shift H : cursor HOME .ADDR CD.I ; 69 shift I : enter INSERT mode .ADDR POPJ ; 6A shift J : .ADDR CD.K ; 6B shift K : KILL line .ADDR POPJ ; 6C shift L : .ADDR CD.M ; 6D shift M : MATCH parenthesis .ADDR POPJ ; 6E shift N : NORMAL mode (exit insert/graphique) .ADDR POPJ ; 6F shift O : .ADDR POPJ ; 70 shift P : .ADDR CD.Q ; 71 shift Q : QUOTE character .ADDR CD.R ; 72 shift R : READ file .ADDR CD.S ; 73 shift S : SEARCH character .ADDR POPJ ; 74 shift T : .ADDR POPJ ; 75 shift U : .ADDR CD.V ; 76 shift V : appel de LE LISP .ADDR CD.W ; 77 shift W : WRITE screen .ADDR POPJ ; 78 shift X : .ADDR POPJ ; 79 shift Y : .ADDR CD.Z ; 7A shift Z : positionnement fin de la page .PAGE .SBTTL; Editeur : sous-programmes des commandes ; au lancement d'une commande : ; - HL contient le pointeur courant ; au lancement d'une commande AGAIN (CD.xAG) ; - HL contient le pointeur courant ; - B contient le caractere argument ; au retour de toutes les commandes, HL doit contenir ; le nouveau pointeur (qui sera verifie pas le TOPLEVEL) ;--------------- CD.BS: ;;; 08 BS : recule d'1 caractere. DCX H ; recule le curseur RET ; et c'est tout ;--------------- CD.TB: ;;; 09 TAB : avance d'1 caractere INX H ; avance le curseur RET ; et c'est tout ;--------------- CD.LF: ;;; 0A LF : ligne suivante MOV A,L ; avance de 64 caracteres ADI 64 MOV L,A RNC ; pas de changement de H INR H RET ;--------------- CD.CR: ;;; 0D ENTER : nouvelle ligne. MOV A,L ANI $0C0 ; realise le RETURN simple MOV L,A JMPR CD.LF ; puis vers le line-feed. ;--------------- CD.CA: ;;; 18 shift/left arrow DCX H ; delete + left arrow MOV A,H CPI $3C ; si je suis en 1ere position. RC ; ya pu rien a faire. JMP CD.D ; apres c'est comme delete. ;--------------- CD.EM: ;;; 19 shift/ right arrow : passe en fin de ligne. CALL CD.CR ; simule un ENTER CD.EM1: DCX H ; et commence a reculer MOV A,H CPI $3C ; debut de l'ecran ? RC ; oui : fini. MOV A,M ; le caractere CPI ' ' ; c'est vide ? JRZ CD.EM1 ; oui : continue. INX H ; sinon pointe sur le 1er caractere libre RET ; de la ligne. ; 5 - 1000l$$1000t$$ ;--------------- CD.SU: ;;; 1A shift/down arrow : fait 1 trou de 64 caracteres MOV A,H CPI $3F ; test si fond de memoire video. RZ ; je suis trop bas LXI B,$3FFF+1 ; recepteur LXI D,$3FFF-64+1 ; source CD.SU1: DCX B DCX D LDAX D STAX B ; transfert MOV A,D CMP H ; je suis ou j'etais ? JRNZ CD.SU1 ; nan MOV A,E CMP L ; vraiment ? JRNZ CD.SU1 ; pour de rire. MVI D,64 ; pour la ligne d'espaces MVI A,' ' CD.SU2: DCX B ; fait 64 espaces STAX B DCR D ; compteur. JRNZ CD.SU2 ; encore. RET ;--------------- CD.ES: ;;; 1B shift/up arrow : enleve 64 caracteres. PUSH H ; sauve la position courante. MOV D,H ; DE <- recepteur MOV E,L LXI H,64 DAD D ; HL <- emetteur. CD.ES2: MOV A,M STAX D ; transfert mot INX H INX D ; actualise le pointeur MOV A,H CPI $40 ; fin memoire ? JRC CD.ES2 ; nan : ca roule XCHG ; HL <- recepteur CD.ES3: MVI M,' ' ; force la derniere ligne a espace INX H MOV A,H CPI $40 ; fin memoire video. JRC CD.ES3 ; nan. POP H ; nouvelle position RET ; voila ;--------------- CD.CL: ;;; 1F CLEAR efface tout l'cran. MVI L,' ' ; avec des espaces, CALL CLS ; effacement effectif. CD.H: ; equivalent CD.CL1: LXI H,$3C00 ; position HOME RET ;--------------- CD.UP: ;;; 5B UP : recule d'1 ligne MOV A,L ; recule de 64 caracteres SUI 64 MOV L,A RNC ; pas de changement de H DCR H RET ;--------------- CD.A: ;;; 61 shift/A repete la derniere commande de recherche LDA CD.ARG ; recup l'argument de la commande MOV B,A ; qui est rangee dans B. LDA CD.COM ; recup la derniere commande de recherche. LXI D,CD.TBA ; adresse des AGAIN possibles JMP EDBINX ; go indirect indexe. CD.TBA: ; table des commandes qui peuvent etre AGAIN. .ADDR CD.SAG ; 0 = SHIFT/S X .ADDR CD.BAG ; 1 = SHIFT/B X .ADDR CD.MAG ; 2 = SHIFT/M .ADDR CD.QAG ; 3 = SHIFT/Q X ;--------------- CD.B: ;;; 61 shift/B repete la derniere commande de recherche MVI A,1 ; code commande pour le AGAIN. STA CD.COM CALL EDTC ; lecture du caractere argument STA CD.ARG ; sauv l'argument de la commande (AGAIN) MOV B,A ; qui est sauve dans B. CD.BAG: PUSH H ; sauve l'ancienne position. JMPR CD.B2 ; vers la 1ere incrementation. CD.B1: MOV A,M ; caractere suivant. CMP B ; c'est cui-la ? JRNZ CD.B2 ; nan. POP B ; nettoie la pile RET ; et c'est tout. CD.B2: DCX H ; avance dans l'ecran. MOV A,H CPI $3C ; fin ecran ? JRNC CD.B1 ; nan POP H ; recup l'ancienne position RET ; et voila. ;--------------- CD.D: ;;; 64 shift/D delete 1 caractere PUSH H CD.D1: INR L MOV A,L ANI $3F ; fin de la ligne ? MOV A,M JRZ CD.D2 ; oui. MVI M,' ' ; force un espace DCR L ; recule encore MOV M,A ; reforve le caractere INR L JMPR CD.D1 CD.D2: POP H ; le curseur n'est donc pas modifie RET ;--------------- CD.E=EDFS ;;; 65 shift/E : retour sans rien faire. ;--------------- CD.G: ;;; 67 shift/G entre en mode graphique CALL EDTC ; lit et teste le caractere suivant ORI $C0 ; conversion graphique MOV M,A ; range en memoire ecran INX H ; avance le curseur JMPR CD.G ; ca roule. ;--------------- ;CD.H=CD.CL1 ;;; 68 shift/H : repositionne en tete ;--------------- CD.I: ;;; 69 shift/I entre le mode insertion. CALL EDTC ; lecture et teste du caractere suivant. PUSH H ; sauve la position courante CD.I2: MOV B,M MOV M,A ; force le nouveau caractere INR L ; MOV A,L ANI $3F ; fin de la ligne ? MOV A,B ; le caractere efface. JRNZ CD.I2 POP H ; position courante INX H ; pour le suivant. JMPR CD.I ; continue l'insertion. ;--------------- CD.K: ;;; 6B shift/K : detruit la fin de la ligne. PUSH H ; pour ne pas bouger le pointeur CD.K1: MVI M,' ' ; efface INX H MOV A,L ANI $3F ; fin de la ligne ? JRNZ CD.K1 ; nan POP H ; repositionne le pointeur. RET ; et voila. ;--------------- CD.M: ;;; 6D shift/M match parentheses CD.MAG: MVI A,2 ; code commande pour le AGAIN. STA CD.ARG ; range dans la commande. MVI B,0 ; raz le compteur de ( PUSH H ; au cas ou on ne bouge pas. CD.M1: MOV A,M ; examine le caractere suivant. CPI '(' JRNZ CD.M2 ; nan. INR B ; on incremente simplement CD.M2: CPI ')' JRNZ CD.M4 ; nan : au suivant. DCR B JM CD.M3 ; peut pas etre < 0! JRNZ CD.M4 ; mot pas ferme POP B ; recup le vieux HL RET ; et voila. CD.M3: MVI B,0 ; peut pas etre < 0. CD.M4: INX H ; adresse suivante dans la memoire video MOV A,H CPI $40 ; fin de la memoire video. JRC CD.M1 ; nan. POP H ; pour ne pas bouger. RET ;--------------- CD.Q: ;;; 71 shift/Q : quote caractere! MVI A,3 ; code commande AGAIN STA CD.COM CALL EDL ; lecture de n'import quel caractere LXI B,CD.Q1 ; prepare le retour des tests. PUSH B ; pour RET MVI B,$5D ; print left arrow. CPI $08 ; left arrow ? RZ ; ouaip. CPI $18 ; shift/left arrow ? RZ ; ouaip. MVI B,$5E ; print rigth arrow. CPI $09 ; right arrow ? RZ ; ouaip. CPI $19 ; shift/right arrow ? RZ ; ouaip MVI B,$5C ; print down arrow. CPI $0A ; down arrow ? RZ ; ouaip. CPI $1A ; shift/down arrow ? RZ ; ouaip. MVI B,$5B ; print up arrow. CPI $1B ; shift/print up arrow ? RZ ; ouaip. SUI $40 ; passe en mode controle! MOV B,A RET ; pour tomber sur CD.Q1 CD.Q1: MOV A,B ; A le nouveau caractere STA CD.ARG ; range l'argument pour un Again. CD.QAG: MOV M,B ; force ce caractere INX H ; avance le pointeur. RET ; et voila! ;--------------- CD.R: ;;; 72 shift/R lecture d'une page sur K7. XRA A ; numero du drive. CALL $0212 ; define drive CALL $0296 ; find sync byte. CALL CD.CL ; efface tout! CD.R1: PUSH H ; clean, clean, clean. CALL $0235 ; lecture d'un octet. POP H ; recup l'adresse sur l'ecran. CPI $0D ; c'est return ? JRZ CD.R3 ; ouip. MOV M,A ; affiche sur l'ecran. INX H ; avance le pointeur. CD.R2: MOV A,H ; recup l'adresse. CPI $40 ; c'est la fin de l'ecran ? JRC CD.R1 ; nan : continue. CALL $01F8 ; stop la K7. LXI H,$3C00 ; passe en HOME. RET ; et c'est tout. CD.R3: CALL CD.CR ; avance le pointeur d'une ligne JMPR CD.R2 ; puis le test ... ;--------------- CD.S: ;;; 73 shift/S : SEARCH 1 caractere. XRA A ; code commande pour le AGAIN. STA CD.COM CALL EDTC ; lecture du caractere argument STA CD.ARG ; sauv l'argument de la commande (AGAIN) MOV B,A ; qui est sauve dans B. CD.SAG: PUSH H ; sauve l'ancienne position. JMPR CD.S2 ; vers la 1ere incrementation. CD.S1: MOV A,M ; caractere suivant. CMP B ; c'est cui-la ? JRNZ CD.S2 ; nan. POP B ; nettoie la pile RET ; et c'est tout. CD.S2: INX H ; avance dans l'ecran. MOV A,H CPI $40 ; fin ecran ? JRC CD.S1 ; nan POP H ; recup l'ancienne position RET ; et voila. ;--------------- CD.V: ;;; 76 shift/V : relecture video par LE LISP STA IEDIT ; indicateur video. LXI H,ECRAN SHLD EDIPT ; init de pointeur ecran. JMP EDFS ; et termine l'editeur. ;--------------- CD.W: ;;; 77 shift/W : ecriture de la page sur K7 PUSH H ; sauve le pointeur courant. XRA A ; numero du drive. CALL $212 ; define drive. CALL $287 ; write leader LXI H,$3C00 ; adresse debut de la page. CD.W1: PUSH H ; sauve le pointeur MOV A,M ; recupere le caractere. CPI $20 ; c'est un espace ? JRZ CD.W2 ; ouiap : traitement particulier. CALL $264 ; ecrit le byte POP H ; recupere le pointeur. INX H ; caractere suivant. MOV A,H ; pour le test CPI $40 ; fin ecran ? JRC CD.W1 ; nan : continue MVI A,$0D ; force 2 lignes de mieux : CALL $264 ; une CALL $264 ; et deux . CALL $1F8 ; puis cassette OFF POP H ; reprend la position initiale. RET CD.W2: INX H ; avance dans la ligne. MOV A,L ; recup le numero dans la ligne. ANI $3F ; test fin de ligne. MVI A,$0D ; pour un retour avec RETURN. RZ ; c'est la fin de la ligne donc une suite ; d'espace == return! MOV A,M ; recup le caractere suivant de la ligne. CPI $20 ; c'est toujours des espaces ? JRZ CD.W2 ; oui : vers le test de fin de ligne. DCX H ; non : recule pour etre comme avant. MVI A,$20 ; et la suite d'espaces et equivalente ; a n blancs. RET ; voila. ;--------------- CD.Z: ;;; 7A shift/Z : position fin d'ecran LXI H,$4000 ; position debut derniere ligne JMP CD.EM1 ; et point sur le dernier caractere ;--------------- EDEND=. ; fin du code de l'editeur EDSIZ=EDEND-EDSTR ; taille du code de l'editeur! .ENDC ; de EDITRS. .PAGE .SBTTL; Fonctions sur COLORIX ;******************************* ;********* FONCTIONS SUR COLORIX ;******************************* .IFNE COLOR ; POUR MZ80 ET CERTAINS TRS CPIOA=$D0 ; DATA PIO A COLORIX CPIOB=$D2 ; DATA PIO B COLORIX CCPIA=$D1 ; CONTROL PIO A COLORIX CCPIB=$D3 ; CONTROL PIO B COLORIX ;----- S.P D'INITIALISATION DE COLORIX ; APPELLE PAR REENT. CLRIN: MVI A,7 ; ENABLE INTERRUPT OUT CCPIA OUT CCPIB MVI A,$0F ; OUTPUT MODE OUT CCPIA MVI A,$CF ; OUTPUT MODE 3 OUT CCPIB MVI A,$80 ; I0000000 (BIT 7 EN INPUT) OUT CCPIB MVI L,0 MOV E,L ; <- Y = 0 JMP COLC1 ; HOME (SANS ATTENDRE). ;****(COULIX N) [SUR 1] COLC: IN CPIOB RLC ; CY <- NLUCAR .BYTE $38,$FB ; JRC COLC COLC1: MVI A,$40 OUT CPIOB ; BIT SORCAR A 1 MOV D,L ; D <- VVVVBBBB DAD H DAD H ; H <- RRRRVV MOV A,D ANI $3F OUT CPIOA MOV A,H ; A <- RRRRVV ANI $3F ; A <- 00RRRRVV OUT CPIOB RET ;**** (ADRIX N) [SUBR 1] ;**** (ADRIXY X Y) [SUBR 2] COLX: MOV A,L ANI $3F ; PREP Y MOV E,A ; E <- Y. DAD H DAD H MOV A,H ; PREP X ANI $3F MOV L,A ; L <- X PRET. ; COULXY DOIT SUIVRE. COLXY: IN CPIOB RLC ; CY <- NLUCAR .BYTE $38,$FB ; JRC COLXY MVI A,$40 ; BIT NSORCAR A 1 OUT CPIOB MOV A,L ; A <- X CMA OUT CPIOA MOV A,E CMA ANI $3F ; NSORCAR A 0 OUT CPIOB RET ;**** (COULDOSE R V B) [SUBR 3] COLD: IN CPIOB RLC ; CY <-NLUCAR .BYTE $38,$FB ; JRC COLD MVI A,$40 ; BIT NSORCAR A 1. OUT CPIOB MOV A,E ANI $0F ; E <- 0000BBBB MOV A,L RLC RLC RLC RLC ANI $30 ; A <- 00VV0000 ORA E OUT CPIOA ; SORT 00VVBBBB MOV A,L RRC RRC ANI $3F MOV L,A ; L PDS FORTS DE V POP D ; DE <- ROUGE. MOV A,E RLC RLC ANI $3C ORA L OUT CPIOA ;SORT 00RRRVV RET ;**** (COULT COLOR) [SUBR 1] COLT: PUSH H ; SAUVE LA COULEUR. MVI L,0 ; PREPARE LE HOME. MOV E,L CALL COLXY ; 'HOME'. POP H ; RECUP LA COULEUR CALL COLC ; ECRIT LA COULEUR LXI H,61888 ; 65536-(64*57) LXI D,1 ; POUR DECREMENTER. IN CPIOB ; LIT NLUCAR ET COULEUR. MOV B,A ; SAUVE LA COULEUR -> B. RLC ; CY <- NLUCAR .BYTE $38,$FA ; JRNC ERS IN CPIOB MVI A,$40 ; POSIT NSORCAR A 1 OUT CPIOB MOV A,B ; RECUP LA COUL OUT CPIOB DAD D .BYTE $30,$F0 RET .ENDC ; COLOR .PAGE .SBTTL; Debug : VDDT ;**************************************** ;*** DEBUG : POUR M.A.P. TRS80 *** ;**************************************** .IFNE DDT DBUG: LXI SP,BSTAK MVI C,'/' ; PROMPT DBUG CALL CO CALL DBUG5 ; LIRE UNE ADRESSE PUSH H ; QUI EST SAUVEE DBUG2: POP H ; RECUP L'ADRESSE MOV A,M ; RECUP LE MOT MEMOIRE INX H ; POINT SUR LE SUIVANT PUSH H ; RERANGE EN PILE. CALL DBUG8 ; EDIT L'OCTET EN HEXA MVI C,'-' ; PROMPT MODIF CALL CO CALL DBUG5 ; LIRE UNE VALEUR MOV A,H ; YA QCQ ? ORA A ; HEIN JZ DBUG2 ; NAN : CONTINUE D'EDITER POP D ; RECUP L'ADRESSE PUSH D ; ON LE RAMET DCX D ; CAR ON AVAIT AVANCE XCHG MOV M,E JMP DBUG2 ; AU SUIVANT DBUG5: LXI H,0 ;;; LECTURE D'UN NB HEXA DBUG6: PUSH H ; SAUVE L'ACCU CALL CI ; LECT CARACTERE MOV C,A ; POUR L'EDITER PUSH PSW ; POUR SAUVER LE CARACTERE CALL CO ; EDITE LE CAR LU POP PSW ; RECUP LE CAR POP H ; RECUP L'ACCU CPI ' ' ; ESPACE ? RZ ; FIN PAR ESPACE. CPI $0D ; 'ENTER' JZ DBUG ; RECOMMENCE SUI '0' ; CONVERSION HEXA CPI $0A JC DBUG7 SUI 7 ; PASSAGE AUX LETTRES DBUG7: DAD H ; * 16 HL DAD H DAD H DAD H ADD L ; CAR + L MOV L,A ; HL = HL*16 + CAR JMP DBUG6 ; POUR LES AUTRES DBUG8: PUSH PSW ;;; EDITE A SUR 2 CHIFFRES HEXA RLC RLC RLC RLC ; POUR LE PARTIE GAUCHE CALL DBUG9 POP PSW ; POUR LA PARTIE DROITE DBUG9: ANI $0F ; MASQUE LSB ADI '0' ; CONVERSION SAUVAGE CPI '9'+1 JC DBUG0 ADI 7 ; PASSAGE AUX LETTRES DBUG0: MOV C,A JMP CO ; IMPRESSION. .ENDC ; de DDT .PAGE .SBTTL; Entree, lecture logique caractere : GETCH: GETYP: GETCV: ;----- STREAM LOGIQUE : GETCH ;----- STREAM PHYSIQUE : INCHB ; GETCH : LIT LE CAR SUIV CELUI A REINGURGITER (READ). ; OU L'ELEMENT SUIVANT (IMPLODE). ; RETOUR : B <- CAR A <- TYP DU CAR. ; NEBOUZILLE RIEN D'AUTRE. GETCH: LDA RINGR ; YA QUEKCOSE ORA A ; A REINGURGITER ? JZ GETH1 ; NAN. MOV B,A ; B <- LCAR. XRA A ; RINGR <- 0. STA RINGR JMP GETH2 GETH1: LDA IMPLP ; ON EST DANS ORA A ; la fonction IMPLODE ? JNZ GETH3 ; OUAIP. CALL INCHB ; B <- CAR SUIVANT. GETH2: CALL GETYP ; A <- LE TYP. DCR A ; CAR NULLS ? JM GETCH ; OUAIP. RET ; ; GETYP : METS DS A LE TYPE DU CARCTERE B GETYP: MOV A,B ; A <- LE CARACT. GETAP: PUSH H ; GETYP BOUZILLE RIEN. PUSH D LXI H,TABCH PUSH PSW ; SAUVE LE CARACTERE RRC ; CARRY SI CARACT IMPAIR. ANI $3F ; MASK POUR 64 CARACT. MOV E,A MVI D,0 ; POUR LE DAD. DAD D ; HL <- @ EN TABLE. POP PSW ; RESTAURE LE CARACTERE RRC ; pour tester la parite MOV A,M ; TYPE. JC GETY1 RRC RRC RRC RRC ; ISOLE LA PARTIE GAUCHE. GETY1: ANI $0F POP D ; RESTAURE LES 2. POP H RET .PAGE ;----- LECTURE DE LA LISTE DU IMPLODE GETH3: PUSH H ; SAUVE TOUT. PUSH D PUSH B ; vraiment tout LXI B,.IMPLD+1 ; adresse de l'atome IMPLODE LDAX B ; charge faible MOV L,A ; dans HL DCR C ; donc BC est la vraie adresse LDAX B MOV H,A ; HL est donc la c-val de implode CPI HLIST ; c'est toujours une liste ? JNC GETH4 ; ouaip ca roule MVI L,6 ; a priori, c'est le'rreur numero 6 CPI HNIL ; si c'est pas la liste vide JNZ ERLEC ; oui, on y va LXI D,.T ; pour que ce soit faux, au coup d'apres MVI A,' ' ; on considere que c'est un separateur JMP GETH5 ; et ca redevient commun GETH4: .UNCNS ; AVANCE DS LA LISTE. CALL OUXMRG ; desinterne le nombre et controle <128 GETH5: MOV H,B ; HL <- l'atome IMPLODE MOV L,C MOV M,D INR L MOV M,E ; (SET 'IMPLODE (CDR IMPLODE)) POP B ; restaure tout POP D POP H MOV B,A ; LE CARACT DOIT ETRE DS B. JMP GETH2 .PAGE ; GETCV : RAMENE LE 1ER CARACT LISP VALIDE. ; TRAITE LES COMMENTS ET LES SLASHES. ; FAIT LA CONVERSION MIN-MAJ. ; RETOUR : B <- LE CAR, A <- TYP - 4. GETV1: CALL GETCH CPI CLECM-1 ; END COMMENT ? JNZ GETV1 ; NAN : CONTINUE LA LECTURE DU COMMENT. GETCV: CALL GETCH DCR A ; SLASH ? JP GETV2 ; nan : vers la suite des tests. CALL GETCH ; ON RELIT LE SUIVANT. MVI A,CCNOR ; QUI EST NORMAL ! RET GETV2: DCR A ; DEB COMMENT ? JM GETV1 ; OUAIP. DCR A ; FIN COMMENT ? JM GETCV ; OUAIP : ON L'IGNORE. ;;; CONVERSION MIN -> MAJ PUSH PSW ; SAUVE LE TYPE. LDA IPTI ; STATUS READ ORA A ; faut faire la conversion ? JNZ GETV3 ; PAS TOUCHE ! MOV A,B ; A <- LE CARACT. CPI 'A' ; A Majuscule JC GETV3 ; PAS DE CONV. CPI 'Z'+1 ; Z Majuscule JNC GETV3 ; PAS DE CONV. ADD $20 ; CONV PROPREMENT DITE. MOV B,A ; REST LE CARACT GETV3: POP PSW ; REST LE TYPE. RET .PAGE .SBTTL; Entree, lecture US suivante : RD1: RDST: RDMAC: RDHX: TRYAT: CRATO: ; RD1 : LIT L'U.S. SUIVANTE. ; RETOUR: HL <- ADRESSE DE L'OBJET LISP LU ; A <- TYPE 0:OBJET LISP, 1:.,2:(,3:) RD1: CALL GETCV ; CARACT VALIDE SUIVANT. DCR A ; SEP NULL ? JM RD1 ; ON LES SAUTE. JZ RDMAC ; VERS TRAIT MACROS DCR A JZ RDST ; si symbole special DCR A JZ RDHX ; SI # SHARP-MACRO. DCR A JZ RD2 ; SI ATOME. CPI 4 ; MONO-SYMBOLE ? JZ RDMNS ; ouaip ; SI . ( ) -A- EST OK. LXI H,RDCRD ; PREP MAJ DEEP READ. CPI 3 ; ) ? JZ RD11 ; OUAIP. CPI 2 ; ( ? RNZ ; NAN. INR M ; OUAIP. RET RD11: DCR M ; DANS LE CAS ) RP ; SI C'EST > 0 MVI M,0 ; SI YA TROP DE ) RET RD2: ; cas caractere normal, lecture du P-name entier. MVI C,MBFMZ ; nb de caracteres max du P-name. LXI H,MBUF+1; adresse du debut du buffer du P-name RD4: MOV M,B ; charge le caractere INR L ; avance dans le buffer (meme page) DCR C ; chien de garde JM ERLC1 ; too much ! CALL GETCV ; caractere suivant. CPI CCNOR ; il est toujours normal ? JZ RD4 ; ouiap, ca roule CPI CCDOT ; un point on accepte JZ RD4 MOV A,B ; sauve le dernier STA RINGR ; separateur. MVI A,MBFMZ ; calcule la taille reelle du P-name. SUB C ; dans A. STA MBUF ; que l'on charge dans le P-length. CALL TRYAT ; ON INTERNE. XRA A ; TYPE RD1 = 0 (OBJ LISP) RET ; VOILA. .PAGE ;----- RDST : LECTURE D'UNE PSEUDO-CHAINE RDST: MVI C,MBFMZ ; nb maximum de caracteres. LXI H,MBUF+1 ; POINT SUR DEBUT P-NAME. JMP RDST3 ; en voiture RDST4: MOV M,B ; charge dans le buffer INR L ; avance dans le buffer (meme page) DCR C ; chien de garde, longueur max JM ERLC1 ; trop long ! RDST3: CALL GETCH ; CARACTERE SUIANT. CPI CLSTR-1 ; DELIM symbole special ? JNZ RDST4 ; nan, ca roule CALL GETCH ; on recommence car il est peut-etre double' CPI CLSTR-1 ; c'est lui ? JZ RDST4 ; ouaip, comme si il n'y en avait qu'un MOV A,B ; sauve le caractere lu en trop STA RINGR ; ringar, non pardon, ringUr RDST5: MVI A,MBFMZ ; CALCUL P-LENGTH SUB C STA MBUF ; QUE L'ON RANGE. CALL CRATO ; VERS INTERN. PUSH H ; SAUVE L'ADRESSE DE L'ATOME. ; a remettre pour avoir une constantification ; MOV M,H ; FORCE LA C-VAL DE CET ATOME ; MOV A,L ; POUR PRESERVER L. ; INR L ; AVEC LUI-MEME (CONSTANTE). ; MOV M,A LXI D,7 ; offset p-type (6 si on constantifie !) DAD D ; HL <- POINT SUR P-TYPE MVI M,$80 ; FORCE LE P-TYPE PSEUDO-CHAINE. POP H ; RECUP L'ATOME. XRA A ; TYPE OBJ = 0 (POUR RET RD1). RET ; DE RD1. ;----- RDMAC : TRAITEMENT DES MACROS-CARACTERES RDMAC: MOV A,B ; RECUP LE VRAI CARACTERE. CALL CRACH ; FABRIQUE L'ATOME MONO-CARACTERE CALL EVRPN ; EFFECTUE UN LANCEMENT RAPIDE XRA A ; TYPE DE RD1 = OBJET LE LISP. RET ; VOILA ! ;----- RDMNS : traitement des mono-symboles RDMNS: MOV A,B ; prends le caractere CALL CRACH ; on l'interne XRA A ; c'est un bel objet pour rd1 RET ; on le ramene. .PAGE ;----- RDHX : TRAITEMENT DES SHARP-MACROS ; RAMENE L'OBJET INTERNE DS HL & 0 -> A (TYPE DE RD1) ; traite le cas des SHARP-MACROS suivantes : ; ; #. (defsharp . () (eval (read))) ; #/ (defsharp / () (readcn)) ; #^ (defsharp ^ () (logand (readcn) #1F)) ; #$ (defsharp $ () ....) lit un nombre en base 16 RDHX: CALL GETCH ; le selecteur de la SHARPMACRO PUSH B ; sauve le caractere MOV A,B ; A <- caractere CALL CRACH ; interne le caractere LXI D,.SHRP ; l'indicateur CALL GETPR ; recherche dans la p-liste POP B ; nettoie LXI D,NIL ; pas d'arg JNC EV15 ; on l'execute MOV A,B ; je me moque bien du type CPI $2E ; le #. JZ SHRP1 ; on le traite CPI $2F ; le #/ JZ SHRP2 ; on le traite CPI $5E ; lw #^ JZ SHRP3 ; on le traite CPI $24 ; le #$ JZ SHRP4 ; on le traite CPI $22 ; le #" JZ SHRP6 ; on le traite MVI L,10 ; code de l'erreur JMP ERLEC ; inconnu au bataillon .PAGE ;----- SHRP1 : #. (EVAL (READ)) SHRP1: CALL READ ; expression suivante CALL EVAL ; sa valeur XRA A ; et c'est ca qui est retourne RET ;----- SHRP2 : #/ (READCN) SHRP2: CALL GETCH ; caractere suivant MOV A,B ; pour l'interner CALL CRANA ; valeur Lisp XRA A ; type = objet Lisp RET ;----- SHRP3 : #^ (LOGAND (READCN) #1F) SHRP3: CALL GETCH ; caractere suivant MOV A,B ; pour y travailler ANI $1F ; force a 0 les bits CONTROL CALL CRANA ; valeur Lisp XRA A ; type = objet Lisp RET ;----- SHRP6 : #" ; retourne la liste des codes ascii SHRP6: CALL NCNSN ; doublet d'initialisation PUSH H ; on le sauve JMP SHR6T ; en voiture SHR6L: PUSH H ; sauve le dernier doublet CALL CRANA ; interne le nombre POP D ; recupere le precedent CALL PLACP ; accroche et avance SHR6T: CALL GETCH ; caractere suivant MOV A,B ; le type on s'en fout CPI $22 ; c'est le delimiteur ? JNZ SHR6L ; nan ca roule CALL GETCH ; on recommence, car il est peut-etre double' MOV A,B CPI $22 ; s'il y en a 2, il y en a 1 !!!! JZ SHR6L ; et oui STA RINGR ; et non, il faudra le relire POPCDR: POP H ; recupere le premier doublet INR L ; il faut prendre le CDR INR L MOV A,M ; charge fort INR L MOV L,M ; faible MOV H,A ; voila XRA A ; type objet LISP RET ; et voila .PAGE ;----- SHRP4 : LECTURE D'UN NOMBRE HEXA SHRP4: CALL RDHT ; est ce un chiffre hexa ? MVI L,11 ; code de l'erreur JC ERLEC ; il en faut au moins un MVI H,0 ; PREPARE L'ACCU. JMP RDHX3 RDHX1: DAD H ; * 2 DAD H ; * 4 DAD H ; * 8 DAD H ; * 16 ADD L ; CALCUL POIDS FAIBLES. RDHX3: MOV L,A CALL RDHT ; DIGIT SUIVANT. JNC RDHX1 ; IL EST BON. MOV A,B ; SAUVE LE DERNIER CARACT STA RINGR ; POUR LE REINGURGITER. CALL CRANB ; INTERNE LE NB. XRA A ; TYPE DE RD1 = 0 RET ; RDHT : LIT LE CAR SUIV, TEST SI DIGIT HEXA. ; RETOUR : CARRY SI FAUX. RDHT: CALL GETCH ; CAR LISP SUIV. MOV A,B ; A <- LE CARACT. RDHT0: SUI '0' ; < '0' ? RC ; RETOUR FAUX. CPI $0A ; > 9 ? JC RDHT1 ; NAN (VERS RETOURS VRAIS) SUI 7 CPI $0A RC ; ENTRE 9 & A => FAUX. CPI $10 ; > F ? RDHT1: CMC ; POSIT LE CARRY (ASTUCE) RET .PAGE ;TRYAT : REGARDE LA CHAINE DS MBUF. ; APPELLE CRANB SI NB, CRATO SI ATOME LITTERAL. TRYAT: LXI H,MBUF ; HL <- @ DU BUFFER MOV B,M ; B <- TAILLE DU BUFFER. LXI D,0 ; DE <- ACCU XRA A ; SIGNE : >= 0. STA SIGN INX H MOV A,M ; RECUP LE 1ER CAR. CPI '+' ; TEST DE SIGNE. JZ TRYA5 ; C'EST +. CPI '-' ; TEST DE SIGNE. JNZ TRYA8 ; RATE. STA SIGN ; SI # 0 => < 0. TRYA5: DCR B ; ACTUALISE LE NB DE CAR RESTANTS. JZ CRATO ; YAVAIT QU'UN SIGNE ! TRYA7: INX H ; CARACT SUIV. MOV A,M ; DANS A. TRYA8: SUI '0' ; TESTDECIMAL. JC CRATO CPI $0A JNC CRATO ; SI # => ATOM LITTERAL PUSH B ; SAUVE PLENGTH. XCHG ; HL <- ACCU, DE <- PIOINT DAD H ; ACCU <- ACCU * 2 CC TOVF ; test de debordement numerique PUSH H ; SAUVE PROD PARTIEL. DAD H ; ACCU <- ACCU * 4 CC TOVF ; test debordement numerique DAD H ; ACCU <- ACCU * 8 CC TOVF ; test de debordement numerique POP B DAD B ; ACCU <- ACCU * 10 ! CC TOVF ; test de debordement numerique MVI B,0 ; BC <- DIGIT SUIVANT (SUR 16 BITS). MOV C,A DAD B ; FIN DU HORNER. CC TOVF ; dernier test de debordement. XCHG ; HL <- POINT, DE <- ACCU. POP B ; RECUP PLENGTH DCR B ; IL EN RESTE ? JNZ TRYA7 ; OUAIP. XCHG ; HL <- L'ACCU. NBSGN: LDA SIGN ; CEATION NB AVEC SIGN. ORA A ; TEST DE SIGNE ? CNZ CMPHL ; IL DOIT ERE NEGATIF. CALL RIOMP ; charge READ ou IMPLODE en cas d'erreur JMP CRANB ; ON L'INTE. .PAGE ;----- CRATO : CHERCHE L'ATOME LITTERAL DS MBUF. ; il le cree s'il n'existait pas ; et dans tous les cas le met au debut CRATO: LXI D,MBUF ; pointe sur l'atome cherche LHLD CATOL ; premier symbole MOV B,H MOV C,L ; dans BC LXI H,8 ; offset a-link DAD B ; le voila PUSH H ; le predecesseur est lui meme JMP CRAF2 ; en voiture .PAGE ;----- boucle de recherche d'un atome dans l'oblist CRAF6: MVI E,MBUF & $FF ; reinit sur atome cherche POP H ; pointe juste apres a-link CRAF5: DCR L ; sur fort MOV B,M DCR L ; rebelotte faible MOV C,M MOV A,B ; test de fin ORA C JZ CRAC1P ; il est tout neuf XTHL ; new devient old ! CRAF2: LXI H,10 ; offset p-length DAD B ; dessus LDAX D ; p-length du cherche CMP M ; c'est le meme ? JNZ CRAF5 ; nan, le suivant vite fait ORA A ; gaffe au symbole de longueur nulle JZ CRAF4 ; c'est lui PUSH H ; memorise le candidat MOV C,A ; C compteur CRAF3: INX H ; avance dans le candidat INR E ; avance dans le cherche (meme page) LDAX D ; un caractere CMP M JNZ CRAF6 ; fallait pas se fier aux apparences DCR C ; un de moins JNZ CRAF3 ; y en a encore POP H ; recupere le debut CRAF4: DCR L ; pointe sur fort a-link MOV B,M ; charge fort suivant DCR L MOV C,M ; charge faible suivant XCHG ; DE sur a-link du nouveau symbole LHLD CATOL ; pointeur sur premier atome XCHG ; HL le a-link du nouveau premier atome MOV M,E ; le force INR L MOV M,D LXI D,-9 ; offset a-link DAD D ; repasse au debut SHLD CATOL ; nouveau premier POP D ; recupere le precedent MOV A,C ; le suivant de son suivant STAX D ; on le force dans son a-link INR E ; rebelotte forte MOV A,B STAX D ; ca y est RET ; voila .PAGE ;----- CREATION D'UN NOUVEAU SYMBOLE CRAC1P: POP H ; nettoie la pile CRAC1: LHLD CATOC ; COURANT ATOME. LXI D,BUFAT ; COPIER LE NEW ATOM. LDA MBUF ; P-LENGTH. ADI 14 ; de c-val a p-length plus le pad ANI $FC ; fait le pad modulo 4 MOV C,A ; C le compteur ; 6 - 1000l$$1000t$$ ADD L ; debut zone libre, ca tient ? JNC CRAC2 ; ok en route MOV A,H ; ca change de page CPI HLIST-1 JNC ERATO ; erreur terrible !!!!! CRAC2: XCHG ; DE <- zone libre HL <- mbuf .IFNE ZILOG MVI B,0 ; ca compte sur 16 bits LDIR ; on balance tout .IFF ; pauvre 8080 CRAC6: MOV A,M ; charge STAX D ; transfert INR L ; avance dans MBUF (meme page) INX D ; avance dans la zone DCR C ; decremente le compteur JNZ CRAC6 ; il en reste .ENDC ; de ZILOG LHLD CATOC ; ancien debut i.e. new atome XCHG SHLD CATOC ; nouveau debut XCHG ; new atom SHLD CATOL ; premier de l'oblist (l'ancien vient de lui etre lie) RET .PAGE .SBTTL; Entree, READ interne : READ: ;----- READ : (INTERNE) LITNE S-EXPR -> HL. READ: CALL RD1 ; 1ER OBJET. REA0: DCR A ; ATOME ? RM ; OUI : C'EST FI DCR A MVI L,3 ; code de l'erreur JNZ ERLEC ; SI # DE ATOME OU ( REA1: CKSTK ERFSR ; CAS 1ERE '('. CALL RD1 ; U.S. SUIVANTE. CPI 3 JZ FALSE ; CAS (). CALL REA0 ; FINI DE LE LE 1ER ELEMENT. CALL NCONS ; YA PAS DE CONS EN TROP. PUSH H ; SAUVE PREM PUSH H ; SAUVE LAST. JMP REA2 ; en voiture REA5: ;;; cas "(" normale CALL REA1 ; lit le 1er element REA6: ;;; rajoute un element POP D ; depile le precedent CALL PLACP ; et on l'accroche PUSH H ; empile le new LAST REA2: CALL RD1 ; ELEMENT SUIV. DCR A JM REA6 ; VERS ELEM NORM. JZ REA4 ; SI "." DCR A JZ REA5 ; SI "(" POP H ; ")" DEPILE LAST. POP H ; DILEPREM RET .PAGE ;----- TRAITEMENT DES PAIRES POINTEES REA4: CALL READ ; accepte la forme generale : (s1 . s2) PUSH H ; sauve la partie droite. CALL RD1 ; U.S. suivante qui termine la paire. CPI 3 ; c'est une ")" ? MVI L,4 ; code de l'erreur JNZ ERLEC ; si non erreur. POP D ; recupere la partie droite. POP H ; recupere la partie gauche. JTNUM D,ERRONS ; pas de CDR numerique .RPLD D,E POP H ; recupere PREM RET ; et c'est tout. .PAGE .SBTTL; Entree: macro caracteres standards ;***** (DMC /' () (LIST 'QUOTE (READ))) ;***** (DE KWOTE (L) (LIST 'QUOTE L)) RDMAQ: ;;; 'S == (QUOTE S) CALL READ ; on lit KWOTE: CALL NCONS ; on listifie LXI D,.QUOT CALL XCONS ; on reunit XRA A ; pour RD1 RET ;***** (DMC /& () (LIST 'EDIT (READ))) .IFNE EDITRS RDMAE: ;;; &N == (EDITV n) LXI D,.ETV PUSH D CALL READ ; LIT LE S-EXPR SUIVANTE. CALL NCONS POP D ; RECUP LE CAR CALL XCONS ; FORME LA LISTE XRA A ; TYPE = 0 (POUR RD1) RET ; DE RD1. .IFF RDMAE: JMP FALSE ; pour que ca retourne NIL. .ENDC ; de EDITRS ;***** (DMC ^ () (ASCII (LOGAND (READCN) #31)))) FLEXE: CALL GETCH ; B <- le caractere MOV A,B ; je me moque du type ANI $1F ; force les bits CONTROL CALL CRACH ; je le cree sous forme de symbole. XRA A ; type = 0 (pour RD1) RET .PAGE ;***** (DMC /[ () ; (TYPECH '/! 12) ; (TYPECH '/] 12) ; (LET ((D (LIST 'LIST))) ; (CRO D D (READ)) ; D ) ) ; ; (DE CRO (DEBUT ACTUEL NEW) ; (WHEN (NEQ NEW '/]) ; (IF (NEQ NEW '/!) ; (CRO DEBUT (PLACDL ACTUEL NEW)) (READ)) ; (LET ((X1 (LIST (READ)))) ; (IF (EQ DEBUT ACTUEL) ; (SEQUENCE (CDR (RPLAC DEBUT 'APPEND X1)) (READ)) ; (RPLACA DEBUT ; (IF (EQ ACTUEL (CDR DEBUT)) 'CONS 'MCONS) ) ; (LET ((X2 (READ))) ; (IF (EQ X2 '/]) ; (RPLACD ACTUEL X1) ; (SEQUENCE ; (CDAR (PLACDL ACTUEL ; (CONS 'APPEND X1) ) ) ; X2 ) ) ) ) ) ) ) ) ; ; (DE SEQUENCE (LAST NEXT) ; (IF (EQ NEXT '/!) ; (SEQUENCE (PLACDL LAST (READ))) (READ)) ; (WHEN (NEQ NEXT '/]) ; (LET ((D (LIST 'LIST NEXT))) ; (PLACDL LAST D) ; (CRO D (CDR D) (READ)) ) ) ) ) ; cette definition non recursive optimise la representation interne: ; '[a b c d] ---> (List a b c d) ; '[a ! b] ---> (cons a b) ; '[a b c !d] ---> (mcons a b c d) ; '[a !b !c !d] ---> (cons a (append b c d)) ; '[!a !b !c] ---> (append a b c) ; etc .PAGE .IFNE BIG CROOUV: LXI H,RDCRD ; profondeur parenthetique INR M ; une de plus LXI H,.LIST ; a priori CALL NCONS ; fabrique le premier doublt PUSH H ; qu'il faudra ramener CALL CRO ; en voiture LXI H,RDCRD ; profondeur parenthetique DCR M ; un de moins POP H ; le premier doublet XRA A ; type objet LISP RET ; et voila .PAGE ;----- BOUCLE DE LECTURE APRES UN CROCHET OUVRANT CRO: PUSH H ; DEBUT PUSH H ; ACTUEL JMP CRO1 ; en voiture CRO4: POP D ; recupere le precedent CALL PLACP ; (RPLACD ACTUEL (LIST NEW)) PUSH H ; nouveau ACTUEL CRO1: CALL READ ; suivant MOV A,H CPI .CROF ^ ; c'est "]" ? JNZ CRO2 ; nan vers essai "!" MOV A,L CPI .CROF & $FF JNZ CRO3 ; nan vers essai "!" POP H ; nettoie la pile : ACTUEL POP H ; nettoie la pile : DEBUT RET ; c'etait le cas (LIST ...) CRO3: MOV A,H ; NEW fort CRO2: CPI .UNPAK ^ ; c'est "!" ? JNZ CRO4 ; nan, vers l'accrochage normal MOV A,L CPI .UNPAK & $FF JNZ CRO4 CALL READ ; lit l'objet a deballer CALL NCONS ; qu'on listifie de toutes facons POP B ; ACTUEL POP D ; DEBUT XCHG ; DE <- (LIST (READ)) = X1 HL <- DEBUT MOV A,B ; (EQ DEBUT ACTUEL) ? CMP H JNZ CRO5 ; nan, vers le test (EQ (CDR DEBUT) ACTUEL) MOV A,C CMP L JNZ CRO5 MVI M,.APP ^ ; (RPLACA DEBUT 'APPEND) INR L MVI M,.APP & $FF INR L MOV M,D ; (RPLACD DEBUT X1) INR L MOV M,E ; c'est le cas [!a ---> (append ... PUSH D ; sauve LAST JMP SEQ4 ; vers la boucle de lecture des "!" .PAGE ;----- TRANSFORME 'LIST EN 'CONS OU 'MCONS CRO5: INR L ; PASSE AU CDR INR L MOV A,B ; (EQ ACTUEL (CDR DEBUT)) ? CMP M JNZ CRO6 ; nan, vers (RPLACA DEBUT 'MCONS) INR L MOV A,C CMP M JNZ CRO7 DCR L DCR L ; pointe sur le car MVI M,.CONS & $FF ; (RPLACA DEBUT 'CONS) DCR L MVI M,.CONS ^ JMP CRO8 ; vers la lecture de X2 CRO7: DCR L CRO6: DCR L ; pointe sur le car MVI M,.MCONS & $FF ; (RPLACA DEBUT 'MCONS) DCR L MVI M,.MCONS ^ CRO8: PUSH D ; (X1) PUSH B ; ACTUEL PUSH D ; (X1) CALL READ ; on a plus besoin de DEBUT POP B ; (X1) MOV A,H ; c'est "]" ? CPI .CROF ^ ; si oui pas besoin d'append JNZ CRO9 ; et si MOV A,L CPI .CROF & $FF JNZ CRO9 POP H ; ACTUEL POP D ; (X1) .RPLD D,E ; ou BC c'est pareil RET ; c'etait le cas (mcons/cons a b c d) .PAGE ;----- BOUCLE DE LECTURE APRES "!" ; car APPEND est une NSUBR SEQ1: CALL READ ; LIT L'OBJET A DEBALLER .PLACE ; (RPLACD LAST (LIST (READ))) PUSH D ; sauve le nouveau LAST SEQ4: CALL READ ; suivant SEQ3: MOV A,H ; c'est "!" ? CPI .UNPAK ^ JNZ SEQ2 ; fin de la boucle MOV A,L CPI .UNPAK & $FF JZ SEQ1 ; un argument de plus pour append MOV A,H SEQ2: CPI .CROF ^ ; c'est "]" ? JNZ SEQ5 ; nan faut rappeler cro POP D ; ca a l'air bon MOV A,L ; selon les poids faibles CPI .CROF & $FF RZ ; c'etait le cas (APPEND a b c d) PUSH D ; remets tout en place SEQ5: CALL NCONS ; (LIST NEXT) PUSH H ; futur ACTUEL LXI D,.LIST CALL XCONS ; (LIST 'LIST NEXT) POP B ; recupere futur ACTUEL POP D ; recupere LAST PUSH H ; place le futur DEBUT PUSH B ; place le futur ACTUEL CALL PLACP ; (PLACDL LAST (LIST 'LIST NEXT)) JMP CRO1 ; et tout est en place .PAGE ;----- AJOUTE APPEND AU DEBUT CRO9: XTHL ; P:: (X1) X2] PUSH H ; P:: (X1) X2 ACTUEL] LXI D,.APP ; il faut append CALL BNCNS ; (CONS 'APPEND X1) .PLACE ; (RPLACD ACTUEL (LIST (CONS 'APPEND X1))) POP H ; HL <- X2 P:: (X1) JMP SEQ3 ; vers la boucle de lecture des "!" .IFF ; de BIG CROOUV: JMP FALSE .ENDC ; de BIG .PAGE .SBTTL; fonctions d'entree: 0SUBRS ;***** (READ) [SUBR 0] -USER- READU: CALL RD1 ; U.S. SUIVANTE. CPI 3 ; SAUTE TOUTES LES ')' EN TROP. JZ READU JMP REA0 ;***** (PEEKCH) [SUBR 0] NE LE MANGE PAS. .IFNE BIG PEEKC: CALL GETCH ; LIT N'IMPORTE QUOI. MOV A,B ; A <- LE CARACT. STA RINGR ; POUR LE REMANGER. JMP CRACH ; INTERNE. .ENDC ; de BIG ;***** (PEEKCN) [SUBR 0] retourne le code interne PEEKK: CALL GETCH ; lit n'importe quoi. MOV A,B ; pour la conversion STA RINGR ; pour le re lire plus tard JMP CRANA ; retourne le code interne ;***** (READCH) [SUBR 0] READC: CALL GETCH MOV A,B ; CRACH DOIT SUIVRE ... ;----- CRACH : CRE L'ATOME MONO-CARACTERE (DS A) CRACH: LXI H,MBUF ; POINTE SUR P-LENGTH. MVI M,1 ; P-LENGTH = 1 INX H ; AVANCE DS MBUF. MOV M,A ; CHARGE LE CARACTERE. JMP TRYAT ; ET ON INTERNE. ;***** (READCN) [SUBR 0] READK: CALL GETCH ; lit n'importe quoi MOV A,B ; pour la conversion JMP CRANA ; retourne le code interne. .PAGE ;***** (BOL) [SUBR 0] COLBOL: ; appel de BOL redefinissable PUSH D ; ne doit rien detruire PUSH B ; (HL est deja sauve) XRA A ; A <- 0 STA LBCIU ; reinit la position courante LXI H,.BOL CALL EVRPN LXI H,INBUF ; repasse au debut du buffer POP B ; restaure POP D JMP INCH1 ; et on le lit BOL=INCI ; en standard ;***** (TEREAD) [SUBR 0] NEXT RECORD. ; PASSE A L'ENREGISTREMENT SUIVANT. TERD: LXI H,FALSE ; ramene toujours NIL PUSH H ZARBUF: LXI H,INBUF MVI B,128 RAZ0: XRA A ; A <- 0 STRE: MOV M,A INX H DCR B JNZ STRE RET .PAGE .SBTTL; Sortie, impression logique ;----- RAZVF : remets a zero les compteurs des variables-fonctions ; et mets dans SENBLO la taille de la pile, en cas ; de sortie extraordinaire RAZVF: LDA PRPMAX ; profondeur max d'edition STA PRPCOU ; qui devient profondeur restante LHLD PRLMAX ; nombre de lignes SHLD PRLCOU ; idem LHLD PREMAX ; nombre d'elements SHLD PRECOU ; idem LXI H,4 ; memorise le debut de l'impression DAD SP ; pour retour rapide SHLD SENBLO ; provoque par PRLMAX RET ;----- PRINI : APPELLE PROBJ ET PASSE A LA LIGNE PRINI: PUSH H ; SAUVE LA VALEUR CALL PROBJ ; L'EDITE FLUSH: CALL COLEOL ; ET L'IMPRIME POP H ; RECUPERE LA VALEUR RET ; ET RENTRE ;----- PROBJ : edite l'objet HL avec raz des v.f. PROBJ: PUSH H ; sauve l'objet CALL RAZVF ; remets a zero les variables fonctions POP D ; recupere l'objet, et c'est parti PROBX: JFLST D,PRATOX ; pas serieux s'abstenir LXI H,PRPCOU ; c'est donc une liste DCR M ; actualise la profondeur JM PRASTI ; ca depasse, edition de "&" PUSH D ; sauve l'objet LXI B,.PRIN CKSTK ERFS ; si ca tient ! MVI B,'(' ; ca commence CALL PRCHT ; premier caractere JMP PROB5 ; saute l'edition de l'espace .PAGE ;----- BOUCLE D'IMPRESSION D'UNE LISTE PROB6: PUSH H ; sauve l'objet CALL PRSPC ; edite un espace PROB5: POP H ; recupere l'objet .UNCNS PUSH H ; sauve le cdr LHLD PRECOU ; nombre d'elements restant a editer MOV A,H ; il en reste ORA L ; ? JZ PROB8 ; STOP !!!! DCX H ; un de moins SHLD PRECOU ; indique-t-il CALL PROBX ; edite le suivant POP H ; recupere la suite JLTNL H,PROB6,PROB4 ; gaffe a la paire pointee ! PUSH H ; sauve le cdr atomique CALL PRSPC ; un espace MVI B,'.' ; un point CALL PRCHTS ; un espace (non ce n'est pas de la geometrie) POP H ; recupere le cdr atomique CALL PRATO ; on l'edite JMP PROB4 ; vers l'edition de ")" PROB8: POP H ; abandonne la fin de la liste MVI B,'.' ; edite des points de suspension CALL PRCHT3 ; trois fois PROB4: LXI H,PRPCOU ; profondeur courante INR M ; on remonte MVI B,')' ; ouf JMP PRCHT ; et voila .PAGE ;----- PRATO : edite un atome quelconque PRATOX: XCHG ; HL <- l'atome PRATO: JTNUM H,PRNUM ; c'est un symbole PRATOM: LXI D,10 ; offset p-length DAD D ; on pointe dessus MOV A,M ; A <- PLENGTH ORA A ; vide ? (et ca arrive avec la val abs) RZ ; ouiap ; il n'y a rien a faire. MOV C,A ; le compteur doit etre dans C PUSH H ; sauve l'adresse du PLENGTH LDA OPTI ; status print ORA A ; si 0 y a rien JNZ PRAT1 ; il faut pas mettre les delimiteurs CALL INLIN ; C contient la taille d'impression POP H ; recupere le pointeur sur p-length PRAT4: INX H ; pointe sur le caractere suivant MOV B,M ; on le charge PUSH H ; et on memorise la suite CALL PRCH ; on edite et ca tient POP H ; recupere la suite DCR C ; decremente le p-length JNZ PRAT4 ; il en reste RET ; ouf PRAT1: ; cas d'impression des quotes-caracteres DCX H ; pour pointer sur le p-type DCX H DCX H ; le voila MOV A,M ; on le charge RAL ; le bit 8 est l'indicateur de chaine JNC PRAT3 ; c'est pas une chaine, il faut mettre des / PRAT2: ; cas des chaines INR C ; deux caracteres de plus a editer INR C CALL INLIN ; terpri au besoin CALL PRATD ; edite le delimiteur POP H ; recupere la chaine MOV C,M ; remets le p-length CALL PRAT4 ; edite sans "/" PRATD: MVI B,$7C ; le delimiteur JMP PRCH ; et ca tient .PAGE ;----- IMPRESSION D'UN ATOME AVEC DES "/" PRAT3: ; cas des "/" POP H ; recupere l'objet PUSH H ; pour consultation MVI D,CLNOR ; pour compter les caracteres anormaux MOV E,C ; compteur de la boucle, car C sera modifie PRAT5: INX H ; caractere suivant MOV B,M ; charge CALL GETYP ; calcule son type CMP D ; il est normal ? JZ PRAT6 ; ouais INR C ; donc un slash en plus a editer PRAT6: DCR E ; decremente le p-length JNZ PRAT5 ; c'est pas fini CALL INLIN ; fait le test avec la vraie longueur POP H ; recupere l'objet MOV A,M ; recharge le p-length qui a peut-etre change CMP C ; d'ailleurs regardons JZ PRAT4 ; pas de caracteres anormaux, edition rapide MOV C,A ; charge p-length PRAT7: INX H ; caractere suivant MOV B,M ; charge CALL GETYP ; son type CPI CLNOR ; normal ? JZ PRAT8 ; ouais PUSH H ; sauve le symbole MVI B,'/' ; faut un slash CALL PRCH ; edite et ca tient POP H ; recupere le symbole MOV B,M ; recharge le caractere PRAT8: PUSH H ; sauve la suite CALL PRCH ; edite et ca tient POP H ; recupere la suite DCR C ; decremente p-length JNZ PRAT7 ; c'est pas fini RET .PAGE ;----- PRNUM : EDITE UN NB D'@ HL PRNUM: CALL EDNBR ; edition du nombre dans le buffer d'entree LDA MBUF ; la longueur de sa represntation MOV C,A ; en bonne place CALL INLIN ; terpri si besoin LXI H,MBUF ; sur le buffer d'entree MOV C,M ; la longueur PRNUL: INX H ; sur le premier caractere MOV B,M ; charge le caractere PUSH H ; sauve l'endroit CALL PRCH ; dans le buffer de sortie, ca tient POP H ; recupere le pointeur DCR C ; decremnte la longueur JNZ PRNUL ; ca roule RET ; voila ;----- EDNBR : edite un nombre dans le buffer d'entree ; ; HL = nombre ; au retour MBUF contient longueur suivie de la representation EDNBR: LXI D,MBUF ; sur le debut du buffer XRA A ; a <- 0 STAX D ; y a rien INR E ; sur le premier endroit EDNBRM: CALL VALNB ; desinterne et y a pas d'erreur LDA IBASE ; BASE DE SORTIE CPI 10 ; deicmale ? JZ PRDC ; nan PRHEX: ;;; impression de HL en pas decimal. XCHG ; HL sur BUFFER MVI M,'#' ; specificateur de sharp-macro INX H ; suivant MVI M,'$' ; specificateur de nombre hexa LXI H,MBUF ; sur la taille INR M JMP PRDCNF ; vers le commun .PAGE ;----- PRDC : edition d'un nombre dans une base quelconque PRDC: MOV A,H ; test du signe ORA A JP PRDC1 ; VERS NB >= 0. CALL CMPHL ; HL <- -HL XCHG ; HL sur le BUFFER MVI M,'-' ; le signe LXI H,MBUF ; sur la taille PRDCNF: INR M ; augmentee XCHG ; HL <- le nombre PRDC1: MOV A,H ORA L JZ PRHX3 ; 0 est 0, en voiture PRDC2: MVI D,0 ; BASE <256. LDA IBASE ; la base MOV E,A ; dans DE CALL DVD ; PUSH D ; SAUVE LE RESTE. MOV A,H ORA L ; QUOTIENT = 0 ? CNZ PRDC2 ; HE OUI: C'EST RECURSIF ! POP D MOV A,E ; le chiffre PRHX3: ; ADI '0' ; CPI '9'+1 ; LETTRE ? ; JC PRCH ; NAN : C'EST TOUT BON. ; ADI 7 ; PASSAGE AUX LETTRES. ; REMPLACE PAR LES 4 INSTRUCTIONS : ADI $90 ; QUI SONT ILLISIBLES ... DAA ACI $40 DAA ; VOILA C'EST PAS BEAU ... MOV B,A ; dans B LXI H,MBUF ; sur la taille INR M ; qui est augmentee MOV A,M ; et chargee ADD L ; pointe dans la premiere position libre MOV L,A ; voila MOV M,B ; range le caractere RET ; et c'est fini .PAGE ;----- PRSPC : edite un espace ou passe a la ligne si eol PRCH2S: CALL PRCHT ; pour ceux qui doublent PRCHTS: CALL PRCHT ; edite d'abord un caractere PRSPC: MVI B,$20 ; charge l'espace LDA XPLDI ; indicateur d'explode ORA A ; on y est JNZ PRCH1 ; oui : impression forcee MVI C,1 ; longueur d'un espace CALL INLIN ; vide si besoin LDA LBMIN ; teste si y a eu vidage CMP M ; i.e. poscour=lmargin RZ ; ouais, rien a faire JMP PRCH ; on l'edite ;----- PRCHT : edite le caractere dans B avec terpri eventuel PRASTI: ; cas de la profondeur depassee INR M ; remet la profondeur MVI B,'&' ; la caractere indicateur JMP PRCHT ; on l'edite PRCHT3: CALL PRCHT ; pour les 3 PRCHT2: CALL PRCHT ; pour les 2 PRCHT: MVI C,1 ; longueur d'un caractere CALL INLIN ; terpri eventuel ;;; PRCH doit suivre ;----- PRCH : edite le caractere dans B qui est cense tenir PRCH: LDA XPLDI ; on est dans EXPLODE ORA A JNZ PRCH1 ; ouais MVI A,OUBUF & $FF ; debut tampon LXI H,LBCOU ; pointe sur la position ADD M ; position courante INR M ; actualise la position MOV L,A ; dans L MVI H,OUBUF ^ ; fort tampon MOV M,B ; force le caractere dedans RET ; et voila .PAGE ;----- PRCH1 : allonge la liste du explode PRCH1: PUSH B ; sauve C (p-length dans le cas atome) MOV A,B ; remet dans A le caractere CALL CRANA ; creation de la valeur numerique (ASCII) XCHG ; et le tout dans DE. LHLD XPLDL ; recupere LAST de EXPLODE. CALL PLACPX ; on accroche SHLD XPLDL ; qui devient le new LAST. POP B ; restaure C (et B mais on s'en fout) RET ; c'est tout. .PAGE ;----- INLIN : test si C caracteres tiennent dans la ligne ; sinon TERPRI apres test de PRLCOU ; au retour HL pointe sur LBCOU INLIN: LXI H,LBCOU ; taille courante LDA XPLDI ; indic explode ORA A ; on y est ? RNZ ; ouaip, pas de terpri LDA LBMAX ; taille max SUB M ; ce qui reste SUB C ; ce qui restera RP ; c'est bon LHLD PRLCOU ; nombre de lignes restant MOV A,H ; on a encore droit ? ORA L JNZ INLNR ; ouais, on vide LHLD SENBLO ; non, recupere l'endroit d'appel SPHL ; abandonne toute l'impression RAZBUF: ; efface le buffer LXI H,OUBUF ; debut du tampon MVI A,$20 ; il faut des espaces MVI C,$80 ; 128 pour etre precis RZBUFL: MOV M,A ; force un espace INX H ; avance DCR C ; un de moins JNZ RZBUFL ; ca roule RAZBOR: LDA LBMIN STA LBCOU ; revient a la case depart XRA A RET ; retour tres tres rapide INLNR: DCX H ; une ligne de moins SHLD PRLCOU ; nouveau nombre de lignes permis PUSH B ; sauve la longueur CALL COLEOL ; appel de la fonction redefinissable POP B ; recupere la longueur LDA LBMAX ; et on reteste! LXI H,LBCOU ; car les marges peuvent etre deconnantes SUB M ; ce qui reste SUB C ; ce qui restera RP ; ok, on continue XRA A STA LBMIN ; remet la marge gauche LXI B,.PRIN EROOL: LXI H,NIL ; pas d'argument reel LXI D,.MSOOB JMP CALSR .PAGE ;***** (EOL) [SUBR 0] COLEOL: LXI H,.EOL ; la fonction de fin de ligne JMP EVRPN ; on l'applique EOL: CALL FLUSU ; vide le tampon PUSH H ; SAUVE T CALL PCRLF ; edite rc/lf POP H ; recuper T RET ;***** (FLUSH) [SUBR 0] FLUSU: LDA LBMAX ; partons de la fin ADI OUBUF & $FF MOV L,A ; faible MVI H,OUBUF ^ ; fort EOLTS: MVI A,$20 ; pour comparer CMP M ; on pointe sur un espace ? JNZ EOLOU ; nan, on a la longueur min DCR L ; un espace de moins a sortir MVI A,OUBUF & $FF CMP L JNZ EOLTS ; c'est pas un buffer vide MOV L,A EOLOU: MOV C,L ; C <- la derniere position significative MVI L,OUBUF & $FF ; au debut JMP EOLT ; en voiture EOLL: MOV B,M ; charge le caractere MVI M,$20 ; et le remplace par un espace INR L ; pour le suivant PUSH H ; sauve l'index CALL OUTB ; sort le caractere POP H ; recupere l'index EOLT: MOV A,C ; pour comparer CMP L ; on est arrive ? JNC EOLL ; nan CALL RAZBOR ; init des indicateurs LXI H,.T ; faut bien ramener quelque chose RET PCRLF: MVI B,$D ; sort un return CALL OUTB MVI B,$A ; sort un line-feed JMP OUTB ; et voila .PAGE ;***** (TERPRI N) [SUBR 1] TERPR: PUSH H ; la valeur de retour CALL COLEOL ; vide la ligne POP H ; recupere l'arg RFNUM H ; tout est fini MOV C,L ; le compteur MVI B,$A ; line feed pour les intimes DCR C ; n-1 fois PUSH H ; sauve la valeur de retour JMP TERPF ; en voiture TERPI: CALL OUTB ; edite LF TERPF: DCR C ; il en reste ? JP TERPI ; ouaip POP H ; recupere le nombre RET ; et voila ;***** (EXPLODE S) [SUBR 1] EXPLO: PUSH H ; SAUVE L'ARGUMENT. CALL NCNSN ; CRE LE 1ER (NIL . NIL) SHLD XPLDL ; SUAAVE DANS LAST EXPLODE. POP D ; recupere l'arg PUSH H ; sauve le premier doublet LXI B,POPCDR ; l'adresse de retour PUSH B ; tout est en place LXI B,XPLDI ; l'indicateur LXI H,PROBJ ; ce qu'il faut faire JMP BINDI1 ; construit un bloc BIND interne et fait tout .SBTTL; Organisation de la memoire ; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ; !! !! ; !! ATTENTION !! ; !! !! ; !! ICI COMMENCE LE DECOUPAGE EN ZONE !! ; !! SELON LE POIDS FORT DES ADDRESSES !! ; !! !! ; !! LA CONNAISSANCE DE CE DECOUPAGE !! ; !! EST INDISPENSABLE A LA COMPREHENSION !! ; !! DE LA GESTION DES BLOCS DE CONTROLE !! ; !! ET A L'AJOUT DE FONCTIONS PREDEFINIES !! ; !! !! ; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ; Chaque page memoire ci-apres est caracteristique d'un ; certain etat de la pile a l'appel de EVAL (que ce soit ; un appel direct ou un appel a des modules appelant ; EVAL sans adresse de retour: PROGN etc) ; ; L'ajout d'une fonction predefinie doit donc se faire dans la ; zone caracteristique de son mode d'appel; en cas de doute ; la mettre dans la zone F qui est totalement ignoree ; des modules de lecture dans l'incorruptible pile. ; Ce decoupage permet de connaitre le type d'appel precedent ; par simple consultation du poids fort de l'adresse de retour ; se trouvant dans la pile: il n'y a qu'un appel a EVAL ; par zone (mais il peut y avoir appel a des modules appelant ; par une instruction CALL le module EVAL, cf EVARG ...) ; 1) realisation des echappements ; Les blocs de controles sont divises en deux catagories: ; les blocs de restaurations et les blocs d'echappement. ; Les blocs de restauration contiennent a leur debut ; un pointeur vers la fin du bloc et un pointeur sur le debut ; du bloc precedent. Lorsque qu'un echappement est provoque', ; les blocs de sauvegarde sont visite's et le pointeur de fin ; de bloc est remplace' par le pointeur sur le debut du bloc precedent. ; Le depilement d'un bloc de sauvegarde se compose d'une phase de ; restauration, puis de l'affectation du pointeur de pile par le ; pointeur de fin de bloc. Si aucun echappement n'avait eu lieu, ; cela n'a aucun effet et un retour normal est effectue'. ; Sinon le retour se fera directement sur le module de destruction ; du bloc suivant. ; Les blocs d'echappement ont tous comme deuxieme mot une certaine ; valeur initiale. Si un echappement se produit, il affectera les ; blocs de sauvegarde comme il vient d'etre dit, ju'a rencontre ; d'un bloc d'echappement, ou il remplacera le deuxieme mot par le nom ; de l'echappement provoque'. Le depilement se fait en comparant le ; deuxieme mot avec la valeur initiale. S'il n'y pas egalite, c'est donc ; un echappement qui est alors relance'. .PAGE ; 2) interpretation iterative des blocs ; TAG, BIND, WHERE, LAMBDA ; Avant de construire un de ces blocs, on s'assure que leur effet ; ne sera pas masque par la presence d'un meme bloc avant eux ; dans la pile: arret d'echappement ou restauration de valeurs. ; S'il en est ainsi, le bloc de controle ne sera pas construit ; permetant ainsi une economie de pile et de temps. ; La detection d'inutilite du bloc se fait par une descente ; iterative dans la pile, cherchant un bloc identique a celui ; en cours de construction. ; Cette descente est rapide car chaque appel a EVAL permet ; de pointer directement sur l'appel precedent, soit parce ; qu'un pointeur vers cet appel est fourni (cas EXPR, LAMBDA ; FLET, BIND et NSUBR), soit parce que le nombre de mots empiles ; est constant pour ce type d'appel (tous les autres cas). ; Cette descente s'effectue tant qu'on a pas trouve un tel bloc ; et tant qu'on ne rencontre pas un appel demandant expressement ; la construction du bloc. ; Cette demande est principalement le fait des routines evaluant ; les arguments des fonctions avant leurs lancements. ; A l'inverse chacun de ces quatre blocs n'exige aucune ; construction de la part des trois autres. ; Cette reciprocite est particulierement heureuse, car autrement ; il y aurait empilement d'un bloc indestructible mais permettant ; la destruction des autres, ce qui occasionnerait une longue ; descente dans la pile dans le cas d'une recursivite ; incluant ce bloc, a la recherche d'un appel significatif. ; Ainsi il n'y aura pas de debordement de pile ; pour des fonctions aussi complexes que: ; ; (lambda ... ; (tag foo ... ; (flet ... ; (tag bar ... ; (self ...))))) .PAGE ; 3) interpretation semi-iterative des blocs LAMBDA ; Dans ces cas, la descente dans la pile s'effectue tant que: ; * soit la reutilisation de l'environnement ; est specifiee (rencontre d'une FSUBR, ; d'un bloc PROTECT ou LOCK ou d'une EXPR differente de ; la fonction appelee) ; La construction du bloc a alors lieu ; * soit l'absence de reutilisation est assuree: ; on a trouve l'appel de la meme lambda, apres ; eventuellement l'appel de tous les autres cas ; (LAMBDA differente, TAG, BIND, ; EXPR IDENTIQUE, 1SUBR, 2SUBR, 3SUBR et NSUBR) ; Ce plus large eventail d'autorisation par rapport aux blocs ; TAG et BIND et FLET, provient du fait que les SUBRS et EXPRS ; n'utilisent pas l'environnement appele, mais peuvent utiliser ; les valeurs des variables fonctions, et etre reprises par ; les echappements. ; Mais ces cas supplementaires ne sont pas en reciprocite ; avec le bloc lambda, contrairement aux autres blocs. ; Aussi pour eviter l'etagement de ces appels non ; significatifs du point de vue de la construction du bloc, ; un bloc sans sauvegarde de l'environnement est construit. ; Le gain d'espace pile est donc plus faible, mais le gain de ; temps reste intact car le test d'utilite de construction ; reste independant du nombre d'appel recursif de la fonction. ; ; Toutefois il existe un cas ou la reciprocite a lieu. ; Il s'agit de NSUBRs possedant la propriete suivante: ; (f e1 . . . en (f s1 . . . sm)) ; = (f e1 . . . en s1 . . . sn) ; Pour ces fonctions un test de recursivite terminale est ; egalement fait et en cas de reussite les deux appels sont ; confondus en un seul; la trace des appels recursifs a alors ; disparu et le bloc sans sauvegarde est alors inutile. ; On distinguera donc ces MSUBRs des autres NSUBRs. ; ; Pour reperer les differents cas de recursivite, ; les appels a EVAL qui ne construisent pas de bloc de controle ; sont egalement repartis dans differentes pages de la memoire. ; L'evaluation des arguments d'une fonction de n'importe quel ; type s'effectue toujours selon le principe suivant: evaluation ; des arguments sauf le dernier par un sous-programme dans une ; zone ignoree par les tests de recursivite terminale, puis remise ; en sommet de pile de l'adresse de la fonction (ou de son traitement ; dans le cas des EXPRs) avant de lancer l'evaluation du dernier ; argument par un saut (et non un appel) a EVAL. ; La lecture du dernier mot empile est ainsi caracteristique de ; l'appel en cours. .PAGE ; Cette repartition correspond PRESQUE a celle des ftypes, ; cependant certaines SUBRS se comportent comme des FSUBRs ; c'est a dire appellent EVAL, donc reutilisent l'environnement ; (par exemple EVAL lui-meme, APPLY, EVLIS ...), tandis que ; certaines FSUBR n'appellent pas EVAL (par exemple PROG1). ; Ces reserves faites, on peut dire que la memoire ; est organisee de la maniere suivante: ; ; ; !---------------! ; ! F ! fsubr ; !---------------! ; ! E ! expr ; !---------------! ; ! N ! nsubr ; !---------------! ; ! M ! msubr ; !---------------! ; ! 3 ! 3subr ; !---------------! ; ! 2 ! 2subr ; 7 - 1000l$$1000t$$ ; !---------------! ; ! 1 ! 1subr ; !---------------! ; ! V ! verrou (lock) ; !---------------! ; ! P ! protect ; !---------------! ; ! T ! tag ; !---------------! ; ! B ! bind ; !---------------! ; ! W ! where ; !---------------! ; ! L ! lambda ; !---------------! ; ! R ! recursivite terminale ; !---------------! ; On notera la contiguite des zones contenant un bloc de controle ; et celles des blocs de sauvegarde d'une part et d'echappement d'autr ; part, ce qui minimise la taille des tables d'appartenance, ; et l'absence d'appels a EVAL apres la zone R (en particulier ; l'interdiction d'avoir ici la zone du compilateur), ce qui ; permet un test unique d'appartenance a la table de debranchement .PAGE .SBTTL; ZONE F : Fonctions de definition ;***** DMC, DM, DF, DE DM: MVI A,18 ; F-TYP = MACRO LXI B,.DM ; en cas d'erreur JMP DEF1 DF: MVI A,16 ; F-TYP = FEXPR LXI B,.DF JMP DEF1 DMC: LXI B,.DMC ; en cas d'erreur PUSH H ; sauve tout (pour DE) MOV D,M ; DE <- le nom INR L MOV E,M LXI H,CLMAC ; nouveau type de caractere CALL TCSEN ; on le definit POP H ; recupere toute la forme ;;; DE doit suivre DE: MVI A,14 ; F-TYP = EXPR LXI B,.DE DEF1: STA EEXNC ; memorise le f-type CALL VARCAR ; seoare le nom et le controle PUSH H ; sauve ((LVAR) .. BODY .. ) PUSH D ; sauve le nom MOV A,M INR L ; HL <- (LVAR) MOV L,M MOV H,A LXI D,$FFFF ; MARQUEUR PUSH D ; DE FIN DE RECURSION JMP DEF3 ; AU BOULOT .PAGE DEF31: .UNCNS ; DEUX VERIFS XCHG ; LE CAR D'ABORD PUSH D ; PLUS TARD JTNIL H,ERLIP ; PAS NIL EN PARAMETRE ! DEF3: JTLST H,DEF31 ; C'EST PAS FINI JTNUM H,ERLIP ; PAS DE NOMBRE ! POP H ; PASSONS AU SUIVANT MOV A,H ; MAIS EN RESTE-IL ? INR A JNZ DEF3 ; BAH OUI DEF5: POP H ; HL <- le nom POP D ; DE <- ((LVAR) .. BODY ..) PUSH H ; SAUVE LE NOM (VAL DE LA FNT). INR L INR L INR L INX H ; HL POINT SUR F-VAL. MOV M,E ; force la F-VAL. INR L MOV M,D INR L LDA EEXNC ; recupere le f-type MOV M,A ; le force POP H ; RECUP LE NOM. RET ; VOI. .PAGE .SBTTL; Zone F : fonctions d'affectation ;***** (SETQ A1 S1 ... AN SN) [SUBR F] SETQX: XCHG ; HL <- les args SETQ: LXI B,.SETQ ; en cas d'erreur CALL VARCAR ; DE <- (CAR HL) HL <- (CDR HL) PUSH D ; SAUVE LE NOM. CALL EVARG ; EVALUE LA VAL. POP B ; recupere le nom MOV A,H ; forte valeur STAX B ; affecte la c-val INR C ; rebelotte faible MOV A,L STAX B ; voila JTLST D,SETQX ; y en a encore RET ; la derniere est dans HL .PAGE ;***** (NEXTL AT) [SUBR F] ; (PROG1 (CAR AT) (SETQ AT (CDR AT))) .IFNE BIG NEXTL: LXI B,.NEXTL ; en cas d'eereur CALL VARCAR ; separe et controle XCHG ; HL <- la variable PUSH H ; SAUVE LE NOM DE L'ATOME MOV A,M INR L MOV L,M MOV H,A ; HL <- CVAL DE L'ATOME .UNCNS XCHG ; HL <- CAR DE CVAL, DE <- CDR CVAL XTHL ; HL <- L'ATOME MOV M,D ; FAIT LE (RPLACA AVEC LE CDR DE CVAL) INR L MOV M,E POP H ; RECUP LE CAR DE LA CVAL RET ; VOILA .ENDC ; de BIG .PAGE ;***** (NEWL AT S) [SUBR F] ; (SETQ L (CONS AT (CVAL L))) .IFNE BIG NEWL: LXI B,.NEWL ; en cas d'erreur CALL EVSET ; BC <- (CAR HL) DE <- (CVAL (CAR HL)) HL <- (EVAL (CADR HL)) PUSH B ; sauve e nom CALL CONS ; ajoute l'entete ASET: POP D ; RECUPERE LE NOM ASETX: XCHG ASETP: MOV M,D INR L MOV M,E XCHG ; RAMENELE 2EME ARG. RET ;***** (NEWR L AT) [FSUBR] ; ; (SETQ L (NCONC L (CONS (EVAL AT)))) et non seulement (NONC L ... !!! NEWR: LXI B,.NEWR ; en cas d'erreur CALL EVSET PUSH B ; sauve le nom PUSH D ; sauve la c-val CALL NCONS ; fabrique le dernier doublet POP D ; la c-val JFLST D,ASET ; pas de debut de liste, vers SETQ POP PSW ; le nom on s'en fout PUSH D ; le debut de laliste aramener CALL CONCX ; on accroche POP H ; le debut RET ; et voila .ENDC ; de BIG .PAGE ;***** (INCR at n) [SUBR F] ;***** (DECR at n) [SUBR F] .IFNE BIG DECR: LXI B,.DECR ; EN CAS D'ERREUR JMP NCR ; ET C'EST COMME INCR FINCR: LXI B,.INCR ; atome INCR si erreur NCR: PUSH B ; sauve le nom de la fonction CALL EVSET ; controle, evalue, charge JFNIL H,NCR1 ; y a le deuxieme arg LXI H,1 ; 1 par defaut NCR1: XTHL ; Pile:: ... INCREMENT] PUSH H ; Pile :: ... INCREMENT FONCTION] MOV H,B ; HL <- nom de la variable MOV L,C POP B ; BC <- fonction XTHL ; HL <- incremen (SP) <- variable CALL VALN2 ; desinterne les deux MOV A,C ; faible de la fonction CPI .DECR & $FF ; c'est decr ? CZ CMPHL ; ouaip, faut l'inverse DAD D ; on fait l'incrementation CALL CRANB ; on interne la valeur JMP ASET ; on force la nouvelle val .ENDC ;de BIG .PAGE .SBTTL; Zone F : Fonctions de controle ;***** (SELF E1 ... EN) [SUBR F] SELF: XCHG ; DE <- LES ARGS LHLD SELFM ; LA FONCTION EN COURS MOV A,H ; Y EN A-T-IL UNE INR A JNZ ESELF ; OK, COMME SI DE RIEN N'ETAIT JMP SELFR ; ON EST AU TOPLEVEL !!! ;***** (WHILE E1 ... SN) [SUBR F] WHIL1: CALL PROGX ; EVALUE LE CORPS DE LA BOUCLE. POP H ; RECUP (E S1.SN) WHILE: PUSH H ; SAUVE (E S1 ...S N) CALL EVPRD ; EVAL LE 1ER. JNZ WHIL1 ; C'EST PAS NIL. POP D ; NETTOIE LA PILE. RET ; ET RENTRE. ;***** (UNTIL E1 ... SN) [SUBR F] .IFNE BIG UNTI1: CALL PROGX ; EVALUE LE CORPS DE LA BOUCLE. POP H ; RECUP (E S1.SN) UNTIL: PUSH H ; SAUVE (E S1 ...S N) CALL EVPRD ; EVAL LE 1ER. JZ UNTI1 ; C'EST PAS NIL. POP D ; NETTOIE LA PILE. RET ; ET RENTRE. .ENDC ;***** (REPEAT n s1 ... sN) [SUBR F] REPT: CALL EVARG ; evalue n PUSH D ; sauve le corps s1 ... sN LXI B,.REPT ; atome REPEAT en cas d'erreur CALL VALNB ; HL <- val de n JMP REPT5 ; au boulot REPT1: PUSH D ; SAUVE LE CORPS PUSH H ; SAUVE LE COMPTEUR CALL PROGX ; EVALUEX LEX CORPSX POP H ; RECUPERE LE COMPTEUR REPT5: POP D ; RECUPERE LE CORPS DCX H ; OU EN EST-ON ? MOV A,H ; pour le test ORA A JP REPT1 ; c'est toujours positif JMP TRUTH ; il ramene toujours T .PAGE ;***** (COND CL2 ... CLN) [SUBR F] COND0: POP H ; RECUP LE RESTE DES CLAUSES COND: RFLST H ; EN A PU (OLD **ER A3). .UNCNS XCHG ; HL <- 1ER CLAUSE, DE <- LE RESTE. PUSH D ; SE RESTE DES CLAUSES. CALL EVPRD ; EVAL LE PREDICAT. JZ COND0 ; CA A PAS ETE. POP B ; NETTOIE LA PILE. RFLST D ; PAS DE CORPS, RAMENE LE PREDICAT JMP PROGX ; EVALUE L'ACTION. ;***** (SELECTQ cl1 ... clN clFAIL) [SUBR F] .IFNE BIG SELQ: CALL EVARG ; EVALUE le selecteur MOV B,H MOV C,L ; BC LE SELECTEUR. XCHG ; HL LES CLAUSES JMP SELQ1 ; AU BOULOT .PAGE SELQ2: PUSH H ; SAUVE RESTE DES CLAUSES PUSH D ; SAUVE LA CLAUSE EN COURS PUSH B ; SAUVE LE SELECTEUR LDAX D ; PRELEVE LE CHAMP MOV H,A ; DANS A INR E LDAX D MOV L,A MOV D,B ; ET PLACE LE SELECTEUR MOV E,C CALL MEMBER MOV A,H ; SAUVE LE RESULTAT DE MEMBER POP B ; RESTAURE SELECTEUR POP D ; CLAUSE EN COURS POP H ; RESTE DES CLAUSES CPI HNIL ; TESTE ENFIN LE RESULTAT JNZ PROGDX ; OK (EPROGN (CDR DE)) SELQ1: JFLST H,FALSE ; y a plus rien .UNCNS ; DE <- CAR HL HL <- CDR HL JTLTA D,SELQ2 ; c'est une liste = use MEMBER LDAX D CPI .T ^ ; c'est la clause generale ? JNZ SELQ3 ; nan INR E ; rebelotte faible LDAX D DCR E ; pour etre synchrone CPI .T & $FF JZ PROGDX ; c'est elle LDAX D ; recharge le fort car SELQ3: CMP B JNZ SELQ1 ; COMPARE BC INR E LDAX D CMP C JNZ SELQ1 ; AU SUIVANT DONC. DCR E ; REPASSE AU DEBUT JMP PROGDX .ENDC ; de BIG .PAGE .IFNE BIG ;***** (WHEN b v1 ... vn) [SUBR F] WHEN: CALL EVPRD ; EVALUE LE TEST RZ ; RIEN A FAIRE JMP PROGX ; EVALUE ;***** (UNLESS b f1 ... fn) [SUBR F] UNLES: CALL EVPRD ; EVALUE LE TEST JNZ FALSE ; c'est pas NIL donc c'est NIL !!! JMP PROGX ; EVALUE LA SEQUENCE ;***** (IFN b f v1 ... vn) [SUBR F] AIFN: CALL EVPRD ; EVALUE LE TEST JZ EVCAX ; EVALUE L'UNIQUE FORME JMP PROGDX ; EVALUE LA SEQUENCE .ENDC ; DE BIG .PAGE ;***** (OR e1 ... en) [SUBR F] AOR0: POP D ; RECUPERE LE RESTE DE LA SEQUENCE RFNIL H ; L'EVALUATION PRECEDENTE EST VRAIE XCHG ; HL <- LA SEQUENCE AOR: LXI B,AOR0 ; PREPARE LE RETOUR SI SEQUENCE PAS VIDE JMP PROGT ; VERS L'ADMINISTRATEUR DES SEQUENCES ;***** (AND e1 ... en) [SUBR F] AAND: JFLST H,TRUTH ; (AND) --> T LXI B,AAND0 ; PAS DE JMP POUR SI PEU, VOIR PLUS LOIN JMP PROGT ; CA RECOMMENCE APRES AAND0: POP D ; RECUPERE LA SEQUENCE RTNIL H ; L'EVALUATION PRECEDENTE EST FAUSSE XCHG ; HL <- LA SEQUENCE LXI B,AAND0 ; PREPARE LE RETOUR SI SEQUENCE PAS VIDE JMP PROGT ; VERS L'ADMINISTRATEUR DES SEQUENCES ;----- WILT : boucle d'appel infinie a PROGN WILTX: XCHG WILT: PUSH H ; sauve la sequence CALL PROGN ; l'evalue POP H ; la recupere JMP WILT ; encore et toujours, et meme : indefiniment .PAGE ;***** (IF b v f1 . . . fn) [SUBR F] ;***** (PROGN e1 ... eN) [SUBR F] ;***** (EPROGN l) [SUBR 1] AIF: CALL EVPRD ; EVALUE LE TEST JNZ EVCAX ; EVALUE L'UNIQUE FORME PROGDX: ; (EPROGN (CDR DE)) XCHG PROGD: ; (EPROGN (CDR HL)) INR L INR L MOV D,M INR L MOV E,M PROGX: ; (EPROGN DE) XCHG PROGN: ; [SUBR 1] EPROGN [SUBR F] PROGN RFLST H ; YA RIEN A FAIRE.. PUSH H ; PLUS CONCIS QUE JMP ; PROG0 DOIT SUIVRE PROG0: ; BOUCLE D'EVALUATION DE LA SEQUENCE POP H ; RECUPERE LA SEQUENCE LXI B,PROG0 ; ADRESSE DE RETOUR SI PAS FINI ; PROGT DOIT SUIVRE ; POINT D'ENTREE DES SEQUENCEURS ; HL = LA SEQUENCE A EVALUER ; BC = L'ADRESSE DE RETOUR SI (CDR HL) N'EST PAS NIL ; CE SOUS-PROGRAMME DOIT ETRE UTILISE PAR TOUS LES SEQUENCEURS ; POUR PERMETTRE LE TRAITEMENT DES ENVIRONNEMENTS PERIMES ; ACTUELLEMENT EST UTILISE PAR: ; PROG0 AOR0 AAND0 PROGT: .UNCNS ; SEPARE LA SEQUENCE JFLST H,EVALX ; C'EST LE DERNIER, L'EVALUE SANS EMPILER PUSH H ; SAUVE LE CDR DE LA SEQUENCE PUSH B ; PREPARE LE RETOUR EN DEBUT DE BOUCLE JMP EVALX ; EN FAIT C'EST CALL .PAGE .SBTTL; Zone F : fonctions manipulant l'environnement ;***** (LAMBDA . BODY) [SUBR F] ;***** (MLAMBDA . BODY) [SUBR F] ;***** (FLAMBDA . BODY) [SUBR F] FMLAMB: FFLAMB: FLAMB: LHLD FORM RET ;**** (ENV AL . BODY) [SUBR F] ; e'value AL , puis execute le corps dans l'environnement ; donne' par la a-liste ; ATTENTION : l'elimination du bloc de controle n'est pas ; permise car ce ne seront pas necessairement les memes ; variables qui seront lie'es. ; Il convient donc : ; 1) de ne pas faire le test de recursivite' terminale ; 2) de signaler aux autres blocs qu'il ne sera pas de'truit ; pour ce faire on emplie une adresse dans la zone 1 ; afin de faire croire a une enveloppe, donc autorisation ; de construire un bloc dans la zone R. LETQ: LXI B,POPJ1 ; pour les test de tail-recs PUSH B ; ca fait croire a une enveloppe PUSH H ; SAUVE TOUTE LA FORME CALL EVCAR ; EVALUE L'ENVIRONNEMENT XCHG ; DE <- A-LISTE LXI H,2 DAD SP ; calcul la fin du bloc SHLD ENBLO ; range' LHLD SELFM ; pour compatibilite avec les lambda XTHL ; voila, et recupere la forme SHLD FONCT ; sauve la forme JMP LETQT ; et en voiture pour les liaions, dans la page des L. ;***** (ENVQ AL . BODY) [SUBR F] LETQQ: CALL TVPALL ; TEST D'ENVIRONNEMENT PERIME ET CALCUL D'ENBLO PUSH PSW ; SAUVE L'INDICATEUR D'ENVELOPPE A PRIORI JZ SLTQT ; CA MARCHE, LIAISON SIMPLE XTHL ; ENV! SONT TRANSPARENTES A SELF JMP LETQT ; en voiture .PAGE LETQL: XCHG ; HL <- LA A-LISTE .UNCNS ; HL <- LA SUITE PUSH H ; FAIT DE LA PLACE LXI B,.ENV ; en cas d'erreur CALL VARCAX ; separe et controle si c'est une variable XCHG ; HL <- nom DE <- val .XCVAL ; BC <- (CVAL HL) (CVAL HL) <- DE POP D ; RECUPERE LA SUITE PUSH B ; SAUVE L'ANCIENNE C-VAL PUSH H ; SAUVE LE NOM LETQT: JTLST D,LETQL ; AU SUIVANT LHLD FONCT ; RECUPERE TOUT JMP LETF ; VERS LA FIN DE LA CONSTRUCTION DU BLOC .PAGE .SBTTL; Zone F : fonctions d'applications ;***** (MAPC F E1 . . . . EN) [SUBR N] ;***** (MAPCAR F E1 . . . . EN) [SUBR N] ;***** (MAPCAN F E1 . . . . EN) [SUBR N] ;***** (MAP F E1 . . . . EN) [SUBR N] ;***** (MAPLIST F E1 . . . . EN) [SUBR N] ;***** (MAPCON F E1 . . . . EN) [SUBR N] ; Toutes ces fonctions sont realisees par un seul module ; parametre par deux adresses de sous-programme: l'un ; traitant les entrees (appliquer sur le CAR ou identite) ; l'autre traitant le resultat de l'application (rien, ; CONS, NCONC). ; La methode d'accrochage de bord est utilisee, ce qui ; rend ces fonctions iteratives. ; la fonction d'application utilisee est FUNCALL et non ; APPLY ce qui evite des CONS inutiles. ; Il s'agit donc de simuler un appel a FUNCALL. ; Un saut (et non un appel) est donc provoque vers FUNCALL ; avec l'etat de pile suivant: ; [ a'n ] partie du n-ieme argument ; [ ... ] ; [ a'1 ] partie du premier argument ; [ f ] la fonction a appliquer ; [ $FFFFF ] marqueur de fin ; [ OUT ] retour de FUNCALL vers traitement ; [ resultat ] precedent resultat (pour accrochage) ; [ IN ] traitement des entrees ; [ ------------ pointeur pour commencer a l'envers ; [ $FFFF ] ! marqueur pour operer a l'envers ; [ an ] ! argument initial puis ses CDR ; [ ... ] ! ; [ a1 ]<-- meme chose ; [ f ] la fonction ; [ resultat ] resultat a retourner (ex $FFFF) ; ; et HL pointera sur OUT .PAGE ;----- CHARGEMENT DES PARAMETRES DES MAPxxx .IFNE BIG MAPC: PUSH H ; sauve last LXI H,NIL ; le resultat LXI D,CARIN ; Il faut prendre les CAR LXI B,MAPNIL ; il faut rien faire en sortie JMP MAP1 ; au boulot MAPCAR: PUSH H CALL NCNSN LXI D,CARIN LXI B,MAPONS JMP MAP1 MAPCAN: PUSH H CALL NCNSN LXI D,CARIN LXI B,MAPONC JMP MAP1 MAP: PUSH H LXI H,NIL LXI D,CDRIN LXI B,MAPNIL JMP MAP1 MAPLIS: PUSH H CALL NCNSN LXI D,CDRIN LXI B,MAPONS JMP MAP1 MAPCON: PUSH H CALL NCNSN LXI D,CDRIN LXI B,MAPONC JMP MAP1 .PAGE ;----- PRELUDE ET POSTLUDE DU TRAITEMENT DES MAPxxx MAP1: XCHG ; HL <- IN DE <- RESULTAT SHLD MAPIN ; range le IN POP H ; recupere last arg MOV A,H ; test 0 arg INR A JZ ERMAP ; pas de fonction ! XTHL ; range last arg, recupere pointeur DCX H ; pointe sur $FFFF MOV M,D ; remplace par le resultat DCX H ; rebelotte faible MOV M,E DCX H ; pointe sur la fonction PUSH H ; fait de la place LXI H,$FFFF ; on opere a l'envers XTHL ; voila un beau marqueur DCX H DCX H ; pointe sur le premier arg de la fonction MOV A,M ; y en a un ? INR A JNZ MAP2 ; OK en voiture MAP3: ; fin des maps INX H ; sur la fonction INX H ; la saute INX H SPHL ; abandonne les arguments POP H ; le premier doublet cree ou NIL INR L INR L MOV A,M ; prend le cdr INR L MOV L,M MOV H,A RET ; et voila .PAGE ;----- BOUCLE D'APPLICATION DES MAPxxx MAP4: POP H ; rentree de OUT apres traitement du resultat SHLD MAPIN ; remet IN POP H ; le pointeur sur la premiere liste MAP2: PUSH H ; simple consultation JFLST M,MAP3 ; c'est la fin INX H INX H ; pointe sur a fonction PUSH H ; fait de la place LHLD MAPIN ; en cas d'appel recursif XTHL ; il faut le sauver PUSH D ; sauve le resultat provisoire PUSH B ; prepare le retour de FUNCALL vers OUT LXI B,$FFFF ; Le marqueur pour FUNCALL PUSH B MOV D,M ; prend la fonction DCX H MOV E,M PUSH D ; premier arg de FUNCALL DCX H ; pointe sur la premiere liste XCHG ; dans DE LXI H,1 ; pour pointer sur la forte fonction DAD SP SHLD ENBLO ; tout ca c'est pour FUNCALL LDAX D ; fort premier MOV B,A ; et c'est parti MAP5: DCX D ; boucle de preparation des arguments LDAX D ; passe au faible MOV C,A ; BC = arg JFLST B,MAP6 ; les atomes sont transmis tels quels LHLD MAPIN PCHL ; l'execute et revient ici MAP7: INX D ; repasse a la forte MOV A,H ; fort CDR STAX D ; range DCX D MOV A,L ; rebelotte STAX D ; tout est pret pour l'appel suivant MAP6: PUSH B ; l'argument tout pret DCX D ; au suivant LDAX D MOV B,A INR A ; s'il en reste JNZ MAP5 ; OUI LHLD ENBLO ; recupere le pointeur JMP MAPFNC ; applique .PAGE ;----- TRAITEMENT DES ARGUMENTS ET RESULTATS DES MAPxxx CARIN: MOV H,B MOV L,C .UNCNB ; separe JMP MAP7 ; c'est tout CDRIN: MOV H,B MOV L,C ; BC est l'arg INR L ; prend le CDR INR L MOV A,M INR L MOV L,M MOV H,A JMP MAP7 MAPNIL: POP D ; recupere le NIL LXI B,MAPNIL ; nommez-vous ! JMP MAP4 ; c'est tout MAPONS: .PLACE ; (RPLACD (POP) (LIST HL)) LXI B,MAPONS JMP MAP4 MAPONC: POP D ; le precedent CALL TCONC ; accroche DE a HL LXI B,MAPONC JMP MAP4 .ENDC ; de BIG .PAGE ;***** (MAPCOBLIST fnt) [SUBR 1] MPOBL: PUSH H ; sauve la fonction CALL NCNSN ; doublet d'init POP B ; la fonction PUSH H ; pour le retrouver a la fin XCHG ; DE <- doublet LHLD CATOL ; premier symbole MPOBLL: PUSH B ; sauve la fonction PUSH H ; sauve l'atome courant PUSH D ; sauve le resultat precedent LXI D,MPOBS ; prepare le retour en fin de boucle PUSH D ; voila LXI D,$FFFF ; marqueur de fin d'arg NSUBR PUSH D PUSH B ; premier arg de FUNCALL : la fonction PUSH H ; deuxieme : l'atome LXI H,3 DAD SP ; pour pointer sur la forte fonction LXI B,.MPOB ; en cas d'erreur JMP MAPFNC ; applique et revient ici MPOBS: POP D ; resultat precedent CALL TCONC ; accrcoche POP H ; dernier atome (DE resultat) CALL NATOM ; atome suivant POP B ; fonction JNZ MPOBLL ; y en a encore POP H ; tout premier doublet JMP CDRNT ; et c'est tout ;***** (OBLIST) [SUBR 0] OBLST: LXI D,NIL ; CREATION LISTE A L'ENVERS. LHLD CATOL ; premier atome OBLS1: XCHG PUSH D CALL XCONS XCHG POP H ; precedent atome CALL NATOM ; suivant JNZ OBLS1 ; il en reste XCHG RET NATOM: ; passe a l'atome suivant HL dans HL LXI B,8 DAD B ; POINT SUR NEW A-LINK. MOV A,M INR L MOV H,M ; HL <- a-link de HL MOV L,A ORA H ; FIN LATOM (0) ? RET ; l'indic est positionne .PAGE ;***** (APPLY fnt lval) [SUBR 2] ;***** (FUNCALL fnt e1 . . . en) [SUBR N] APPLY: POP D XCHG APPLYP: SHLD FNTEV ; EN CAS D'ERREUR LXI B,.APPLY ; idem JTLST H,APPLY1 ; c'est une LAMBDA (on espere ...) CPI HATOM ; ce doit etre un nom MVI A,APLYT ^ ; ca devrait etre bon JNC APFNC ; ok vers le debranchement JMP ERUDF ; vers le message FUNCAD: ; point d'entree interne DAD SP ; ca donne le pointeur PUSH H ; et ca le met FUNCAX: ; encore un autre XCHG ; HL <- last arg FUNCAL: ; on le met a LXI B,.FNCL ; en cas d'erreur MOV A,H ; test 0 arg INR A JZ ERUDFF ; quoi ?! XTHL ; recupere le pointeur et range le der DCX H ; saute le marqueur DCX H DCX H ; pointe sur forte fonction MAPFNC: MOV D,M ; la charge DCX H MOV E,M XCHG ; HL <- la supposee fonction SHLD FNTEV ; en cas d'erreur JTLST H,FNCLB ; une lambda probablement CPI HATOM ; ce doit etre un atome JC ERUDFL ; n'importe quoi MVI A,FNCLT ^ ; la table ;;; APFNC doit suivre .PAGE ;----- APFNC : applique la fonction atomique HL ; A contient l'adresse forte de la table de ; debranchement sur ftype ; BC contiendra la f-val ; DE n'est pas detruit APFNC: INR L ; pointe sur la Fval INR L INR L INX H MOV C,M INR L MOV B,M ; BC <- la FVAL INR L MOV L,M ; le f-type MOV H,A ; adresse forte de la table MOV A,M ; ADRESSE FORTE DU LANCEMENT INR L MOV H,M ; ADRESSE FAIBLE MOV L,A ; BC contient toujours la fonction PCHL ; DE l'arg (APPLY) ou le pointeur dessus .PAGE ;----- APPLY : APPLICATION DES NSUBRS, FSUBRS, 0SUBRS APNS: LXI H,$FFFF ; MARQUEUR ET AUTRE JFLST D,AP0S ; pas d'arg PUSH H ; MARQUEUR LXI H,2 ; POUR POINTER EN DESSOUS DAD SP ; POINTE SOUS LE MARQUEUR SHLD A4 XCHG ; HL <- LA LISTE ARG JMP APNSU ; AU CHARBON APNSL: PUSH D ; RANGE L'ARG APNSU: .UNCNS ; SEPARE JTLST H,APNSL ; C'EST PAS LE DERNIER LHLD A4 ; RECUPERE LE POINTEUR PUSH H ; RANGE APFS: XCHG ; HL <- DERNIER ARG AP0S: PUSH B ; LA F-VAL RET ; L'EXECUTE .PAGE ;----- APPLY : APPLICATION DES 1SUBR, 2SUBR, 3SUBR AP3S: XCHG ; HL <- LA LISTE .UNCNS ; SEPARE PUSH D ; RANGE LE PREMIER XCHG ; DE <- LA LISTE ;;; AP2S DOIT SUIVRE AP2S: XCHG .UNCNS PUSH D XCHG ;;; AP1S DOIT SUIVRE AP1S: XCHG MOV A,M INR L MOV L,M MOV H,A PUSH B ; PLACE LA F-VAL RET ; ET ON Y VA .PAGE ;----- APPLY : application des variables fonctions AP2V: XCHG ; HL <- la liste .UNCNS ; de <- 1er HL <- reste XCHG ;AP1V doit suivre AP1V: JTNIL D,AP0S ; c'est un GET XCHG ; HL <- liste MOV A,M ; prend le car INR L MOV L,M MOV H,A ; dans HL APFNV: PUSH H ; fait de la place DCX B ; pointe sur l'adresse du set LDAX B ; la charge MOV H,A ; dans HL DCX B ; rebelotte faible LDAX B MOV L,A ; voila XTHL ; la place et prend le 2eme arg RET ; et on y va .PAGE ;----- FUNCAL : application des 0subr, 1subr, 2subr FNC0: XCHG ; HL pointe sur le nom empile SPHL ; au cas il y aurait trop d'argument POP PSW ; enleve le nom inutile FNC01: POP PSW ; enleve le marqueur inutile PUSH B ; la f-val RET ; on y va FNC1: LXI H,NIL ; au cas ou il y aurait pas assez d'arg PUSH H ; NIL par defaut FNC1C: DCX D ; pour pointer au dessus de la fonction empilee DCX D XCHG ; HL pointe un mot au dessus SPHL ; au cas ou il y aurait trop d'empilement POP H ; l'argument POP PSW ; nettoie POP PSW ; re PUSH B ; la f-val RET ; on y va FNC2: LXI H,NIL ; rebelotte PUSH H PUSH H ; si pas assez d'arg DCX D ; pour se mettre 2 mots au dessus de la fonction DCX D DCX D DCX D XCHG ; HL pointe 2 au dessus SPHL ; le reste eventuel on s'en fout POP H ; arg 2 POP D ; arg 1 POP PSW ; nettoie POP PSW ; nettoie PUSH D ; arg 1 doit etre au dessus PUSH B ; f-val RET ; go .PAGE ;----- FUNCAL : APPLICATION DES 3SUBR FNC3: LXI H,NIL ; nil par defaut pour arg manquants PUSH H PUSH H PUSH H ; comme ca pas d'histoire DCX D ; pour se placer 3 mots au dessus de la fonction DCX D DCX D DCX D DCX D DCX D XCHG SPHL ; la pile est comme il faut POP H ; arg 3 SHLD A4 ; fait de la place POP H ; arg 2 POP D ; arg 1 POP PSW ; nettoie POP PSW PUSH D ; mets les arg en place PUSH H LHLD A4 ; et voila PUSH B ; la f-val RET ; on y va .PAGE ;----- FNC1V : FUNCALL : APPLICATIONS DES SUBR1V FNC1V: CALL NB1ARG ; test get ou set ? JZ AP0S ; get ==> commme une 0subr MOV H,B ; HL <- F-VAL MOV L,C DCX H ; preleve l'adresse du set MOV B,M DCX H MOV C,M JMP FNC1C ; et c'est comme une 1subr ;----- FNC2V : FUNCALL : application des 2subrv FNC2V: CALL NB1ARG ; test 0 arg JZ FNC0N ; charge NIL et go DCX D ; saute la fonction DCX D CALL NB1ARG ; test 0 arg de plus (laid !) XCHG ; pour faciliter le test JZ FNC01 ; nettoie un mot et go DCX H ; se place 2 mots au-dessus de la fonction DCX H SPHL ; au cas ou il y en aurait de trop POP H ; le 2eme POP D ; le 1er POP PSW ; nettoie POP PSW ; re JMP APFNV ; et c'est comme APPLY .PAGE ;----- NB1ARG : test 0 arg en plus de la fonction dans FUNCALL ; DE = pointeur sur la fonction dans la pile ; au retour on a ; Z = 0 si au moins un arg et la pile est intacte ; Z = 1 sinon et ; HL = (SP - 2) i.e. $FFFF ; DE = (SP) i.e. la fonction ; SP = SP - 4 NB1ARG: LXI H,2 ; pour sauter l'adresse de retour DAD SP ; pointe sur le dernier arg de FUNCALL MOV A,H CMP D ; idem au pointeur sur la fonction ? RNZ ; nan ok MOV A,L ; rebelotte CMP E RNZ ; ca ressemblait POP H ; l'adresse de retour POP D ; depile la fonction XTHL ; depile le marqueur RET ; et rentre ;----- FUNCALL : application des FSUBR ; il faut listifier la liste sauf la fonction ; il suffit de remplace la fonction par le marqueur ; et le marqueur par la f-val de la fonction ; et un saut a LIST suffit ! FNCF: CALL NB1ARG ; test 0 arg JNZ FNCFS ; y en a LXI H,NIL PUSH B ; la f-val ; 8 - 1000l$$1000t RET ; on y va FNCFS: XCHG ; HL pointeur MVI M,$FF ; mets le marqueur INX H MVI M,$FF INX H ; passe a l'ancien marqueur MOV M,C ; le remplace par la f-subr INX H MOV M,B ; voila POP D ; le premier arg JMP LISTNI ; listifie et atterira sur la f-subr .PAGE ;----- FUNCALL : application des NSUBR ; le format est tout pret mais la fonction est de trop ; on la remplace donc par la fonction identite POPJ FNCN: CALL NB1ARG ; test 0 arg JNZ FNCNS ; y en a LXI D,NIL ; y en a pas PUSH B ; HL est tout pret RET ; on y va pour pas grand chose FNCNS: XCHG ; HL le pointeur MVI M,$FF ; remplace la fonction par un marqueur INX H MVI M,$FF INX H ; sur l'ancien marqueur MVI M,POPJ & $FF ; pour retourner dans de bonnes conditions INX H MVI M,POPJ ^ DCX H ; HL pointe en dessous du marqueur XTHL ; le place et recupere le dernier arg PUSH B ; la f-val RET ; et on y va ;----- FUNCALL : application des fonctions utilisateurs ; les arguments sont listifies et puis c'est comme APPLY ; le sous-programme suivant listifie et est appele juste ; avant les point d'entree d'APPLY correspondants ; pour les FEXPRS et les MACROS on peut pas faire autrement ; pour les EXPRS on pourrait theoriquement ne pas listifier FNCUSR: MOV H,B ; la f-val MOV L,C ; sera recuperee par les appelants FNCUSH: SHLD FONCT ; et sera protogee des G.C. eventuels ! POP B ; recupere le retour CALL NB1ARG ; test 0 arg JNZ FNCUSS ; pas si simple FNC0N: LXI H,NIL ; pas d'arg PUSH B ; prepare le retour RET ; voila FNCUSS: XCHG ; DE <- retour MVI M,$FF ; place un marqueur INX H MVI M,$FF INX H MOV M,C ; prepare le retour INX H ; vers le module apply correspondant MOV M,B POP D ; le premier arg JMP LISTNI ; . . . protegee des G.C. .PAGE .SBTTL; Zone F : EVALUATEURS ;***** (EVLIS L) [SUBR 1] LISTX: XCHG ; (EVLIS DE) EVLIS: ; [SUBR 1] RFLST H ; L'ARGUMENT N'EST PAS UNE LISTE. CALL EVARG ; EVALUE LE 1ER. PUSH D ; SAUVE LERESTE. CALL NCONS ; QLISTIFIE. POP D ; RECUP LE CDR. RFLST D ; YAVAIT QU'1 ELEMENT (YA U QU'1 CONS) PUSH H ; EMPILE LE DEB DE LA LISTE. MOV B,H ; BC <- LE DEBUT EVALUE MOV C,L XCHG ; HL <- LE RESTE LIST1: .UNCNS ; SEPARE LES ARGS PUSH H ; SAUVE LE RESTE PUSH B ; SAUVE LE PRECEDENT CALL EVALX ; EVALUE LE SUIVANT CALL NCONS ; QU'ON LISTIFIE MOV B,H ; ET QU'ON MET DANS BC MOV C,L POP H ; RECUPERE LE PRECEDENT .RPLD B,C ; ON ACCROCHE POP H ; ET ON RECUPERE LE RESTE JTLST H,LIST1 ; YEN A ENCORE. PHRET: POP H ; RECUP LE 1ER ELEM. RET ; VOILA. .PAGE ;----- EVARX : DE <- (CDR DE) HL <- (EVAL (CAR DE)) ;----- EVARG : DE <- (CDR HL) HL <- (EVAL (CAR HL)) EVARX: XCHG EVARG: .UNCNS ; DE <- CAR HL, HL <- CDR HL. PUSH H ; SAUVE LE CDR CALL EVALX ; EVALUE LE CAR POP D ; RECUP LE CDR. RET ; ;----- EVPRED : EVALUE L'ELEM SUIVANT ET TEST / NIL. EVPRD: .UNCNS ; DE <- CAR HL, HL <- CDR HL. PUSH H ; sauve le cdr CALL EVALX ; evalue le car POP D ; RECUP LE CDR. MOV A,H CPI HNIL ; NIL ? RET ; L'INC Z EST POSITIONNE. .PAGE ;----- EVSET ; ; au de'part: ; HL = forme ; BC = nom d'une fonction affectation ; au retour: ; HL <- (EVAL (CADR HL)) ; BC <- (CAR HL) et controle que c'est une variable ; DE <- (CVAL (CAR HL)) EVSETX: XCHG EVSET: CALL VARCAR ; DE <- (CAR HL) HL <- (CDR HL) et controle DE PUSH D ; sauve le nom de la variable CALL EVCAR ; evalue POP B ; recupere la variable LDAX B ; charge la c-val MOV D,A ; dans DE INR C ; rebelotte faible LDAX B MOV E,A ; voila DCR C ; repasse en debut de nom RET ;----- EVBAX : HL <- (eval (car DE)) et BC n'est pas detruit EVBAX: PUSH B CALL EVCAX POP B RET .PAGE ;----- E V A L EVCAX: XCHG ; (EVAL (CAR DE)) EVCAR: MOV D,M ; (EVAL (CAR HL)) INR L MOV E,M EVALX: XCHG ; (EVAL DE) EVAL: ; (EVAL HL) ** ENTRY ** LDA TREVP ; il est trace' ? ORA A JNZ CLSTE ; on appelle STEPEVAL EVALNT: RTVAR H ; RETOUR SI CONSTANTE JTLST H,EV1 ; VERS LE TRAITEMENT DES FORMES ;---- EVAL : ATOMES LITTERAUX. MOV D,M ; DE <- C-VAL de HL INR L MOV E,M XCHG ; HL <- LA C-VAL. MOV A,H CPI HUNDF ; UNDEFINED ? RNZ ; NAN. MOV A,L ; YA PAS DE COMP 16 BITS !?! CPI UNDEF & $FF RNZ DCR E ; DE <- NOM DE L'ATOME. XCHG ; HL <- l'atome indefinie LXI B,.EVAL ; atome EVAL LXI D,.MSUND ; le message JMP CALSR .PAGE ;----- CLSTE : appel de STEPIN redefinissable CLSTE: LXI D,RSTRE ; prepare le retour LXI B,.STPEV ; charge le nom CLSTE2: XRA A ; desactive la trace STA TREVP ; car sinon ca boucle ;;; CLFC1 doit suivre ;----- CLFC1 : simulation d'un appel de FUNCALL avec 2 arguments ; DE = adresse de retour ; BC = arg 1 i.e. fonction ; HL = arg 2 i.e. arg de la fonction CLFC1: PUSH D ; prepare le retour CLFC11: XCHG ; DE <- L'ARG LXI H,$FFFF ; marqueur de fin d'arg PUSH H ; le place LXI H,2 ; le pointeur DAD SP ; pointe sur le debut PUSH B ; la fonction a appliquer PUSH H ; le pointeur sur le debut XCHG ; HL <- l'arg veritable JMP FUNCAL ; on applique sans CONS pour les subr ;----- rstre : retour de STEPIN RSTRE: LXI B,EVALNT ; on re'e'value sans tester LXI D,.VERST ; le retour XCHG ; en bon ordre JMP SIMVER ; protege' par un bloc verrou ;----- VERSTE : appel de STEPOUT redefinissable VERSTE: ; retour de STEPEVAL, par un bloc LOCK LXI B,.STPEQ ; il faut appliquer la fonction STEPOUT LXI D,VERSTS ; et revenir ici JMP CLSTE2 ; vers la'ppel de FUNCALL VERSTS: MVI A,1 ; restaure la trace STA TREVP POP B ; recupere le premier argument donn'e par LOCK RTNIL B ; y a pas eu d'echappement LXI D,XPOPJ ; faudra rien faire JMP REXIX ; reactive l'echappement .PAGE ;***** (STEPIN ) [SUBR 1] ; ; est appele' avant l'evaluation d'une forme si la trace est active ; en standard imprime la forme et l'evalue en mode trace, en ; macro ge'ne'rant un appel de traceval STEPIN: PUSH H ; sauve la forme MVI B,'-' ; le debut de la fleche CALL PRCHT2 ; 2 fois MVI B,'>' ; fin de la fleche POP H ; recupere la forme CALL TOPL3 ; edite la fleche, un espace et la forme CALL KWOTE ; macro-genere (traceval ') LXI D,.TRVAL ; l'atome TRACEVAL JMP XEXONS ; fin de la macro-generation ;***** (STEPOUT ) [SUBR 1] ; ; est appele' apres l'evaluation d'une forme si la trace est active ; en standard, imprime ce resultat STEPOU: PUSH H ;sauve le resultat MVI B,'<' ; le debut de la fleche CALL PRCHT MVI B,'-' ; la fin de la fleche CALL PRCH2S ; 2 fois et un espace POP H ; la forme JMP PRINI ; l'imprime et rentre ;***** (TRACEVAL E) [SUBR 1] ; fonction de tracage interne . TRVAL: XCHG ; DE <- LA FORME LXI H,EVALNT ; il faudra evaluer sans trace au premier coup LXI B,TREVP ; adresse de l'indicateur JMP BINDI1 ; vers la construction du bloc .PAGE ;----- EVLIT : traitement des interruptions de EVAL .IFNE ITEVAL CEVLIT: LDA ITVLP ; indicateur d'ITEVAL deja actif ORA A ; alors ? RNZ ; encore un qui tape plus vite que son nombre PUSH H ; sauve la forme a evaluer LXI H,PHRET ; prepare le retour sous EVAL PUSH H ; et voila CALL CI ; lecture veritable du caractere! CALL CRANA ; cre un argument numerique XCHG ; DE <- le caractere LXI H,CLFC11 ; prepare le retour LXI B,ITVLP ; l'adresse de l'indicateur JMP BINDI1 ; simule le bloc, appel FUNCALL et revient ;***** (ITEVAL n) [SUBR 1] ; en standard, cette fonction interprete les caracteres suivants: ; ; ^C retour a CP/M ; ^B appel de la fonction BREAK ; ^S attente d'un caractere puis retour ; tous les autres caracteres sont ignore's (retour immediat) ITEVAF: MOV A,L ; charge le nombre CPI 3 ; ^C ? JZ ASTOP ; on arrete tout CPI $2 ; ^B JZ CALBR ; appel de BREAK redefinissable CPI $13 ; ^S RNZ ; c'est tout pour le moment CALL CI ; on attend un caractere JMP TRUTH ; et on ramene quelque chose de propre .ENDC ; de ITEVAL .PAGE ;----- EVALUATION D'UNE FORME DE TYPE LISTE. EV1: ; FORME = LISTE (DS H&L). XCHG ; DE <- la forme. CKSTK ERFSE ; test fin de pile. XCHG ; HL <- restaure la forme. ; traitement de l'ITEVAL, uniquement pour les systemes ; pour lequel le test est TRES rapide. Cela veut dire ; qu'il vaut mieux eviter les : ; CALL CS / ORA A / CNZ CEVLIT ; qui font doubler les temps de l'interprete !!! .IFNE ITEVAL TESTIT ; test du port, en fonction de la machine CNZ CEVLIT ; et pour les autres c'est tant pis ... .ENDC ; de ITEVAL SHLD FORM ; sauve definitivement la forme. .UNCNS ; DE <- la fnt, HL <- les arguments XCHG ; HL <- la fnt, DE <- les arguments .PAGE ;----- EVAL FNT -> HL & LARG -> DE EV15: JFLST H,EVFAT ; lambda ou autre ;----- EVAL : LA FONCTION EST UNE LISTE EV2: MOV A,M ; <- LH DU CAR DE LA FNT. CPI .LAMB ^ JNZ EV22 ; C'EST PAS UNE LAMBDA. INR L MOV A,M ; A (L) DU CAR. CPI .LAMB & $FF ; OU EST LE COMPARATEUR 16 BITS ? JZ EVLEX ; C'EST UNE LAMBDA CPI .FLAM & $FF JZ EVFLEX ; C'EST UNE FLAMBDA CPI .MLAM & $FF JZ EVMLEX ; C'EST UNE MLAMBDA ;----- EVAL : FONCTION LISTE DIFFERENTE DE F/M/ /LAMBDA DCR L ; REPASSE AU DEBUT EV22: PUSH D ; SAUVE LES ARGS. CALL EV1 ; RE-EVALUE LA FONCTION. POP D ; RECUP LES ARGS. JMP EV15 ; CA ROULE. .PAGE ;----- EVAL RAPIDE POUR LES FONCTIONS ATOMIQUES. EVRPN: LXI D,NIL ; appel interne des fonctions sans arg EVFAT: JTNUM H,EVRFN ; pas de nombre ! EVRPD: SHLD FNTEV ; sauve le nom de la fonction INR L ; prepare le lancement rapide. INR L INR L INX H ; HL pointe sur la F-VAL MOV C,M ; BC <- la F-VAL INR L MOV B,M INR L PUSH B ; empile la F-VAL. MOV L,M ; L <- le F-TYP. EVRPI: ; lancement rapide : ; FVAL empilee, HL pointe sur le FTYPE. MVI H,EVALT ^ MOV A,M ; HL <- adresse de lancement INR L ; du type de la fonction. MOV H,M MOV L,A BINDR: ; adresse des branchements indirects. PCHL ; on y va avec : ; - DE <- les arguments ; - la F-VAL empilee. ;----- EVAL : FONCTION ATOMIQUE INONNUE. EVUN: POP B ; DEPILE LA VIELLE F-VAL. LHLD FNTEV ; recharge la fonction MOV B,M ; BC <- CVAL de HL INR L MOV C,M DCR L JTVAR B,ERA9 ; la c-val est une constante! MOV A,B CMP H ; constante ? JNZ EVUN1 ; nan MOV A,C CMP L ; encore ? JZ ERA9 ; c'est vraiment une constante! EVUN1: MOV H,B ; recharge la foncion MOV L,C JMP EV15 ; et on recommence EVAL. .PAGE ;----- EVAL DES 3SUBR, 2SUBR, 1SUBR EV3A: CALL EVARX ; EVALUE LE PREMIER ARG XTHL ; RANGE ET PUSH H ; METS LA F-VAL PAR DESSUS ;;; EV2A DOIT SUIVRE EV2A: CALL EVARX ; PREMIER DES 2, OU DEUXIEME DES TROIS XTHL ; RANGE ET PUSH H ; METS LA F-VAL PAR DESSUS ;;; EV1A DOIT SUIVRE EV1A: LDAX D ; fort car MOV H,A ; dans H INR E ; rebelotte faible LDAX D MOV L,A ; HL <- CAR INR E ; test d'arguments en trop LDAX D ; fort CDR CPI HNIL ; ca doit etre NIL JZ EVAL ; ok XCHG ; HL pointe sur les arguments en trop MOV D,M ; charge les args INR L ;rebelotte faible MOV E,M XCHG ; HL <- les args XTHL ; sauve les args et recupere la f-val CALL FINFD ; ramene le nom en clair MOV B,H ; dans BC MOV C,L POP H ; recupere les args en trop JMP ERRTAP ; vers le chargement du message ;--- LANCEMENTS DES 0SUBR, FSUBR XPOPJ: XCHG ; [SUBR F] POPJ: RET ; [SUBR 0] ON TOMBE SUR LA F-VAL EMPILEE !?. .PAGE ;----- EVAL : lancement des variables-fonctions ; les variables-fonctions sont codees ainsi: ; la f-val est l'entree du mode get ; le mot precedant cette adresse est celle du set ;--- EVAL : lancements des subr1v EV1V: RTNIL D ; c'est en get POP H ; recupere la f-val DCX H ; qui est l'adresse du get MOV B,M ; l'adresse du set est juste au-dessus DCX H MOV C,M ; la voila PUSH B ; prepare l'appel JMP EVCAX ; calcul l'arg. ;----- EVAL : lancement des subr2v EV2V: CALL EVARX ; evalue le premier RTNIL D ; y en a qu'un, c'est un get XTHL ; prend la f-val, sauve le premier DCX H ; derreiere le get, se cache le set MOV A,M ; avec indirection DCX H MOV L,M MOV H,A ; HL <- le set XTHL ; le place, PUSH H ; avec le premier arg par-dessus CALL EVCAX ; evalue le deuxieme POP D ; recupere le premier RET .PAGE ;----- EVAL : LANCEMENTS DES NSUBRS ; Les arguments sont empiles sauf le dernier. ; a l'entree de la nsubr on a: ; ; HL = dernier argument evalue ; ; ---------------- ; SP --> ! ------------ ; ---------------- ! ; ! ARGUMENT n-1 ! ! ; ---------------- ! ; ! ARGUMENT n-2 ! ! ; ---------------- ! ; ... ; ---------------- ! ; ! ARGUMENT 1 ! ! ; ---------------- ! ; ! $FFFF ! ! ; ---------------- ! ; <--- ; ; Cependant dans le cas ou il n'y a pas d'argument on a: ; ; HL = $FFFF ; DE = (CDR FORME) ie NIL (ou alors au fou !) ; et la pile est vide ; ; Le pointeur vers le marqueur est utilise pour les nsubr operant ; a l'envers (ou a l'endroit c'est selon): PRIN, MAP et derivees. ; Il sert aussi au traitement des environnements perimes ; ; Dans le cas des NSUBRs associatives (les MSUBRS), un test ; est fait verifiant si l'appel de cette subr est le dernier ; argument d'un autre appel de cette meme subr. ; Dans l'affirmative, la f-val est remise en-dessous des ; arguments precedents et le pointeur est recupere: tout se ; passe comme si le premier appel se continuait. .PAGE ;----- INITIALISATIONS DE L'ACTIVATION DES NSUBRS EVNM: ; NSUBR associatives test de rec-term POP H ; fonction a activer POP B ; appel precedent PUSH B ; simple consultation MOV A,B ; test poids fort CMP H ; s'agit-il d'une NSUBR associative ? JNZ EVNI ; nenni MOV A,C ; rebelotte faible CMP L JNZ EVNI XCHG ; HL <- arg RFLST H ; pas de nouveaux arguments, execute rapide POP D ; ecrase la f-val par elle-meme ! POP B ; recupere le pointeur DCX B ; pointe sur le marqueur $FFFF MOV A,D ; on remet la f-val ! STAX B DCX B ; rebelotte faible MOV A,E STAX B JMP NSF ; et c'est comme s'il n'y avait eu qu'un appel EVNI: ; echec du test de rec-term PUSH H ; replace la f-val EVNA: ; entree des NSUBR normales (ou anormales !) LXI H,$FFFF ; POUR 0 ARGUMENTS OU PILE RFLST D ; PAS D'ARGS INX H ; HL <- 0 DAD SP ; HL POINTE SUR LA F-VAL MOV B,H ; BC <- LE POINTEUR MOV C,L XCHG ; HL <- LES ARGS JMP NSF ; AU BOULOT .PAGE ;----- BOUCLE D'EVALUATIONS DES ARGUMENTS DES NSUBRS NSC: PUSH H ; LE CDR DES ARGS PUSH B ; POINTEUR SUR F-VAL CALL EVALX ; EVALUE LE SUIVANT POP B ; RECUPERE LE POINTEUR XTHL ; RANGE L'EVALUATION, RECUPERE LE RESTE NSF: .UNCNS ; SEPARE LES ARGS JTLST H,NSC ; C'EST PAS LE DERNIER MOV H,B ; HL <- LE POINTEUR MOV L,C ; SUR F-VAL MOV C,M ; RECUPERE FAIBLE F-VAL MVI M,$FF ; PLACE LE MARQUEUR INX H ; REBELOTTE POIDS FORT MOV B,M MVI M,$FF INX H ; POINTE EN DESSOUS (ENVIRONNEMENT PERIME) PUSH H ; SAUVE POINTEUR PUSH B ; F-VAL EN SOMMET DE PILE JMP EVALX ; ATTERIRA SUR LA F-VAL .PAGE ;----- EVAL DES FEXPRS ET APPLY ET FUNCALL DES USER FONCTIONS FNCLB: CALL FNCUSH ; listifie les args XCHG ; dans DE LHLD FONCT ; recupere la fonction LXI B,.FNCL ; en cas d'erreur APPLY1: MOV A,M ; teste le CAR CPI .LAMB ^ ; LAMBDA ? JNZ ERUDFL INR L MOV A,M ; les poids faibles CPI .LAMB & $FF JZ EVFLEX ; ok CPI .FLAM & $FF JZ EVFLEX ; c'est la meme chose pour APPLY DCR L ; en cas d'erreur pointeur ok CPI .MLAM & $FF JNZ ERUDFL ; DE QUOI ? PUSH H ; sauve la forme pour le cons avec args INR L ; saute le CAR INR L MOV A,M INR L MOV L,M MOV H,A ; voila une macro toue propre XTHL ; range la f-val et recupere la forme CALL CONS ; simule un appel direct JMP EVMAP ; et comme si de rien n'etait EVFLEX: INR L MOV A,M ; pour sauter le LAMBDA. INR L MOV L,M MOV H,A JMP FNAPL ; et comme un direct FNCEX: CALL FNCUSR ; listifie les args XCHG ; dans DE LHLD FONCT ; et recupere la fonction FNAPL: PUSH H ; COMME TOUT LE MONDE EVFEX: POP B ; LA F-VAL APEX: PUSH B ; RAPPELEE POUR CONSULTATION PUSH D ; SAUVE LES ARGS LXI H,4 ; POUR POINTER EN DESSOUS DAD SP ; QU'Y A-T-IL EN DESSOUS ? SHLD ENBLO ; MEMORISE LA FIN DU BLOC XCHG ; dans DE MVI H,3 ; indic d'enveloppe CALL TENVPE ; Y A-T-IL BESOIN DE CONSTRUIRE UN BLOC ? JZ SAPTR ; NAN CA VA FONCER POP D ; RECUPERE LES ARGS JMP APEXPN ; HELAS OUI .PAGE ;----- EVAL ET APPLY DES MACROS ET SUITE DES FEXPR FNCMAC: CALL FNCUSR ; listifie les args XCHG ; dans DE LHLD FONCT ; recupere la fonction MOV B,H ; dans B MOV C,L APMAC: PUSH B ; RANGE LA F-VAL LHLD FNTEV ; RECUPERE LE NOM DE LA MACRO CALL CONS ; POUR SIMULER UN APPEL DIRECT JMP EVMAP ; ET TOUT SEMBLE NORMAL EVMLEX: INR L ; CAS (MLAMDA ... MOV A,M ; faut prende le cdr INR L MOV L,M MOV H,A PUSH H ; VOILA OU ELLE DOIT ETRE EVMAC: LHLD FORM ; L'ARG EST LA FORME EVMAP: XCHG ; DANS DE DE LXI H,EVAL ; POUR LA REEVALUATION XTHL ; VOILA QUI EST FAIT PUSH H ; F-VAL PREMIER MOT DU BLOC LXI H,2 ; CALCUL DU POINTEUR DE FIN DE BLOC DAD SP ; VOILS SHLD ENBLO ; COMME TOUT LEMONDE APEXPN: LXI H,NIL ; INITIALISE LA SUITE DES ARBRES SHLD AL LXI H,FEXF ; ADRESSE DE RETOUR SHLD RDLAMB ; PAS DANS LA PILE! MVI A,1 ; INDICATEUR LIAISON EN 1 TEMPS STA EEXNC LHLD SELFM ; RECUPERE LA FONCTION APPELANTE XTHL ; SAUVE ET RECUPERE L'APPELEE SHLD SELFM ; NOUVELLE FONCTION EN COURS MOV A,M ; CALCUL DES PARAMETRES INR L MOV L,M MOV H,A ; HL <- PARAMETRES JFNIL H,BNDT ; TEST AU MOINS UN ARGUMENT JTNIL D,FEXF ; OK VERS EXECUTION DU CORPS JMP ERRTA ; TROP D'ARGUMENTS ! EEVALS=. TEVALS=EEVALS-CODEB .PRINT TEVALS .PAGE .SBTTL; Zone E .=<<. + $FF> ^ > * $0100 ;PAGE SUIVANTE BEXPR=. ;----- EVAL : DES LAMBDA/EXPR ; Afin de traiter le cas des environnements perimes par une expr ; l'evaluation du dernier argument est une duplication d'appel. ; La boucle d'evaluation teste donc l'atomicite du CDR de la liste ; des parametres, et non la liste elle meme; en consequence ; les cas pathologiques, i.e une entete de fonction atomique et ; non pas liste, sont traites au prealable ici. EVLEX: INR L MOV A,M ; HL <- CDR HL INR L ; I.E. ((LVAR) ..BODY.. ) MOV L,M MOV H,A ESELF: PUSH H ; QUE L'ON SAUVE. EVEXP: LXI H,0 DAD SP ; POINTEUR SUR LA FIN DU FUTUR BLOC MOV B,H ; DANS BC MOV C,L POP H ; CONSULTE LA F-VAL PUSH H ; POUR LA RETROUVER A LA FIN DES LIAISONS MOV A,M ; FORT CAR INR L MOV L,M ; FAIBLE CAR MOV H,A ; HL <- LES PARAMETRES JLTNL H,BND1,EVEXPN ; TRAITEMENT DES CAS PATHOLOGIQUES PUSH H ; SAUVE LE NOM PUSH B ; SAUVE LE POINTEUR CALL LISTX ; LISTIFIE POP D ; LE POINTEUR XTHL ; RANGE LA VALEUR PUSH H ; ET LE NOM PAR DESSUS XCHG ; HL <- LE POINTEUR JMP BND1FF ; ET VOILA EVEXPN: JFNIL D,ERRTAL ; TROP D'ARGUMENT ! JMP BND1FB ; ET VOILA .PAGE ;------ DEBUT DE CONSTRUCTION D'UN BLOC LAMBDA PAR UNE EXPR ; HL = LES PARAMETRES NECESSAIREMENT UNE LISTE ; DE = LES ARGUMENTS A EVALUER ; BC = SP POINTEUR SUR LA FIN DU FUTUR BLOC ; (SP) = LA FONCTION APPELEE ; HL EST N'IMPORTE QUEL OBJET LISP ; NE CONTENANT PAS DE NOMBRE NI NIL SAUF EN CDR. ; AFIN DE NE PAS APPELER EVLIS, ON GERE LE PREMIER NIVEAU DE ; PARAMETRE: ; (DS BND1 (PAR ARG) ; (IF (ATOM (CDR PAR)) ; (BND1D PAR ARG) ; (BND1LL (CAR PAR) (EVAL (CAR ARG))) ; (SELF (CDR PAR) (CDR ARG)) ) ) ; POUR NE PAS PENALISER LE CAS DES LAMBDA NORMALES, LE TEST ; D'ATOMICITE EST FAIT ICI. ; DANS LE CAS D'UNE LISTE DANS LA LISTE DES PARAMETRES, ; ON EST RAMENE AU CAS APPLY, A CECI PRES QUE L'ECHANGE ; DES C-VALS NE DOIT PAS AVOIR LIEU. ON UTILISE ALORS ; L'INDICATEUR EEXNC, VARIABLE GLOBALE ; (DS BND1LL (PAR1 ARG1) ; (COND ; ((CONSP PAR1) ; (SETQ EEXNC 0) ; (BNDL PAR1 ARG1) ) ; ( T (PUSH ARG1) ; (PUSH PAR1) ) ) ) ; LE DEDOUBLEMENT DU CORPS DE LA BOUCLE D'EVALUATION ; QUI PERMET DE REPERER LES CAS D'ENVIRONNEMENT PERIMES ; PAR UNE EXPR, SE COMPLIQUE PAR LE FAIT QU'ON TESTE LA ; FIN DES PARAMETRES ET NON LA FIN DES ARGUMENTS. ; EN FAIT LE CAS DE LA PAIRE POINTEE N'EST PAS TRAITE ; POUR CETTE EVENTUALITE. .PAGE ; (DS BND1D (PAR ARG) ; (IFN (CDR PAR) ; (IF (CDR ARG) ; (SYSERROR 'EVAL "Trop d'arguments" (CDR ARG)) ; (BND1LL (CAR PAR) (EVAL (CAR ARG))) ) ; (LET ((A1 (EVAL (CAR ARG))) (A2 (EVLIS (CDR ARG)))) ; (PUSH A2) ; (PUSH (CDR PAR)) ; (BND1LL (CAR PAR) A1) ) ) ) ; ; ; le bloc se presente ainsi a la fin: ; ; [ nom 1 ] ; [ arg 1 ] ; ..... ; [ fonction appelee ] BND1L: CALL EVARX ; EVALUE L'ARGUMENT SUIVANT DE DE POP B ; RECUPERE LE POINTEUR DE FIN DE BLOC XTHL ; RANGE LA VALEUR, RECUPERE LES NOMS PUSH D ; SAUVE LE RESTE DES ARGS .UNCNS ; SEPARE LES PARAMETRES JFLST D,BND1A ; ATOME ==> LIAISON SIMPLE SHLD LPARAM ; CA SE COMPLIQUE POP H ; EXPEDIONS LES AFFAIRES COURANTES SHLD FNTEV ; RESTE DES ARGS XCHG ; HL <- LE PARAMETRE LISTE POP D ; DE <- L'ARGUMENT EVALUE CORRESPONDANT CALL BNDLE ; LIAISON DES ARBRES LHLD FNTEV ; RECUPERE LES ARGUMENTS SUIVANTS XCHG ; DANS DE LHLD ENBLO ; RECUPERE LE POINTEUR DE FIN DE BLOC MOV B,H ; DANS BC MOV C,L LHLD LPARAM ; RECUPERE LES PARAMETRES SUIVANTS JMP BND1 ; ET CA REPART .PAGE BND1A: XCHG ; HL <- LE PREMIER XTHL ; LE RANGE ENFIN ET RECUPERE LES ARGS XCHG ; TOUT LE MONDE EN PLACE BND1: PUSH H ; SAUVE LES NOMS PUSH B ; SAUVE LE POINTEUR DE FIN DE BLOC INR L ; TEST DE L'ATOMICITE DU CDR INR L ; POUR TRAITEMENT DES ENV. P. PAR EXPR JLTNL M,BND1L,BND1N ; UNE LISTE ==> BOUCLE, NIL ==> DIRECT CALL EVARX ; CAS DE LA PAIRE POINTEE PUSH H ; ON FERA LA LIAISON APRES CELLE CALL LISTX ; DU CDR, QUELLE IMPORTANCE ? POP D ; CAR ON SAIT QU'IL EST ATOMIQUE POP B ; ALORS QUE LE PENULTIEME ON SAIT PAS XTHL ; RANGE LA LISTE EVALUEE PUSH D ; PROVISOIREMENT (VAL DU PENULTIEME) .UNCNS ; SEPARE LES NOMS XTHL ; LIAISON DU DERNIER FAITE XCHG ; HL <- PENULTIEME PARAMETRE, DE <- SA VAL JFLST H,BND1F ; COMME SI C'ETAIT LE DERNIER BND1DL: CALL BNDLE ; VERS LA LIAISON D'ARBRES LHLD ENBLO ; RECUPERE LE POINTEUR JMP BND1FF ; VERS LE TEST D'ENVIRONNEMENT PERIME .PAGE BND1N: XCHG ; HL <- LES ARGS MOV D,M ; DE <- (CAR HL) INR L ; DERNIER ARGUMENT MOV E,M INR L ; TEST ARGUMENT EN TROP JFNIL M,ERRTAM ; TROP D'ARGUMENT CALL EVALX ; SEUL APPEL DIRECT A EVAL DE LA ZONE POP B ; RECUPERE LE POINTEUR DE FIN DE BLOC XCHG ; DE <- LA VALEUR POP H ; HL <- LE NOM LISTIFIE MOV A,M ; DELISTIFIONS INR L MOV L,M MOV H,A JTLST H,BND1DL ; LIAISON D'ARBRE DU DERNIER BND1F: PUSH D ; RANGE LA VALEUR PUSH H ; RANGE LE NOM BND1FB: MOV H,B ; HL <- POINTEUR DE FIN DE BLOC MOV L,C BND1FF: MOV C,M ; RECUPERE LA FONCTION INX H MOV B,M INX H ; HL POINTE SUR L'APPEL PRECEDENT XCHG ; et maintenant DE MVI H,3 ; indic d'enveloppe CALL TENVPE ; TEST D'ENVIRONNEMENT PERIME MOV D,H ; a priori c'est terminal JZ SBND ; CA MARCHE, LIAISON SIMPLE LXI H,0 ; PREPARE LA DESCENTE DANS LA PILE DAD SP JMP DNB1 ; EN ROUTE .PAGE ;----- ETABLISSEMENT DES LIAISONS DANS UNE EXPR ; LA PILE CONTIENT LES NOMS ET LEURS VALEURS (CF BND1 ET CONSORT) ; ECHANGE AVEC LES C-VALS ACTUELLES. DNB1L: INR E ; POINTE SUR FAIBLE C-VAL LDAX D ; LA CHARGE INX H ; POINTE SUR LA MOV B,M ; NOUVELL FAIBLE C-VAL MOV M,A ; SAUVE L'ANCIENNE MOV A,B ; A <- LA NOUVELLE STAX D ; FORCEE DCR E ; REBELOTTE SUR LES FORTES INX H ; NOUVELLE FORTE C-VAL LDAX D MOV B,M MOV M,A MOV A,B STAX D INX H ; AU SUIVANT DNB1: MOV E,M ; FAIBLE D'ABORD INX H ; VERS FORTE MOV D,M ; LA VOILA JFLST D,DNB1L ; C'EST PAS LA FONCTION MOV B,H ; BC <- POINTEUR MOV C,L LHLD SELFM ; FONCTION APPELANTE XCHG ; FONCTION APPELEE SHLD SELFM ; NOUVELLE FONCTION EN COURS MOV A,D ; FONCTION APPELANTE STAX B ; SAUVEE DCX B ; TOUT CA C'EST POUR SELF MOV A,E ; MERCI JEAN-LOUIS STAX B ; ET VOILA INX B ; POUR POINTER SUR INX B ; L'APPEL PRECEDENT XCHG ; DE <- LA FONCTION JMP DNB1VX ; VERS LA FIN DE LA CONSTRUCTION EEXPR=. TEXPR=EEXPR-BEXPR .PRINT TEXPR .PAGE .SBTTL; Zone N : fonctions de creations .=<<.+$FF> ^ > * $0100 ; POUR SE PLACER DANS LA PAGE SUIVANTE BSBRN=. ; TABLE DE DEBRANCHEMENT DES APPELS DE FONCTIONS PAR FUNCALL FNCLT: .ADDR ERFNC ; 0 NIE WIEM .ADDR FNC0 ; 2 0SUBR .ADDR FNC1 ; 4 1SUBR .ADDR FNC2 ; 6 2SUBR .ADDR FNC3 ; 8 3SUBR .ADDR FNCN ; 10 NSUBR .ADDR FNCF ; 12 FSUBR .ADDR FNCEX ; 14 EXPR .ADDR FNCEX ; 16 FEXPR .ADDR FNCMAC ; 18 MACRO .ADDR FNCN ; 20 NSUBR associatives .ADDR FNC1V ; 22 subr1v .ADDR FNC2V ; 24 subr2v ; FIN DE LA TABLE DES DEBRANCHEMENTS POUR FUNCALL ; TABLE DES CLAIRS DES TYPES (CF: TYPFN). TYPFT: .ADDR NIL ; 0 NIE WIEM .ADDR SUBR0 ; 2 0SUBR .ADDR SUBR1 ; 4 1SUBR .ADDR SUBR2 ; 6 2SUBR .ADDR SUBR3 ; 8 3SUBR .ADDR SUBRN ; 10 NSUBR .ADDR SUBRF ; 12 FSUBR .ADDR EXPR ; 14 EXPR .ADDR FEXPR ; 16 FEXPR .ADDR MAKRO ; 18 MACRO .ADDR SUBRN ; 20 NSUBR ASSOCIATIVE .ADDR SUBR1V ; 22 VARIABLES FONCTIONS 1 .ADDR SUBR2V ; 24 VARIABLES FONCTIONS 2 .PAGE ;***** (GCINFO) [SUBR 0] ; retourne les infos du G.C. sous la forme de la liste: ; (GC nbr_d'appels ATOM nbr_d'octets CONS nbr_de_doublets) GCINF: LXI H,$FFFF ; marqueur de fin d'arg PUSH H ; car on va simuler un appel a LIST LXI H,.GC ; la marque du GC PUSH H LHLD GCNBR ; son nombre PUSH H LXI H,.ATOM ; la marque des atomes PUSH H LHLD CATOC ; dernier atome CALL CMPHL LXI D,BLIST ; la fin de la zone DAD D ; ce qu'il en reste PUSH H LXI H,.CONS ; la marque des doublets PUSH H LXI H,12 ; 2 fois le nombre d'arg DAD SP ; donc on pointe en dessous PUSH H ; LHLD FREES ; le nombre de cons, dernier arg ;;; LIST doit suivre ;***** (LIST e1 . . . en) LISTN: XCHG ; DE <- DERNIER ARG, OU HL <- NIL ; 9 - 1000l$$1000t$$ MOV A,D ; ON VA TRANCHER TOUT DE SUITE INR A ; marqueur ? RZ ; RETOURNE NIL (0 ARGUMENT) POP B ; POINTEUR INUTILE LISTNI: LXI H,NIL ; RAJOUTE NIL ET C'EST COMME MCONS ; MCNSL DOIT SUIVRE MCNSL: CALL XCONS MCNST: POP D ; PASSE AU SUIVANT MOV A,D ; S'IL EN RESTE INR A JNZ MCNSL ; OUI RET ; FINI .PAGE .SBTTL; Zone N : fonctions de modifications ;***** (SET N1 V1 . . . NN VN) [SUBR N] PSET: XCHG ; POUR FACILITER LE CAS 0 ARG MOV A,D ; C'EST $FFFF ? INR A RZ ; RETOUR AVEC NIL LXI B,.SET ; EN CAS D'ERREUR DANS LA BOUCLE XCHG ; HL <- DERNIER ARG XTHL ; RANGE ET RECUPERE POINTEUR DAD SP ; IL FAUT TESTER LA PARITE DU NOMBRE D'ARG MOV A,L ; LE DEUXIEME BIT DOIT ETRE = 1 RAR ; RAPPROCHE LE BIT 2 DE LA CARRY RAR ; VOILA LE BIT 2, MULTIPLIE PAR 2 TOUT SEUL LXI H,NIL ; A PRIORI NOMBRE IMPAIR JNC SETS ; OUI, NIL PAR DEFAUT POP H ; NON, LA VALEUR EST FOURNIE SETS: SHLD A4 ; LA VALEUR A RAMENER XCHG ; DE <- LA VAL SETL: POP H ; HL <- LE NOM JTVAR H,ERPLC ; HORREUR MOV M,D ; RPLACA SAUVAGE INR L MOV M,E POP D ; VALEUR SUIVANTE PEUT-ETRE MOV A,D INR A JNZ SETL ; ENCORE ! LHLD A4 ; RECUPERE LA PREMIERE VALEUR RET .PAGE .SBTTL; Zone N : fonctions arithmetiques ;***** (- E1 ... EN) [SUBR N] ; (-) ---> 0 ; (- 3) ---> -3 ; (- 4 1) ---> 3 ; (- 6 1 1 1) ---> 3 PSUB: LXI D,PSUBI ; prepare le retour si y a des args LXI B,.ASUB ; SI ERREUR JMP NSA00 ; retourne 0 si 0 arg, sinon revient ici PSUBI: POP D ; Y A PLUS D'UN ARG? MOV A,D INR A JNZ MOINL ; c'est parti pour l'addition CALL CMPHL ; on veut l'inverse JMP CRANB ; voila SUBL: DAD D ; additionne, c'est pas le premier MOV D,B ; DE <- arg suivan MOV E,C LXI B,.ASUB ; si erreur MOINL: CALL VALNX ; desinterne en inversant POP B ; argument suivant MOV A,B ; s'il y en a INR A JNZ SUBL ; ouaip XCHG CALL CMPHL ; complemente la somme des derniers args DAD D LXI B,.ASUB ; en cas d'overflow JMP CRANB ; et voila .PAGE .SBTTL; Zone N : entrees/sorties ;***** (PRINT E1 ... EN) [SUBR N] ;***** (PRIN E1 ... EN) [SUBR N] PRINT: LXI B,FLUSH ; PREPARE LE RETOUR JMP PRIC PRIN1: LXI B,PHRET ; PREPARE LE RETOUR PRIC: PUSH D ; POUR FACILITER LE TEST MOV A,H INR A JZ AP0S ; Y AVAIT PAS D'ARGUMENT POP D ; remets les choses en place XTHL ; AVEC LES AUTRES ET HL <- POINTEUR LXI D,$FFFF ; METTONS UN MARQUEUR AU DESSUS PUSH D ; CAR TOUT EST A L'ENVERS DCX H ; POINTE SUR LE FORT MARQUEUR MOV M,B ; PLACE L'ADRESSE DE RETOUR DCX H ; REBELOTTE FAIBLE MOV M,C ; ET VOILA PUSH H ; POUR LE RETOUR FINAL DCX H ; POINTE SUR LE PREMIER ARGUMENT PRICL: MOV D,M ; PREND UN ARGUMENT DCX H ; REBELOTTE FAIBLE MOV E,M PUSH H ; MEMORISE LE POINT DE PARCOURS XCHG ; HL <- L'OBJET A EDITER CALL PROBJ ; L'EDITE POP H ; RECUPERE LE POINTEUR DCX H ; AU SUIVANT MOV A,M ; SI C'EST PAS LE MARQUEUR INR A JNZ PRICL ; CA ROULE POP H ; LE POINTEUR DE DEPART POP D ; LE MARQUEUR POP D ; LE DERNIER ARGUMENT SPHL ; OUBLIE LES AUTRES XCHG ; HL <- LAST ARG (A RAMENER) XTHL ; en haut et recupere le retour PCHL ; l'execute ESBRN=. TSBRN=ESBRN-BSBRN .PRINT TSBRN .PAGE .SBTTL; Zone M : fonctions sur listes .=<<.+$FF> ^ > * $0100 ;page suivante BSBRM=. ;***** (APPEND e1 . . . en) ; Utilise la methode d'accrochage de bord. ; Le doublet d'initialisation de la recopie ; est reutilise pour chaque argument quelque soit leur nombre. .IFNE BIG APPND: XCHG MOV A,D ; TEST 0 ARGUMENTS INR A RZ ; RETOURNE NIL POP B ; POINTEUR INUTILE LXI B,.APP ;en cas d'erreur JTNUM D,ERXONS ; pas de cdr numerique helas, trois fois helas PUSH D ; sauve le dernier CALL NCNSN ; doublet d'initialisation XCHG ; DANS DE POP H ; RECUPERE DERNIER ARGUMENT XTHL ; LE SUIVANT S'IL EXISTE PUSH D ; PLACE LE DOUBLET D'INITIALISATION MOV A,H INR A JNZ CPFLT ; Y EN A PLUS D'UN POP D ; REPREND LE DOUBLET D'INITIALISATION XTHL ; REPLACE LE MARQUEUR, RECUPERE L'ARGUMENT LXI B,NIL PUSH B ; FORCE NIL EN DERNIER ARGUMENT PUSH D ; REPLACE LE DOUBLET D'INITIALISATION JMP CPFLT ; POUR FORCER LA RECOPIE DE L'ARGUMENT UNIQUE .PAGE CPFL: PUSH D ; SAUVE LE DERNIER DOUBLET CREE .UNCNS ; SEPARE LA LISTE PUSH H ; SAUVE LE CDR LXI B,NIL ; CREE UN DOUBLET DE CDR NUL CALL BNCNS ; EN ROUTE POP B ; RECUPERE LE RESTE DE LA LISTE XCHG ; DE <- NOUVEAU DOUBLET POP H ; PRECEDENT DOUBLET .RPLD D,E ; (RPLACD HL DE) MOV H,B ; HL <- LE RESTE DE LA LISTE MOV L,C CPFLT: JTLST H,CPFL ; C'EST PAS FINI POP H ; (CDR HL) = LA COPIE QU'ON VIENT DE FAIRE POP B ; RECUPERE LA PRECEDENTE COPIE (OU DERNIER ARG) XCHG ; HL <- DERNIER DOUBLET CREE .RPLD B,C ; ACCROCHE MOV H,D ; DOUBLET D'INITIALISATION MOV L,E ; QUE L'ON RECUPERE INR L ; BC <- (CDR HL) INR L ; LA COPIE SEULEMENT MOV B,M MVI M,HNIL ; REINITIALISE A NIL INR L MOV C,M MVI M,NIL & $00FF POP H ; AU SUIVANT PUSH B ; RANGE LE RESULTAT PUSH D ; RANGE DOUBLET D'INITIALISATION MOV A,H ; ET AU SUIVANT INR A ; s'il en reste JNZ CPFLT ; ET OUI POP D ; NETTOIE LA PILE POP H ; RECUPERE LA RECOPIE RET ; OUF .ENDC ; de BIG ;***** (MCONS e1 . . . en) .IFNE BIG MCONS: MOV A,H ; TEST 0 ARGUMENT INR A XCHG ; FACILITE L'ALTERNATIVE RZ ; RETOURNE NIL POP B ; POINTEUR INUTILE XCHG ; HL <- DERNIER ARGUMENT JMP MCNST ; AU BOULOT .ENDC ; DE BIG .PAGE ;***** (NCONC E1 . . . EN) [SUBR N] NCONC: XCHG MOV A,D ; TEST 0 ARGUMENT INR A RZ ; OK RAMENE NIL POP B ; POINTEUR INUTILE JFNUM D,NCNT ; en voiture LXI B,.NCONC ; pas de cdr numerique JMP ERXONS ; vers l'erreur NCNS: JFLST H,NCNT ; C'EST PAS UNE LISTE PUSH H ; ARGUMENT SUIVANT CALL CONC ; ACCROCHE POP D ; LE PREMIER DOUBLET CORRESPONDANT NCNT: POP H ; ARGUMENT SUIVANT MOV A,H ; S'IL EN RESTE INR A JNZ NCNS ; CA ROULE XCHG ; HL <- DERNIER ACCROCHAGE RET ; ET VOILA ;----- CONC : (rplacd (Last HL) DE) TCONC: RFLST H ; rien a faire CONCX: XCHG CONC: PUSH D ; sauve l'accroche CALL LAST1 ; calcul le dernier de l'accrocheur POP D .RPLD D,E ; accroche RET ; c'est tout .PAGE .SBTTL; Zone M : fonctions sur symboles ;***** (CONCAT e1 .... en) [SUBR N] ; ; fabrique un nouvel atome, en concatenant ceux donnes .IFNE BIG CONCAT: MOV A,H ; test 0 arg INR A JZ FALSE ; n'importe quoi XTHL ; range le dernier, enleve le pointeur LXI D,$FFFF ; marqueur du haut, car on opere a l'envers PUSH D ; voila PUSH H ; pour tout oublier a la fin DCX H ; saute le marqueur du haut DCX H ; sur le premier arg LXI D,MBUF ; le buffer d'entree XRA A ; rien pour le moment STAX D ; futur p-length MOV B,A ; B <- 0 INR E ; pointe sur futur premier caractere JMP COCATI ; en voiture .PAGE ;------ COCATL : concatenation des atomes se trouvant dans la pile COCATL: MOV A,M ; charge l'arg DCX H ; rebelotte faible PUSH H ; memorise le pointeur interne MOV L,M ; voila le faible MOV H,A ; HL <- l'arg LXI B,.CONCA JTLST H,ARGNAT ; n'importe quoi JFNUM H,CONCSY ; c'est un symbole LDA MBUF ; nombre courant CPI 57 ; taille max apres le nombre JNC ERLC1 ; taille max d'un symbole ! CALL EDNBRM ; edite le nombre LXI H,MBUF ; pointe sur la nouvelle longueur MOV A,L ; le depart ADD M ; ajoute la longueur INR A ; pour pointer sur la premiere case libre MOV L,A ; et voila XCHG JMP COCATT ; a la suite .PAGE CONCSY: LXI B,10 ; offset p-length DAD B ; car B = 0 depuis le debut MOV C,M ; charge p-length XRA A ; A <- 0 CMP C ; cas du p-name nul JZ COCATT ; c'est lui au suivant LDA MBUF ; charge p-length en cours ADD C ; en plus CPI 63 ; taille max JNC ERLC1 ; trop long ! STA MBUF ; ok INX H ; a la suite .IFNE ZILOG LDIR ; on balance tout .IFF ; de ZILOG CON80: MOV A,M ; charge p-name STAX D ; dans le buffer INX H ; avance dans l'atome INR E ; avance dans le buffer (meme page) DCR C ; decremente le compteur JNZ CON80 ; et voila .ENDC ; de ZILOG COCATT: POP H ; au suivant COCATI: DCX H MOV A,M ; s'il en reste INR A ; c'est le marqueur JNZ COCATL ; ca repart POP H ; le pointeur de depart SPHL ; oublie tout JMP TRYAT ; on interne .ENDC ; de BIG .PAGE .SBTTL; Zone M : fonctions arithmetiques ;***** (MIN E1 ... EN) [SUBR N] MIN: LXI B,.MIN ; si erreur LXI D,MINT ; si pas 0 arg JMP NSA00 ; agira en consequence MINL: CALL COMPM ; compare JP MINT ; LE NOUVEAU EST LE BON XCHG ; REMETS L'ANCIEN MINT: POP D ; AU SUIVANT MOV A,D ; S'IL EN RESTE INR A JNZ MINL ; OUIAP C'EST REPARTI JMP CRANB ; ET VOILA ;***** (MAX E1 ... EN) [SUBR N] MAX: LXI B,.MAX ; si erreur LXI D,MAXT ; si pas 0 arg JMP NSA00 ; a lui de voir MAXL: CALL COMPM ; compare JM MAXT ; LE NOUVEAU EST LE BON XCHG ; REMETS L'ANCIEN MAXT: POP D ; AU SUIVANT MOV A,D ; S'IL EN RESTE INR A JNZ MAXL ; OUIAP C'EST REPARTI JMP CRANB ; ET VOILA ;---- COMPM : compare HL et DE COMPM: CALL VALNX ; DESINTERNE PUSH H ; SAUVE SA VALEUR UTILISABLE CALL CMPHL ; PREPAE LA SOUSTRACTION DAD D ; OPERATION MOV A,H ; SAUVE LE SIGNE POP H ; RESTAURE LA VALEUR UTILISABLE ORA A ; TEST DU SIGNE RET .PAGE ;***** (+ E1 ... EN) [SUBR N] NPLUS: LXI B,.AADD ; en cas d'erreur LXI D,NPLT ; retour si plus d'un argument JMP NSA00 ; retourne 0 directement sinon ;***** (* E1 ... EN) [SUBR N] NTIMES: XCHG ; POUR FACILITER LE TEST 0 ARG LXI H,1 ; CAR (*) --> 1 MOV A,D INR A JZ CRANB ; ON INTERNE 1 XCHG ; REMET LES CHOSES EN PLACE POP B ; PAS BESOIN DU MARQUEUR JMP NTMET ; C'EST PARTI .PAGE ;----- NSA00 : test 0 arguments dans les NSUBR arithmetiques ; BC = nom de la fonction si erreur ; DE = adresse de retour si au moins un argument ; HL et pile intacts ; ; Si pas d'arguments, retourne 0 sans revenir a DE ; Sinon depile le pointeur inutile, interne le premier argument ; et revient en DE NSA00: MOV A,H INR A JZ CRAZR ; resultat rapide XCHG ; DE <- LAST ARG HL <- RETOUR XTHL ; prepare retour et nettoie la pile JMP VALNX ; interne le premier arg ;----- ADDITION D'UNE LISTE DE NOMBRE DANS LA PILE NPLL: CALL VALNX ; DESINTERNE L'ARGUMENT DAD D ; ADDITIONNE NPLT: POP D ; AU SUIVANT MOV A,D ; S'IL EN RESTE INR A JNZ NPLL ; EH OUI JMP CRANB ; TOUT EST BIEN QUI FINIT BIEN ;----- MULTIPLICATION D'UNE LISTE DE NOMBRE DANS LA PILE NTMEL: CALL CSGN ; CALCUL LE SIGNE DU RESULTAT CALL MLT ; EFFECTUE L'OPERATION SANS SIGNE LXI B,.MUL ; en cas d'overflow LDA SIGN ; RECUPERE LE SIGNE ORA A ; POSITIF ? CNZ CMPHL ; NAN. COMPLEMENTE CALL CRANB ; a cause des overflow NTMET: POP D ; SUIVANT MOV A,D INR A JNZ NTMEL ; CA ROULE RET ; voila .PAGE .SBTTL; Zone M : fonctions de sortie ;***** (TYO . L) [SUBR N] ; ; cette fonction envoie des caracteres directement sur l'ecran. ; les arguments sont des codes ascii ou des listes de codes ascii ; si le nombre est superieur a 128, le quotient est considere ; comme un facteur de repetition, augmente de 1 pour etre homogene ; avec l'absence de compteur. TYO: MOV A,H ; test 0 arg INR A JZ TRUTH ; bof XTHL ; place le dernier, prend le pointeur LXI B,$FFFF ; marqueur PUSH B ; car on opere a l'envers PUSH H ; pour le retour final DCX H ; saute le marqueur du bas DCX H ; rebelotte faible DCX H ; sur le premier arg TYOL: MOV D,M ; le fort DCX H ; rebelotte MOV E,M ; faible PUSH H ; memorise le point de parcours XCHG TYOLL: JLTNL H,TYOLT,TYOT ; les listes eventuellement vides CALL COC ; on le sort JMP TYOT ; et ca repart .PAGE TYOLT: ; traitement d'une liste .UNCNS ; separe XCHG ; DE <- reste HL <- premier CALL COC ; on le sort XCHG ; HL <- le reste JTLST H,TYOLT ; ca roule TYOT: POP H ; recupere le point de parcours DCX H ; au suivant MOV A,M INR A ; s'il en reste JNZ TYOL ; oui POP H ; le pointeur sur le debut SPHL ; ecrase la suite JMP TRUTH ; il faut bien ramener quelque chose .PAGE ;----- COC : sort le le caractere avec facteur de repetition COC: LXI B,.TYO ; en cas d'erreur CALL VALNB ; desinterne MOV A,L ; prend le caractere ANI $7F ; enleve la pseudo-parite MOV C,A ; en place pour CO MOV A,H ; test >256 ORA A ; test facteur de repetition JNZ COC2 ; ouaip, au moins 3 MOV A,L ; recharge pour tester le facteur ORA A ; so what ? CM CO ; il y est JMP CO ; de toutes facons COC2: MOV A,L ; pour prendre le bit fort RLC ; qu'on metdans CY MOV A,H ; les 6 bits forts du facteur RAL ; on rajoute le septieme MOV B,A ; qu'on protege COCL: CALL CO ; on sort DCR B ; un de moins JP COCL ; ca roule RET ; voila ESBRM=. TSBRM=ESBRM-BSBRM .PRINT TSBRM .PAGE .SBTTL; Zone 3 : fonctions de creations de listes .=<<.+$FF> ^ > * $0100 ; POUR SE PLACER DANS LA PAGE SUIVANTE BSBR3=. ;***** (DE ACONS (VAR VAL ALIST) ; (CONS (CONS VAR VAL) ALIST) ) ACONS: POP B ; DEUXIEME ARG DONC VAL POP D ; PREMIER ARG DONC NOM PUSH H ; SAUVE LA A-LISTE CALL BCONS ; FABRIQUE LA LIAISON POP B ; RECUPERE LA A-LISTE XCHG ; DE <- LA LIAISON JMP BCONS ; L'AJOUTE DANS LA A-LISTE ;***** (DE SUBST (NEW OLD OBJ) ; (IF (ATOM OBJ) ; (IF (EQ OLD OBJ) ; NEW ; OBJ ) ; (LET ((L1 (SUBST NEW OLD (CAR OBJ))) ; (L2 (SUBST NEW OLD (CDR OBJ))) ) ; (IF (AND (EQ L1 (CAR OBJ)) (EQ L2 (CDR OBJ))) ; OBJ ; (CONS L1 L2) ) ) ) ) SUBST: POP B ; LE SUBSTITUE POP D ; LE SUBSTITUANT SUBSO: JTLST H,SUBSL ; VERS LE TRAITEMENT DES DOUBLETS CMP B ; EST-CE LE SUBSTITUE ? RNZ ; NON RIEN A FAIRE MOV A,L ; REBELOTTE SUR LE POIDS FAIBLE CMP C RNZ MOV H,D ; PAS XCHG ! MOV L,E ; CAR IL FAUT RAMENER LE SUBSTITUANT RET .PAGE SUBSL: PUSH H ; SAUVE POUR RESTAURATION EVENTUELLE PUSH D ; BESOIN DE PLACE .UNCNS XTHL ; SAUVE LES CDR XCHG CALL SUBSO ; RECURSION SUR LE CAR XTHL ; RANGE LE RESULTAT CALL SUBSO ; RECURSION SUR LE CDR SHLD A4 ; FAIT DEFAUT POP H ; RESULTAT SUR CAR XCHG ; DANS DE XTHL ; SAUVE SUBTITUANT HL <- OBJET INITIA MOV A,M ; POIDS FORT DU CAR CMP D ; EST-CE LE MEME JNZ SBSN ; NAN FAUT CONSER INR L ; REBELOTTE SUR POIDS FAIBLE MOV A,M CMP E JNZ SBSN PUSH D ; SAUVE LE RESULTAT SUR CAR XCHG ; TEMPORAIREMENT LHLD A4 ; RECUPERE LE RESULTAT SUR CDR XCHG ; HL <-- CDR INITIAL INR L MOV A,M ; C'EST REPARTI CMP D JNZ SBSNR ; RATE INR L ; DIX DE DER MOV A,M CMP E JNZ SBSNR ; C'ETAIT TROP BEAU POP D ; NETTOIE LA PILE (RESULTAT SUR CAR) POP D ; RESTAURE LE SUBSTITUANT DCR L ; REPASSE DCR L ; EN DEBUT DCR L ; DE DOUBLET RET ; C'ETAIT LA FONCTION IDENTITE !!!!! SBSN: LHLD A4 ; RECUPERE RESULTAT SUR CDR XCHG ; DANS DE ET HL <- RESULTAT SUR CAR PUSH H ; MOINS DE PLACE QU'UN JUMP SBSNR: POP H ; RECUPERE RESULTAT SUR CAR PUSH B ; SAUVE LE SUBSTITUE CALL CONS ; HELAS POP B ; RESTAURE LE SUBSTITUE POP D ; RESTAURE LE SUBSTITUANT RET .PAGE .SBTTL; Zone 3 : fonctions de modifications ;***** (RPLAC A B C) [SUBR 3] RPLC3: LXI B,.RPLC3 ; en cas d'erreur JTNUM H,ERCONS ; ENCORE ! XCHG ; DE <- FUTUR CDR POP B ; BC <- FUTUR CAR POP H ; HL <- FUTUR DEFIGURE JFLST H,ERPL3 ; INOXYDABLE ! MOV M,B ; FORT CAR INR L MOV M,C ; FAIBLE CAR INR L MOV M,D ; FORT CDR INR L MOV M,E ; FAIBLE CDR DCR L ; REVENONS AU DEBUT DCR L DCR L RET ; RETOURNE LE PREMIER ARG .PAGE ;***** (PUTPROP PLISTE VAL INDIC) [SUBR 3] PUTP: XCHG ; DE <- INDIC POP B ; POUR ACCEDER A LA P-LISTE POP H ; LA VOILA PUTPR: PUSH H ; ON REMET TOUT PUSH B ; ET VOILA LXI B,.PUT ; charge l'atome PUTPROP CALL GETT ; EFFECTUE LA RECHERCHE JC ADDPX ; IL Y EST POP D ; LA VALEUR INR L INR L ; HL <- SUR LE DOUBLET MOV A,M ; QUI CONTIENT LA VAL. INR L MOV L,M MOV H,A MOV M,D ; on fait le RPLACA INR L MOV M,E POP H ; le nom RET ; est retourne. ;***** (SHARP c . body) [SUBR F] ; ; une 3subr deguisee en Fsubr ; definit un macro-caractere sharp DFSHR: .UNCNS ; separe corps et nom PUSH D ; sauve le nom LXI D,.LAMB ; l'atome LAMBDA CALL XCONS ; on cree la lambda MOV B,H MOV C,L ; BC <- val a mettre POP H ; HL <- nom de la p-liste LXI D,.SHRP ; l'indicateur JMP PUTPR ; execute un put .PAGE ;***** (ADDPROP PLIST VAL INDIC) [SUBR 3] ADDPX: XCHG ; POINT D'ENTREE DE PUT ADDP: XTHL ; HL <- VAL (SP) <- INDIC CALL NCONS ; HL <- (VAL) POP D ; DE <- INDIC P:... PLIST] PUSH H ; P:... PLIST (VAL)] CALL XCONS ; HL <- (INDIC VAL) POP B ; BC <- (V POP D ; DE <- PLIST XCHG ; HL <- PLIST DE <- (INDIC VAL) PUSH B ; pour le nom de LXI B,.ADDP ; charge le nom ADDPROP CALL TPLST ; TESTE LA P-LISTE. POP B ; restaure B INR L INR L ; HL EST JUSTE SUR LA P-LISTE INR C INR C ; BC SUR LE CDR DE (VA MOV A,M ; FABRE LES LIENS. MOV M,D STAX B INR C ; OCTET SUIVANT INR L MOV A,M ; FQUE DE NOUVEAU LES LIENS. MOV M,E STAX B DCR L DCR L DCR L ; HL <- L'ATOME RET ; ET VOILA. .PAGE .SBTTL; Zone 3 : fonctions arithmetiques ;***** (SCALE X Y Z) [SUBR 3] ; SCALE = X * Y / Z le calcul s'effectue SANS signe ! .IFNE BIG SCALE: POP D ; DE <- DEUXIEME ARG XTHL ; HL <- PREMIER (SP) <- TROISIEME CALL CSGN ; calcul du signe de X * Y CALL MLT LXI B,.SCALE ; en cas d'erreur XTHL ; pile <- val intermediaire, HL < - Z CALL VALNB ; HL <- val de Z POP D ; D <- val intermediare XCHG JMP DIV1 ; puis comme division. .ENDC ; de BIG ESBR3=. TSBR3=ESBR3-BSBR3 .PRINT TSBR3 .PAGE .SBTTL; Zone 2 : predicats .=<<.+$FF> ^ > * $0100 ; POUR SE POSITIONNER A LA PAGE SUIVANTE BSBR2=. ; TABLE DE DEBRANCHEMENT DES APPELS DE FONCTIONS PAR APPLY APLYT: .ADDR ERAPP ; 0 NIE WIEM .ADDR AP0S ; 2 0SUBR .ADDR AP1S ; 4 1SUBR .ADDR AP2S ; 6 2SUBR .ADDR AP3S ; 8 3SUBR .ADDR APNS ; 10 NSUBR .ADDR APFS ; 12 FSUBR .ADDR APEX ; 14 EXPR .ADDR APEX ; 16 FEXPR .ADDR APMAC ; 18 MACRO .ADDR APNS ; 20 NSUBR associatives .ADDR AP1V ; 22 variables fonctions 1 .ADDR AP2V ; 24 variables fonctions 2 ;***** (EQ S1 S2) [SUBR 2] TEST DES POINTEURS! PEQ: POP D ; RECUPERE LE PREMIER; C'EST COMMUTATIF FEQ: MOV A,H CMP D ; test partie haute. JNZ FALSE MOV A,L CMP E ; test partie basse JNZ FALSE TRUTH: LXI H,.T RET ;***** (NEQ S1 S2) [SUBR 2] PNEQ: POP D MOV A,H CMP D ; test partie haute. JNZ TRUTH ; c'est bien faux. MOV A,L CMP E ; test partie basse. JNZ TRUTH ; C'EST BIEN ENCORE FAUX. JMP FALSE ; ILS SONR HELAS EGAUX. ;***** (NEQUAL s1 s2) [SUBR 2] .IFNE BIG NEQUAL: POP D LXI B,NULL ; adresse du NOT PUSH B ; nouvelle continuation JMP EQUAL .ENDC ; de BIG .PAGE ;***** (EQUAL s1 s2) [SUBR 2] ; le nouveau EQUAL! PEQUAL: POP D JMP EQUAL EQUA1: PUSH D ; pile :: S2 .UNCNS ; DE <- (CAR S1), HL <- (CDR S1) XTHL ; HL <- S2, pile :: (CDR S1) PUSH D ; pile :: (CAR S1) (CDR S1) .UNCNS ; DE <- (CAR S2), HL <- (CDR S2) XTHL ; HL <- (CAR S1) pile :: (CDR S2) (CDR S1) ;;; Y FAUDRAIT TESTER LA PILE !!! CALL EQUAL ; recurse sur les CARs. MOV A,H ; Si les CARs sont pas CPI HNIL ; egaux. POP D ; recupere le reste de S2, POP H ; recupere le reste de S1, JZ FALSE ; c'est fini, les CARs n'etaient pas egaux. EQUAL: JFLST H,FEQ ; (COND ((ATOM S1)(EQ S1 S2)) JTLST D,EQUA1 ; ((ATOM S2) NIL) JMP FALSE ; (T (AND (EQUAL (CAR S1)(CAR S2)) ; (EQUAL (CDR S1)(CDR S2))))) .PAGE ;***** (ALPHALESSP AT1 AT2) [SUBR 2] ; RAMENE T SI PNAME AT1 <= PNAME AT2 SORT: POP D LXI B,.SORT ; en cas d'erreur CALL RTATO ; il faut un atome litteral CALL RTATOX ; la aussi, et echange LXI B,10 ; OFFSET P-LEN DAD B ; HL <- P-LEN AT1 XCHG ; DE <- P-LEN AT1 DAD B ; HL <- P-LEN AT2 XCHG ; A CAUSE DU JC. LDAX D ; RECUP LE 1ER P-LEN MOV C,M ; deuxieme p-len CMP C ; quel est le plus petit ? JNC SORT4 ; C'EST LE PLUS PETIT. MOV C,A ; C CONTIENT LE PLUS PETIT P-LEN. SORT1: INX H ; AVANCE DANS 1 INX D ;AVANCE DANS AT2 LDAX D ; A <- CAR AT2 CMP M JC FALSE ; c'est vraiment plus petit. JNZ TRUTH ; c'est vraiment plus grand. DCR C ; ya encore des caracteres dans le + petit P-name ? JNZ SORT1 ; oui : on continue a tester. JMP FALSE ; si le 1er est identique au debut du 2eme. SORT4: INX H ; AVANCE DANS 1 INX D ;AVANCE DANS AT2 LDAX D ; A <- CAR AT2 CMP M JC FALSE ; c'est vraiment plus petit. JNZ TRUTH ; c'est vraiment plus grand. DCR C ; ya encore des caracteres dans le + petit P-name ? JNZ SORT4 ; oui : on continue a tester. JMP TRUTH ; si le 1er est identique au debut du 2eme. .PAGE .SBTTL; Zone 2 : fonctions de recherche ;***** (MEMQ A L) [SUBR 2] PMEMQ: POP D MEMQ1: RFLST H ; YA PU D'ELEMENTS. MOV A,M CMP D ; EQ OPEN. JNZ MEMQ2 ; PAS PAREIL. INR L MOV A,M DCR L CMP E RZ ; C'EST TOUT BON. MEMQ2: INR L ; CDR SUIVANT. INR L MOV A,M INR L MOV L,M MOV H,A JMP MEMQ1 ;***** (MEMBER S L) [SUBR 2] PMEMBR: POP D MEMBER: RFLST H ; L PAS UNE LISTE MEMBA: PUSH H ; SAUVE LA LISTE ACTUELLE PUSH D ; SAUVE LE CHERCHE MOV A,M ; HL <- CAR HL INR L MOV L,M MOV H,A CALL EQUAL ; TESTE MOV A,H ; RANGE LE RESULTAT POP D ; RESTAURE TOUT POP H CPI HNIL ; EXAMINONS ENFIN LE RESULTAT RNZ ; OK (CAR HL) = DE INR L ; HL <- CDR HL INR L MOV A,M INR L MOV L,M MOV H,A ; VOILA CPI HLIST ; y en a encore ? JNC MEMBA ; ouaip RET ; C'EST FOUTU ;***** (NTH n L) [SUBR 2] ;***** (NTHCDR n L) [SUBR 2] CNTH: POP D LXI B,CAR ; EMPILE UN APPEL DE 'CAR'. PUSH B ; NTH DOIT SUIVRE ... LXI B,.CNTH ; atome CNTH (si erreur) JMP NTH0 ; puis c'est pareil NTH: LXI B,.NTH ; atome NTH (si erreur) POP D ; RECUPERE LE NOMBRE NTH0: RFLST H ; C'EST PLUS UNE LISTE. CALL VALNX ; HL <- le nombre sur 16 bits XCHG ; tout reprend place ORA A ; test les poids forts RM ; si le nb est < 0 c'est fini. INX D ; meilleur que jmp NTH1: DCX D ; decompte MOV A,D ORA E ; tes tpar rapport a 0 sur 16 bits RZ ; LE COMPTE EST BON. INR L ; HL <- (CDR HL) INR L MOV A,M INR L MOV L,M MOV H,A CPI HLIST ; y en a toujours JNC NTH1 ; ouaip RET ; C'EST PU UNE LISTE. .PAGE .SBTTL; Zone 2 : fonctions sur a-listes ;***** (ASSQ A A-LIST) [SUBR 2] ;***** (CASSQ A A-LIST) [SUBR 2] si BIG uniquement! .IFNE BIG CASSQ: XCHG ; DE <- A-LISTE LXI H,CDR ; prepare le CDR final XTHL ; le place et recupere l'atome ;;; ASSQ doit suivre .ENDC ; de BIG ASSQ: XCHG ; DE <- L'ATOME HL <- LA A-LISTE PUSH D ; SIMULE UN APPEL PAR EVAL PASSQ: POP B ; l'atome a tester ASSQ1: RFLST H ; EST EST VIDE. .UNCNS LDAX D ; CHARGE FAIBLE CAR CMP B ; COMPARE LE CAR DE LA A-LISTE JNZ ASSQ1 ; AVEC BC INR E LDAX D CMP C ; POUR LE 2EME JNZ ASSQ1 DCR E ; REPASSE EN DEBUT DE DOUBLET XCHG RET ; SI OK RAMENE LE CAR DE LA A-LISTE. .PAGE ;***** (DE SUBLIS (A L) ; (IF (ATOM L) ; (IF (ASSQ L A) ; (CASSQ L A) ; L ) ; (LET ((L1 (SUBLIS A (CAR L))) ; (L2 (SUBLIS A (CDR L))) ) ; (IF (AND (EQ L1 (CAR L)) (EQ L2 (CDR L2))) ; L ; (CONS L1 L2) ) ) ) ) .IFNE BIG SUBLS: POP D ; HL <- L'OBJET DE <- A-LIST SUBLO: PUSH H ; SAUVE POUR RESTITUTION EVENTUELLE JTLST H,SUBLL ; VERS LE TRAITEMENT DES DOUBLETS CALL ASSQ ; Y-EST-IL ? POP D ; RECUPERE L'OBJET JFNIL H,CDR ; IL Y EST, RAMENE LA VALEUR XCHG ; HL <- L'OBJET RET .PAGE SUBLL: PUSH D ; FAIT DE LA PLACE ; ?!?! a verifier je viens d'enlever du bllsht! .UNCNS XTHL ; SAUVE LE CDR . . . PUSH H ; ET CONSULTE LA A-LIST XCHG ; TOUT LE MONDE EN PLACE CALL SUBLO ; RECURSION SUR LE CAR POP D ; RETIRE DEFINITIVEMENT LA A-LIST XTHL ; SAUVE LE RESULTAT DU CAR CALL SUBLO ; RECURSION SUR LE CDR POP D ; RECUPERE LE RESULTAT DU CAR POP B ; RECUPERE L'OBJET INITIAL LDAX B ; POIDS FORT DU CAR CMP D ; SONT-CE LES MEMES ? JNZ XCONS ; NON, FAUT CONSER INR C ; AVANCE LDAX B ; REBELOTTE SUR POIDS FAIBLE ; 10 - 1000l$1000t CMP E JNZ XCONS ; C'ETAIT TROP BEAU INR C ; ENCORE LDAX B ; REBELOTTE SUR LE CDR CMP H JNZ XCONS ; C'ETAIT TROP MERVEILLEUX INR C LDAX B ; DIX DE DER CMP L JNZ XCONS ; TOUJOURS TROIS SANS QUATRE DCR C ; REPASSE DCR C ; EN DEBUT DCR C ; DE DOUBLET MOV H,B ; TOUT CA MOV L,C ; POUR ETRE FINALEMENT RET ; LA FONCTION IDENTITE !!! .ENDC ; DE BIG .PAGE .SBTTL; Zone 2 : fonctions sur p-listes ;***** (GETPROP PLIST INDIC) [SUBR 2] GETP: LXI B,.GET ; charge l'atome GETPROP POP D XCHG CALL GETPR ; qui fait tout! JC FALSE ; YA PAS L'INDIC. RET ; ELLE Y EST ;***** (REMPROP PLIST INDIC) [SUBR 2] REMP: XCHG POP H ; LA P-LISTE PUSH H ; SAUVE LA P-LISTE LXI B,.REMP ; charge l'atome REMPROP CALL GETT ; EFFECTUE LA RECHERCHE DE L'INDIC. JC REMP1 ; IL N'Y ETAIT PAS INR L INR L MOV A,M ; HL <- CDR HL INR L MOV L,M MOV H,A INR L INR L ; 2EME CDR MOV A,M STAX B ; BC CONTIENT TOUJOURS LE POINT ARRIERE INR C INR L ; (CFETT) MOV A,M STAX B POP H ; RECUP L AP-LISTE RET REMP1: POP B ; DEPILE N'IMPORTE OU RET ; ET RAMENE LE DERNIER CDR. .PAGE ;----- GETPR : ramene la valeur associee a l'indicateur DE dans HL ; avec Carry si il n'y a pas GETPR: CALL GETT ; cherche RC ; y a pas CALL CADR ; prend la valeur XRA A ; CY <- 0 RET ;----- GETT : CHERCHE DANS LA P-LISTE HL L'INDIC DE ; RAMENE CARRY SI YA PAS, RAMENE NC SI YA AVEC ; HL POINTANT SUR L'INDIC ET BC POINT ARRIERE (REMP) GETT: CALL TPLST ; C'EST UNE BONE P-LISTE . GETT1: INR L INR L MOV B,H ; B <- POINT ARRIERE MOV C,L MOV A,M ; HL <- CDR HL INR L MOV L,M MOV H,A CPI HLIST ; c'est encore une liste ? JC GETTF ; nan MOV A,M CMP D ; TEST INDIC JNZ GETT2 ; C'EST PAS CUI-LA. INR L MOV A,M DCR L ; REPOSIT SUR INDIC. CMP E ; SUITE DU TEST RZ ; !OK! RETOUR AVEC CY POSITIONNE. GETT2: INR L INR L ; HL <- CDR HL MOV A,M INR L MOV L,M MOV H,A CPI HLIST ; test encore iste JNC GETT1 ; ouaip GETTF: STC ; RETOUR FAUX RET .PAGE .SBTTL; Zone 2 : fonctions de modifications ;***** (RPLACA S1 S2) [SUBR 2] PRPLA: POP D XCHG RPLCA: LXI B,.RPLCA ; atome RPLACA JFLST H,ARGNLS ; C'EST UN ATOME ! RPCA1: MOV M,D INR L MOV M,E DCR L ; RAMENE LE H&L DU DEBUT. RET ;***** (RPLACD S1 S2) [SUBR 2] RPLCD: ;;; fonction standard POP D XCHG LXI B,.RPLCD ; atome RPLACD JFLST H,ARGNLS ; c'est pas une liste ! PUSH H ; SAUVE LA VAL DE RETOUR. JTNUM D,ERXONS; car cela cre des doublets veroles. INR L INR L ; position CDR MOV M,D INR L ; force DE MOV M,E POP H ; RECUP LA VAL DE RET. RET .PAGE ;***** (DISPLACE S1 S2) [SUBR 2] RPLCB: LXI D,.PROGN ; en cas d'tomicite' MOV A,H ; ca doit fabriquer CPI HLIST CC XEXONS ; (progn ) POP D LXI B,.RPLCB ; atome RPLACB JFLST D,ARGNLX ; c'est pas une liste PUSH D ; SAUVE LA VAL DE RETOUR. .RPLCB ; UNE BONNE MACRO SI ZILOG POP H ; RECUP LE POINT. RET ; VOILA. .IFNE ZILOG .IFF ; 5 octets sur Z80, ca vaut pas le coup RPLB0: MVI B,4 ; 10 sur 8080, l'idiot ! RPLB1: MOV A,M STAX D INR E INR L DCR B ; compteur JNZ RPLB1 ; ca repart RET ; c'est tout .ENDC ; de ZILOG ;***** (PLACDL L E) [SUBR 2] ; (CDR (RPLACD L (CONS E ()))) ; ideal pour les accrochages de bord ! PLACPX: ; entree pour les routines systemes inversees XCHG PLACP: ; entree pour les routines systemes PUSH D PLAC1: .PLACE ; par lui tout a ete fait XCHG ; pour ramener le CDR RET .PAGE ;***** (NRECONC L1 L2) [SUBR 2] .IFNE BIG PFREV: POP D RFLST D ; Y A RIEN A FAIRE FREV2: XCHG ; HL <- CDR HL DE <- VIEUX HL INR L INR L MOV A,M MOV M,D ; M <-> D MOV D,A INR L MOV A,M MOV M,E ; M <-> E MOV E,A ; DE <- CDR HL DCR L DCR L DCR L ; REPOSITIONNE HL SUR LE DOUBLET FREVR: JTLST D,FREV2 ; CA COTINUE RET ; VOILA .ENDC ; DE BIG .PAGE .SBTTL; Zone 2 : variables fonctions ;***** (CVAL A [e]) [SUBR2V] CVSET: LXI B,.CVAL JTVAR D,ERPLCX ; horreur MOV A,H ; rplaca sauvage STAX D INR E MOV A,L STAX D RET ; et on ramene la valeur .ADDR CVSET CVGET: LXI B,.CVAL ; si erreur CALL RTATO ; test atome litteral MOV A,M INR L MOV L,M MOV H,A RET ;***** (PLIST a [e]) [SUBR2V] PLISET: LXI B,.PLIST ; en cas d'erreur XCHG ; DANS HL CALL TPLST ; teste si vraie P-liste. .RPLD D,E ; et force le CDR XCHG ; doit retourner la nouvelle RET ; P-liste. .ADDR PLISET PLIST: LXI B,.PLIST; charge l'atome PLIST CALL TPLST ; teste vraie P-liste. JMP CDRNT ; et retourne la P-liste. .PAGE ;***** (VALFN at [val]) [SUBR2V] ; GET/SET la fval de l'atome litteral. VFSET: LXI B,.FVAL ; charge l'atome FVAL CALL RTATOX ; inverse, test de type, revient si ok PUSH D ; prepare la valeur de retour LDAX D ; A = type du CAR de DE JFNUM A,FVAL0 ; c'est pas (high low) XCHG ; HL <- (high low) CALL CALAD ; calcul la vraie adresse XCHG ; tout revient en place FVAL0: LXI B,4 ; offset F-val DAD B ; HL <- sur la F-val MOV M,E ; SET. INR L MOV M,D POP H ; et retourne val (non modifiee) RET ; .ADDR VFSET VFGET: LXI B,.FVAL ; en cas d'erreur CALL RTATO ; revient si ok, sinon declenche l'erreur LXI B,4 ; GET seul DAD B ; HL <- sur la F-val MOV E,M ; INR L MOV D,M XCHG ; retourne f-val. JFLST H,FADRES; retourne l'adresse (high low) RET .PAGE ;***** (TYPEFN at [ftype]) [SUBR2V] ; GET/SET en clair du type de la fonction associee a at. FTSET: LXI B,.TYPFN; charge l'atome FTYPE CALL RTATOX ; echange, test de type, revient si ok XCHG ; HL <- F-type, DE <- atome. PUSH H ; sauve la valeur de retour PUSH D ; pour la suite. CALL GFTYP ; A <- le F-type pret. POP D ; D <- le nom de l'atome. LXI H,6 ; offset F-type. DAD D ; HL <- pointeur F-type. MOV M,A ; force le F-type. POP H ; recupere l'arg RET ; et rentre .ADDR FTSET FTGET: LXI B,.TYPFN CALL RTATO LXI D,6 ; offset du F-type. DAD D ; pointeur sur le F-type. MOV E,M ; E <- le F-type. MVI D,0 ; pour le DAD. LXI H,TYPFT ; adresse de la table des clairs des noms. DAD D ; adresse du clair. MOV A,M INR L MOV H,M MOV L,A ; FTYPE CLAIR RET .PAGE ;----- GFTYP : HL <- contient le nom d'un type de fnt. ; retourne dans A le F-type (x 2) GFTYP: PUSH D ; tout doit rester propre. LXI D,TYPFT+26 ; adresse de la fin de la table des noms de type. GFTYP1: DCX D LDAX D ; H du nom. CMP H ; c'est le meme ? JNZ GFTYP2 ; nan : a suivre. DCX D LDAX D ; L du nom. CMP L ; c'est le meme ? JNZ GFTYP3 ; nan : a suivre. MOV A,E ; calcul du code. SUI TYPFT & $FF ; pour avoir le code pur. POP D ; restaure tout. RET ; et retourne A. GFTYP2: DCX D ; recule le L GFTYP3: MOV A,E ; il y en a encore ? CPI TYPFT & $FF ; hein ? JNC GFTYP1 ; oui : on continue la recherche. XRA A ; sinon retourne 0 POP D ; et nettoie tout. RET ; et voila. .PAGE ;***** (MEMORYB (high low) [value]) [SUBR2V] ; ou (MEMORYB adresse [value]) ; si VALUE, SET si non VALUE, GET MEMSET: LXI B,.MEMRY ; en cas d'erreur CALL VALNB ; desinterne le nombre XCHG CALL CALAD ; et l'adresse MOV M,E ; force ! XCHG ; la valeur RET .ADDR MEMSET MEMGET: CALL CALAD ; calcule l'adresse MOV A,M ; GET JMP CRANA ; vers l'internement. ;***** (INBUF ) [SUBR2V] ;***** (OUTBUF ) [SUBR2V] ; retourne (et modifie parfois) le caractere de position n INBSET: PUSH D ; fait de la place LXI D,INBUF ; debut du buffer d'entree LXI B,.INBU ; en cas d'erreur JMP IOUBUF ; et c'est commun OUBSET: PUSH D ; fait de la place LXI D,OUBUF ; debut du buffer de sortie LXI B,.OUTBU ; en cas d'erreur IOUBUF: CALL OUTMRG ; desinterne le code ascci XTHL ; prend la position CALL OUTMRG ; la desinterne DAD D ; pointe sur la position desiree POP D ; recupere la valeur MOV M,E ; force le buffer JMP CRANX ; et reinterne la valeur .ADDR INBSET INBGET: LXI D,INBUF ; debut du buffer d'entree LXI B,.INBU ; en cas d'erreur JMP OUNBUF ; et apres c'est commun .ADDR OUBSET OUBGET: LXI D,OUBUF ; buffer de sortie LXI B,.OUTBU ; en cas d'erreur OUNBUF: CALL OUTMRG ; desinterne et provoque l'erreur EROOL si besoin DAD D ; pointe sur la position desiree MOV A,M JMP CRANA ; ramene le code ascii .PAGE ;***** (TYPECN C VAL) [SUBR2V] ;***** (TYPECH C VAL) [SUBR2V] ; get / set le type du caractere dans la table TABCH TCSET: LXI B,.TYPCH TCSEN: PUSH H ; sauve le type CALL VLAX ; prend le code ascii de DE, dans A POP D ; recupere le type MOV L,A ; et aussi dans L JMP TYPST ; et c'est commun TASET: LXI B,.TYPCN CALL OUXMRG ; echange, desinterne dans HL TYPST: PUSH D ; sauve la valeur de retour CALL OUXMRG ; desinterne le nombre MOV A,E ; prend le code ascii du caractere RRC ; 2 caracteres par octet ANI $3F ; 64 octets, la table LXI B,TABCH ; la table ADD C ; on indexe MOV C,A ; voila MOV A,E ; prend le code a nouveau RRC ; test partie droite ou gauche MVI D,$F0 ; a priori c'est a gauche JC TYPSTG ; ouais MOV A,L ; nan, prend le nouveau type RLC ; on decale RLC RLC RLC MOV L,A ; on remet MVI D,$0F ; masque droit TYPSTG: LDAX B ; prend le double type ANA D ; memorise suelement le voisin ORA L ; inclue le bon STAX B ; range la nouvelle valeur POP H ; recupere l'entree RET .ADDR TCSET TCGET: LXI B,.TYPCH CALL VLAS ; echange, prend le code ascii de HL , dans A MOV L,A ; et dans A JMP GECAP ; et c'est commun .ADDR TASET TAGET: LXI B,.TYPCN CALL OUTMRG ; desinterne HL dans HL et controle MOV A,L ; charge le code ascii GECAP: CALL GETAP ; charge le type JMP CRANA ; QUI EST INTERNE. .PAGE ;***** (PTYPE at [val]) [SUBR2V] ; SET/GET le P-TYPE de l'atome at .IFNE BIG PTSET: PUSH H ; sauve la valeur a ramener LXI B,.PRTP ; atome PTYPE si erreur CALL VALNB ; desinterne ORA A ; controle 0>= et <256 JNZ EROOB ; vers l'erreur CALL RTATOX ; echange, et controle LXI B,7 ; offset p-type DAD B MOV M,E ; SET POP H ; recupere le nombre interne' RET .ADDR PTSET PTGET: LXI B,.PRTP ; en cas d'erreur CALL RTATO ; controle LXI B,7 ; offset DAD B MOV A,M JMP CRANA ; VERS L'INTERNEMENT DU NOMBRE .ENDC ; de BIG .PAGE .SBTTL; Zone 2 : fonctions sur P-name ;***** (CHRNTH n at) [SUBR 2] .IFNE BIG CHRNTH: LXI B,.CHRNT ; en cas d'erreur CALL RTATO ; test atome litteral LXI D,10 ; offset p-length DAD D ; ca pointe sur le p-length POP D ; recupere n XCHG ; dans hl CALL VALNB ; et le desinterne ORA A ; le poids fort est dans A JNZ FALSE ; plus grand que la taille max ! INR L ; pour sauter le p-length LDAX D ; A <- le p-length CMP L ; compare a la position JC FALSE ; ca depasse DAD D ; pointe dans le p-name MOV A,M ; charge le caractere JMP CRANA ; et on l'interne .ENDC ; de big .PAGE ;***** (CHRPOS ) [SUBR 2] ; ; donne la position du caractere de code dans l'atome .IFNE BIG CRPOS: LXI B,.CRPOS ; en cas d'erreur CALL RTATO ; un symbole bon dieu ! POP D ; recupere le code ascii CALL VALNX ; echange HL et DE et interne XCHG ; remet les choses en place LXI B,10 ; offset p-length et compteur inverse DAD B ; voila MOV C,M ; compteur MOV A,E ; le caractere a trouver DCR B ; B <- $FF pour que ce soit 0 au coup d'apres CRPO2: INR B ; compteur de position DCR C ; il en reste dans le p-name ? JM FALSE ; non, c'est faux INX H ; caractere suivant CMP M ; c'est lui ? JNZ CRPO2 ; non ca trourne CRPO3: MOV A,B ; prend le compteur JMP CRANA ; on l'interne .ENDC ; de BIG .PAGE ;***** (SYNONYM at1 at2) [SUBR 2] ; rend identique les 2 atomes en copiant tout : ; CVAL PLIST FVAL FTYPE PTYPE .IFNE BIG SYNON: LXI B,.SYNON; charge l'atome SYNONYM POP D ; le premier arg CALL RTATO ; faut un symbole CALL RTATOX ; echange, et controle litteral JTVAR H,ERPLC ; pas une constante de surcroit. PUSH H ; sera ramene en valeur .IFNE ZILOG XCHG ; DE <- DEST, HL <- EMET LXI B,8 ; 5 attributs LDIR ; on balance tout .IFF MVI C,8 ; pour les 5 attributs SYNON1: LDAX D ; source MOV M,A ; dest INX D ; avance dans la source INX H ; avance dans la destination DCR C ; compte JNZ SYNON1 ; ca roule .ENDC ; de ZILOG POP H ; doit retourner le 1er RET .ENDC ;de BIG .PAGE .SBTTL; Zone 2 : fonctions de construction de listes XEXONS: XCHG NEXONS: ; (CONS HL (CONS DE ())) LXI B,NIL BEXONS: ; (CONS HL (CONS DE BC)) PUSH H ; sauve la tete CALL BCONS ; cree le corps ;;; PCONS doit suivre ;***** (CONS E1 E2) [SUBR 2] PCONS: POP D ; RECUPERE LE FUTUR CAR JMP XCONS ; EH OUI ;***** (XCONS e2 e1) [SUBR 2] PXONS: POP D ; recupere le premier JMP CONS ; comme de juste ;***** (REVERSE L1 L2) [SUBR 2] ; EQUIVALENT A (NCONC (REVERSE L1) L2) REV1: XCHG ; DE <- NEW LISTE HL <- RESTE PUSH D ; SAUVE LA NEW LISTE .UNCNS XTHL CALL XCONS PREV: POP D ; RECUP LE RESTE JTLST D,REV1 ; IL EN RESTE RET .PAGE .SBTTL; Zone 2 : fonctions arithmetiques ;***** (DIV A B) [SUBR 2] PDIV: POP D CALL CSGNX LXI B,.DIV ; en cas de division par zero DIV1: MOV A,D ; TEST DIVISION PAR 0 ORA E JZ ERDIV ; ET C'EST LE CAS. CALL DVD JMP NBSGN ;***** (REM A B) [SUBR 2] PREM: POP D CALL CSGNX LXI B,.REM ; en cas de division par zero MOV A,D ; pour le test de division ORA E ; par 0. JZ ERDIV ; et c'est le cas. CALL DVD JMP CRANX ; C'EST TJRS >= 0. ;***** Fonctions numeriques logiques ; ne travaillent que sur 8 bits! ; LOGAND LOGOR LOGXOR [SUBR 2] LOGAN: POP D MOV A,L ; POIDS FAIBLES 1ER OP. ANA E JMP CRANA LOGOR: POP D MOV A,L ORA E JMP CRANA LOGXO: POP D MOV A,L XRA E JMP CRANA .PAGE ;***** Predicats numeriques a 2 arguments ; tout argument = NIL est equivalent a 0 ! ; EQN NEQN LT GE LE GT [SUBR 2] ; actuellement c'est comme presque comme EQ (a la valeur ramenee pres) EQN: LXI B,.EQN ; atome = si erreur POP D CALL VALN2X ; cherche les val des 2 nombres! MOV A,H CMP D ; test partie haute. JNZ FALSE MOV A,L CMP E ; test partie basse JZ CRANB ; c'est tout interne le 1er arg JMP FALSE ; ca va pas! NEQN: LXI B,.NEQN ; atome <> si erreur POP D CALL VALN2X ; cherche les 2 valeurs MOV A,H CMP D ; test partie haute. JNZ CRANB ; si <> je retourne le 1er. MOV A,L CMP E ; test partie basse JNZ CRANB ; c'est tout bon interne le 1er arg. JMP FALSE ; ca va pas! .PAGE FLE: LXI B,.FLE ; atome >= si erreur POP D PUSH D ; pour un retour vrai JMP GE1I ; vers le commum FGE: LXI B,.FGE ; atome >= si erreur POP D XCHG PUSH H ; pour un retour vrai. GE1I: CALL VALN2 ; recupere les 2 valeurs numeriques. GE1: .IFNE ZILOG ORA A ; CARRY = 0 .BYTE $ED,$52 ; SBC DE .IFF CALL CMPDE ; DE <- - DE DAD D ; N1 - N2 .ENDC ; ZILOG POP D ; 1er argument (si vrai) XCHG ; HL <- pret pour le retour MOV A,D ORA A ; teste le signe du resultat. JM FALSE ; ca va pas. RET ; tout est bon ramene le 1er argument! FLT: LXI B,.FLT ; atome < si erreur. POP D PUSH D ; SI VRAI JMP GT1 ; vers le commun FGT: LXI B,.FGT ; atome > si erreur. POP D XCHG PUSH H ; en cas de retour vrai GT1: CALL VALN2 ; recupere les 2 valeurs numeriques. INX D JMP GE1 .PAGE .SBTTL; Zone 2 : fonctions de sortie ;***** (PRINCN C N) [SUBR 2] ;***** (PRINCH C N) [SUBR 2] ; EDITE N FOIS LE CARACTERE C. PRNK: POP B ; recupere le caractere PUSH B ; qui sera ramene MOV B,C ; pour utiliser OUTB PUSH H ; sauve le nombre eventuel JMP PRNCT ; et apres c'est commun PRNC: POP D ;RECUPERE LE CARACTERE PUSH D ; sauve la valeur de retour PUSH H ; sauve le nombre LXI B,.PRNCH ; en cas d'erreur CALL VLAX ; a <- code ascii de DE MOV B,A ; POUR L'IMPRESSION PRNCT: CALL RAZVF ; raz des compteurs des variables-fonctions POP H ; RECUP LE NB MOV C,L ; a priori y a un nombre JTNUM H,PRNC2 ; qu'est ce que je disais MVI C,0 ; pour qu'il n'y ait qu'un passage PRNC1: PUSH B ; sauve tout CALL PRCHT ; IMPRIME LE CARACT POP B ; restaure PRNC2: DCR C ; ENCORE ? JP PRNC1 ; OUAIP POP H ; retourne C RET ; RAMENE LE CARACTERE. .PAGE .SBTTL; Zone 2 : fonctions de controles ;***** (PROG1 RES . BODY) [SUBR F] PRG1: CALL EVARG ; EVALUE LE PREMIER XCHG ; DE <- (EVAL RES) HL <- BODY PRG1X: PUSH D ; SAUVE LE RESULTAT CALL PROGN ; EVALUE LA SUITE POP H ; RECUPERE RET ; ET VOILA ESBR2=. TSBR2=ESBR2-BSBR2 .PRINT TSBR2 .PAGE .SBTTL; ZONE 1 : Predicats .=<<.+$FF> ^ > * $0100 ; POUR SE POSITIONNER A LA PAGE SUIVANTE BSBR1=. ;***** (LISTP S) [SUBR 1] ;***** (CONSP S) [SUBR 1] LISTP: JLTNL H,TRUTH,TRUTH ; LA VRAIE FAUSSE LISTE ! ;;;; CONSP doit suivre CONSP: RTLST H ; C'EST TOUT BON, C'EST UN DOUBLET JMP FALSE ;***** (ATOM S) [SUBR 1] ;***** (NLISTP S) [SUBR 1] ATOM: JFLST H,TRUTH ; LE VRAI FAUX ATOME ! JMP FALSE NLISTP: RFLST H ; C'EST TOUT BON (NLISTP NIL) ---[SUBR 1] LITATO: JFATO H,FALSE JMP TRUTH ; A CAUSE DE NIL ;***** (NUMBERP S) [SUBR 1] NUMBP: JFNUM H,FALSE RET ; C'EST TOUT BON C'EST PAS NIL ;***** (CONSTANTP S) [SUBR 1] CTEP: JTVAR H,TRUTH ; c'en est une JMP FALSE ; et non ;***** (NULL S) [SUBR 1] NULL: MOV A,H ; CPI HNIL ; C'est NIL ? JZ TRUTH ; nan. FALSE: LXI H,NIL ; ouaip. POPJ1: RET ; voila! .PAGE ;***** (MAKUNBOUND at) [SUBR 1] MKUNB: LXI B,.MKUNB ;en cas d'erreur XCHG ; DE <- l'arg CALL VARCAP ; controle sur D XCHG ; remets en place MVI M,HUNDF INR L ; rebelotte faible MVI M,UNDEF & $FF DCR L ; c'est le debut RET ;***** (REMFN at) [SUBR 1] REMFN: LXI B,.REMFN ; en cas d'erreur CALL RTATO ; teste symbole PUSH H ; a ramener INR L ; passe a la f-val INR L INR L INX H ; on y est XRA A ; A <- 0 MOV M,A ; on efface tout INR L MOV M,A ; rebeloote faible INR L MOV M,A ; le f-type POP H ; la fonction RET .PAGE ;***** (BOUNDP at) [SUBR 1] ; teste si l'atome litteral at possede une valeur. ; retourne T si (CVAL at) <> UNDEF .IFNE BIG BOUND: LXI B,.BOUND ; atome BOUNDP CALL RTATO ; faut un litatom ! MVI A,HUNDF ; H de l'atome UNDEF. CMP M ; c'est le meme ? JNZ TRUTH ; nan : retourne T. INR L MVI A,UNDEF & $FF ; poids faibles. CMP M JNZ TRUTH JMP FALSE .ENDC ; de BIG. .PAGE .SBTTL; Zone 1 : selecteurs ;***** SELECTEURS EN TOUS GENRES. ; C..R ya 6 combinaisons en NOT BIG ; C...R ya 14 combinaisons en BIG .IFNE PEDAG CDDDR: CALL CDR CALL CDR JMP CDR CDDAR: CALL CAR CDDR: CALL CDR JMP CDR CDADR: CALL CDR JMP CDAR CDAAR: CALL CAR CDAR: CALL CAR CDR: MOV A,H ; test de validite' CPI HNIL ; si c'est NIL y a rien a faire RZ ; car (CDR NIL) = NIL CPI HLIST ; faut une liste JC ERCDR ; l'idiot CDRNT: INR L INR L QUOTE: MOV A,M INR L MOV L,M MOV H,A RET CADDR: CALL CDR CALL CDR JMP CAR CADAR: CALL CAR CADR: CALL CDR JMP CAR CAADR: CALL CDR JMP CAAR CAAAR: CALL CAR CAAR: CALL CAR CAR: MOV A,H ; test de validite' CPI HNIL RZ CPI HLIST ; il faut une liste JNC QUOTE ; c'est bon LXI B,.CAR JMP ARGNLS ; erreur .IFF ; de PEDAG .IFNE BIG CAADR: INR L INR L CAAAR: CAAART: MOV A,M INR L MOV L,M MOV H,A JMP CAAR CDADR: INR L INR L CDAAR: CDAART: MOV A,M INR L MOV L,M MOV H,A JMP CDAR .ENDC ; de BIG .IFNE BIG CADDR: INR L INR L CADAR: CADART: MOV A,M INR L MOV L,M MOV H,A .ENDC ; de BIG CADR: INR L INR L CAAR: CAART: MOV A,M INR L MOV L,M MOV H,A JMP CAR .PAGE .IFNE BIG CDDDR: INR L INR L CDDAR: CDDART: MOV A,M INR L MOV L,M MOV H,A .ENDC ; de BIG CDDR: INR L INR L CDAR: CDART: MOV A,M INR L MOV L,M MOV H,A CDRNT: CDR: INR L INR L CAR: CART: QUOTE: MOV A,M ; ***** QUOTE [FSUBR] INR L MOV L,M MOV H,A RET .ENDC ;de pedag .PAGE ;***** (LAST l) [SUBR 1] ; retourne le dernier doublet de l LAST: RFLST H ; ce doit etre une liste. XCHG ; meilleur qu jmp LASTX: XCHG ; HL <- la liste LAST1: INR L INR L MOV D,M INR L MOV E,M ; DE <- (CDR hl) JTLST D,LASTX ; ca roule. DCR L ; REPASSE EN DEBUT DE DOUBLET DCR L ; 11 - 1000l$$1000t$$ DCR L RET ; qui est retournee. .PAGE .SBTTL; Zone 1 : fonctions sur listes ;***** (LENGTH L) [SUBR 1] LENGT: LXI D,0 ; RAZ le compteur. JMP LENG2 ; on y va ... LENG1: INR L ; HL <- (CDR HL). INR L MOV A,M INR L MOV L,M MOV H,A INX D ; incremente le compteur. LENG2: JTLST H,LENG1 ; la liste continue ? JMP CRANX ; nan : vers creation de DE .PAGE ;***** (DE COPY (L) ; (IF (ATOM L) ; L ; (CONS (COPY (CAR L)) ; (COPY (CDR L)) ) ) ) .IFNE BIG COPY: RFLST H ; RIEN A FAIRE .UNCNS PUSH H ; SAUVE LE CDR XCHG ; HL <- (CAR L) CALL COPY ; RECURSION SUR LE CAR XTHL ; RANGE ET RECUPERE LE CDR CALL COPY ;RECURSION SUR LE CDR POP D ; RECUPERE LA COPIE DU CAR JMP XCONS ; ET REUNIT .ENDC ; DE BIG .PAGE .SBTTL; Zone 1 : fonctions sur attributs ;***** (GETDEF at) [SUBR 1] ; retourne la definition de la fonction ; sous forme de DE/DF ou DM ou meme DMC .IFNE BIG GETFN: LXI B,.GETFN; charge l'atome GETFN CALL RTATO ; faut un litteral LXI B,BEXONS ; prepare le retour des test reussis PUSH B ; ca ceera la definition XCHG ; DE <- la fonction (le nom) LXI H,4 ; offset F-val DAD D ; voila MOV C,M ; BC <- F-val INR L MOV B,M ; voila INR L MOV A,M ; le f-type LXI H,.DM ; a priori CPI 18 ; c'est une macro RZ ; gagne', vers BEXONS LXI H,.DF ; a priori CPI 16 ; c'est une fexpr RZ ; gagne vers BEXONS POP H ; a priori c'est rate' CPI 14 ; c'est une expr ? JNZ FALSE ; nan ramene NIL PUSH H ; remets la continuation LXI H,10 ; offset p-length DAD D ; car D contient toujours le nom MOV A,M ; charge le p-length INR L ; pointe sur le premier caractere DCR A ; test p-length = 1 MOV A,M ; charge le caractere avant le test LXI H,.DE ; a priori c'est pas un mono-symbole RNZ ; le test enfin. PUSH B ; sauve la f-val CALL GETAP ; charge le type dans A POP B ; restaure la f-val CPI CLMAC ; c'est un macro-caractere ? RNZ ; nan DE est pret LXI H,.DMC RET ; voila .ENDC ; de BIG .PAGE ;***** (FINDFN L) [SUBR 1] ; retourne le nom de f-val L ou NIL s'il y en a pas FINFN: JFLST H,FINFD ; adresse explicite MOV A,M ; test une adresse de forme (high low) CPI HATOM ; le car est un nombre ? CC CALAD ; calcul l'adresse reelle FINFD: XCHG ; dans DE LXI B,4 ; offset nom/f-val LHLD CATOL ; premier atome JMP SVF3 ; en voiture SVF1: DCX H ; repasse en debut de f-val SVF2: DAD B ; pointe sur a-link MOV A,M ; charge INR L MOV H,M MOV L,A ; HL <- suivant ORA H ; test fin d'oblist JZ FALSE ; retourne NIL SVF3: DAD B ; pointe sur f-val MOV A,E ; faible CMP M ; c'est elle ? JNZ SVF2 ; rate INX H MOV A,D CMP M ; rebelotte JNZ SVF1 ; caramba encore rate LXI B,-5 ; offset DAD B ; repasse en debut de nom RET ; et voila .PAGE ;****** (PLENGTH at) [SUBR 1] .IFNE BIG PLENG: JFATO H,CRAZR ; ce doit etre un atome litteral sinon 0. LXI D,10 ; offset du P-len DAD D ; HL <- pointeur P-len MOV A,M ; recup le nb. JMP CRANA ; on cre A. .ENDC ; de BIG .PAGE .SBTTL; Zone 1 : fonctions arithmetiques ;***** (ABS E) [SUBR 1] .IFNE BIG ABS: LXI B,.ABS ; nom de la fonction ABS CALL VALNB ORA A ; TEST SIGNE CM CMPHL JMP CRANB .ENDC ; de BIG ;***** (1+ E) [SUBR 1] ADD1: LXI B,.ADD1 CALL VALNB INX H JMP CRANB ;***** (1- E) [SUBR 1] SUB1: LXI B,.SUB1 CALL VALNB DCX H JMP CRANB .PAGE .SBTTL; Zone 1 : fonctions de sortie ;***** (ASCII N) [SUBR 1] CRE L'ATOME DE CODE ASCII N. ASCII: MOV A,L ; RECUPERE LES POIDS FAIBLES. ANI $7F ; NB MODUO 128 JMP CRACH ; ON LE CRE. ;***** (CASCII C) [SUBR 1] RAMENE LE CODE ASCII DU CAR C CASCI: LXI B,.CASC ; en cas d'erreur CALL VLAS ; CALCUL DU CODE ASCII DE HL JMP CRANA ; INTERNE LA VALEUR DANS A. ;----- VLAS : MET DANS A LE CODE ASCII DU 1ER CARACTERE ; DE L'ATOME HL (LITTERAL OU NUMERIQUE) VLAS: XCHG VLAX: JTNUM D,VLAS1 ; DANS LE CAS D'UN NOMBRE. CPI HLIST ; 'cest une liste ? JNC ARGNAX ; n'importe quoi LXI H,10 ; pour pinter sur le p-length DAD D ; voila MOV A,M ; on le charge DCR A ; on le compare a 1 XCHG ; en cas d'eereur JNZ OUTMAX ; surement une erreur INX D ; pointe sur le caractere unique LDAX D ; on le charge RET ; VOILA VLAS1: CALL OUXMRG ; desinterne le nombre, controle <128, >0 SUI 10 ; TEST <10 JP OUTMAX ; nop ADI $30+10 ; conversion RET ; c'est tout .PAGE ;***** (IMPLODE L) [SUBR 1] INTERNE LA LISTE L. ; si l'argument L n'est pas fourni la liste a interner se trouve ; dans la valeur du symbole IMPLODE! ; Si cette liste est trop longue elle RESTE dans la CVAL! ; Si la liste est fournie elle remplace la valeur du symbole IMPLODE IMPLO: MOV A,H ; pour le test de type CPI HNIL ; l'argument est fourni ? LXI D,.IMPLD; 'IMPLODE CNZ ASETX ; il faut reaffecter la c-val de implode IMPLO2: LXI B,IMPLP ; adresse de l'indicateur LXI H,READ ; ce qu'il faut faire JMP BINDI1 ; protege des echappements .PAGE .SBTTL; Zone 1 : variables fonctions ;***** (SPRINT [I]) [SUBR1V] ; indicateur d'impression des quote-caracteres SPSET: MOV A,H SUI HNIL ; si c'est nil 0 -> A STA OPTI RET .ADDR SPSET SPGET: LDA OPTI NILIS0: ORA A ; c'est 0 ? JZ FALSE ; alors c'est NIL JMP TRUTH ;***** (ICASE [I]) [SUBR1V] ; indicateur de conversion des minuscules en entree SRSET: MOV A,H SUI HNIL ; si c'est NIL 0 -> A STA IPTI RET .ADDR SRSET SRGET: LDA IPTI JMP NILIS0 .PAGE ;***** (OBASE [N]) [SUBR1V] ; valeur de la base en sortie BASET: LXI B,.STBA ; en cas d'erreur CALL OUTMRG ; desinterne, controle >= 0 <128 et a<- L DCR A ; pour eviter 0 DCR A ; pour eviter 1 CPI 31 ; 32 max JNC ERDIV ; n'importe quoi MOV A,L ; reprend la valeur initiale STA IBASE RET .ADDR BASET BAGET: LDA IBASE JMP CRANA ;***** (PROMPT [a]) [SUBR1V] ; variable fonction gerant le prompt du READ PRSET: LXI B,.PROMP CALL RTATO ; test de validite' SHLD PROMPT RET .ADDR PRSET PRGET: LHLD PROMPT RET .PAGE ;***** (INMAX [N]) [SUBR1V] ; ; taille max de la lecture INXST: LXI B,.INMAX ; en cas d'erreur CALL OUTMRG ; test >0 et <128 STA LBMIX ; ok RET .ADDR INXST INXGT: LDA LBMIX ; charge JMP CRANA ; l'interne ;***** (INPOS [N]) [SUBR1V] ; ; position courante en entree INPST: LXI B,.INPS ; en cas d'erreur CALL OUTMRG ; test >0 et <256 LDA LBMIX ; test < maximum courant CMP L JC OUTMAX ; c'est le cas MOV A,L ; charge le bon STA LBCIU ; voila RET .ADDR INPST INPGT: LDA LBCIU JMP CRANA ;***** (OUTPOS [N]) [SUBR1V] ; ; position courante en sortie OUTSP: LXI B,.OUTPS ; en cas d'erreur CALL OUTMRG ; test >0 et <256 LDA LBMAX ; test < max courant CMP L JC OUTMAX ; c'est pas bon MOV A,L STA LBCOU ; ok RET .ADDR OUTSP OUTPG: LDA LBCOU JMP CRANA .PAGE ;***** (PRINTLEVEL [N]) [SUBR1V] LVSET: LXI B,.PRLVL ; en cas d'erreur CALL OUTMRG ; verifie >0 et <128 STA PRPMAX RET .ADDR LVSET LVGET: LDA PRPMAX JMP CRANA ;***** (PRINTLINE [N]) [SUBR1V] LNSET: PUSH H LXI B,.PRLIN ; en cas d'erreur CALL VALNB SHLD PRLMAX POP H RET .ADDR LNSET LNGET: LHLD PRLMAX JMP CRANB ;***** (PRINTLENGTH [N]) [SUBR1V] LGSET: PUSH H LXI B,.PRLGR ; en cas d'erreur CALL VALNB SHLD PREMAX POP H RET .ADDR LGSET LGGET: LHLD PREMAX JMP CRANB .PAGE ;***** (LMARGIN [N]) [SUBR1V] LMSET: LXI B,.LMARG ; en cas d'erreur CALL OUTMRG ; >0 ET <128 STA LBMIN ; RANGE RET .ADDR LMSET LMGET: LDA LBMIN ; CHARGE LE NOMBRE JMP CRANA ; ET L'INTERNE ;***** (RMARGIN [N]) [SUBR1V] RMSET: LXI B,.LINLG ; en cas d'erreur CALL OUTMRG ; test >0 et <128 STA LBMAX RET .ADDR RMSET RMGET: LDA LBMAX JMP CRANA ESBR1=. TSBR1=ESBR1-BSBR1 .PRINT TSBR1 .PAGE .SBTTL; Zone V : construction du bloc .=<<.+$FF> ^ > * $0100 ; PAGE SUIVANTE BVERU=. ;***** (LOCK CATCH . BODY) [SUBR F] ; construit un bloc de controle de forme: ; PBIND ---> [ UNBV ] ADRESSE DE DESTRUCTION ; [ OLD-PBIND ] POUR SORTIE EXTRAORDINAIRE ; [ NIL ] L'ECHAPPEMENT ABSENT ; [ CATCH ] FONCTION A APPLIQUER ; [ $FFFF ] le marqueur pour FUNCALL LOCK: CALL EVARG ; evalue la fonction a appliquer LXI B,PROGN ; apres la construction, il faudra executer ;;; SIMVER doit suivre ;----- SIMVER : construction d'un bloc verrou ; ; HL = la fonction de verrouillage ; BC = adresse de retour apres construction du bloc ; DE ne doit pas etre detruit et sera mis dans HL avant le retour SIMVER: PUSH H ; de la place LXI H,$FFFF ; le marqueur pour FUNCALL XTHL ; le place en premier PUSH H ; avec la fonction de verrouillage par dessus LXI H,NIL ; l'absence d'echappement PUSH H ; voila LHLD PBIND ; prend l'ancien PBIND PUSH H ; le place LXI H,-2 ; calcul du nouveau pbind DAD SP ; voila SHLD PBIND ; tout est pret CALL APFS ; execute le "XCHG PUSH B RET" UNBV: UNBVE: XCHG ; sauve le resultat POP H SHLD PBIND ; RESTAURE LXI H,6 ; le pointeur la dessus JMP FUNCAD ; en route .PAGE .SBTTL; Zone V : gestion des dlambda ;----- LIAISON NORMALE DES FONCTIONS UTILISATEURS ; HL = LES PARAMETRES ; DE = LA LISTE ARGUMENT TOUTE EVALUATION FAITE SI BESOIN ; EEXNC = 0 SI LIAISON EN DEUX TEMPS (EXPR) ; 1 SINON (FEXPR, MACRO, APPLY) ; RDLAMB = ADRESSE DE RETOUR ; Il s'agit soit des fexprs, macros ou apply sur expr, fexpr,macro ; soit d'expr dont les arguments sont en cours d'evaluation. ; dans le premier cas, l'echange des c-vals peut etre fait mais ; pas dans l'autre. La variable globale EEXNC indique le choix. ; La difficulte reside dans le fait que le parcours arborescent ; ne peut etre traite par la pile , car elle est utilisee pour ; recevoir les valeurs. La suite du parcours est donc ; memorise par une a-liste. La fonction suivante realis ; un parcours iteratif jusqu'a trouver un atome, en controlant ; la conformite des arguments, et en ne faisant pas de memorisation ; dans le cas d'une liste de longueur 1. ; ; ; (DS BNDT (P A L) ; (COND ; ((ATOM P) (BNDA P A L)) ; ((NLISTP A) (SYSERROR 'EVAL 'ERWLA (LIST P A))) ; ((CDR P) (BNDT (CAR P) (CAR A) (ACONS (CDR P) (CDR A) L))) ; ((CDR A) (SYSERROR 'EVAL 'ERWNA (CDR A))) ; ( T (BNDT (CAR P) (CAR A) L)) ) ) ; La fonction BNDA est destinee a faire la liaison effective ; et a relancer sur la a-liste. ; Une version innefficiente mais juste serait: ; (DS BNDA (HL DE AL) ; (WHEN HL ; (IF EEXNC ; (PUSH DE) ; (PUSH (CVAL HL)) ; (CVAL HL DE) ) ; (PUSH HL) ) ; (WHEN AL ; (BNDT (CAAR AL) (CDAR AL) (CDR AL) ) ) .PAGE ; Cette version a deux defauts: ; * elle ne profite pas de l'information ; "NIL n'est pas un CAR d'une liste de parametre" ; * le nombre de CONS est egale a deux fois le nombre ; d'atomes contenu dans le parametre ; ; La version suivante reduit les CONS a deux fois le nombre de ; sous-listes en utilisant le meme doublet pour une meme ; sous-liste, par modification physique du doublet. ; L'absence de NIL en CAR est utilisee, mais le cas des fonctions ; a zero arguments doit etre traite au prealable. ; (DS BNDA (PAR ARG AL) ; (IF EEXNC ; (PUSH ARG) ; (PUSH (CVAL PAR)) ; (CVAL PAR ARG) ) ; (PUSH PAR) ; (BNDS AL) ) ; ; (DS BNDS (AL) ; (COND ; ((NULL AL)) ; ((ATOM (CAAR AL)) (BNDA (CAAR AL) (CDAR AL) (CDR AL))) ; ((NLISTP (CDAR AL)) (SYSERROR ; 'EVAL ; 'ERWLA ; (LIST (CAAR AL) (CDAR AL)) )) ; ((CDAAR AL) (BNDT (CAAAR AL) ; (CADAR AL) ; (PROG1 AL ; (RPLAC (CAR AL) ; (CDAAR AL) ; (CDDAR AL))))) ; ((CDDAR AL) (SYSERROR 'EVAL 'ERWNA (CDDAR AL))) ; ( T (BNDT (CAAAR AL) ; (CADAR AL) ; (CDR AL))) ) ) .PAGE BNDLE: ; POINT D'ENTREE DES ARGUMENTS DES EXPRS XTHL ; RECUPERE L'ADRESSE DE RETOUR SHLD RDLAMB ; QUI NE PEUT ETRE DANS LA PILE LXI H,NIL ; INITIALISE LA LISTE DES ARBRES SHLD AL XRA A ; A <- 0 INDICATEUR DE LIAISON EN DEUX TEMPS STA EEXNC MOV H,B ; HL <- POINTEUR DE FIN DE BLOC MOV L,C SHLD ENBLO ; RANGE POP H ; ET RECUPERE LE PARAMETRE LISTE ;;; BNDL DOIT SUIVRE BNDL: JLTNN D,BNDLL,ERLHD ; (NLISTP ARG) l'idiot ! BNDLL: .UNCNB ; SEPARE LES PARAMETRES PUSH B ; A TOUT A L'HEURE LE CAR XCHG ; HL <- L'ARG JTNIL D,BNDNL2 ; c'est la fin, on rallonge pas la a-liste .UNCNB ; SEPARE LES ARGS PUSH B ; A TOUT A L'HEURE LE CAR BNDLN: CALL XCONS ; FABRIQUE LA LIAISON XCHG ; POUR UTILISER SHLD LHLD AL ; LA LISTE DES LIAISONS EN ATTENTE CALL XCONS ; RALLONGEE SHLD AL ; VOILA POP D ; LE CAR DES ARGS BNDTP: POP H ; LE CAR DES PARAMS ; BNDT DOIT SUIVRE .PAGE BNDT: JTLST H,BNDL ; LE TRAITEMENT DES ATOMES SUIT BNDA: LDA EEXNC ; TYPE DE LA LIAISON ? ORA A PUSH D ; a priori EXPR sans CONS, suave l'arg JZ BNDAC ; c'etait bien ca POP D ; et non. BNDA0: .XCVAL ; BC <- (CVAL HL) (CVAL HL) <- DE PUSH B ; MEMORISE L'ANCIENNE C-VAL BNDAC: PUSH H ; EMPILE LE NOM ; BNDS DOIT SUIVRE .PAGE BNDS: LHLD AL ; RECUPERE LA LISTE EN ATTENTE JTNIL H,BNDF ; C'EST LA FIN MOV D,M ; DE <- (CAR AL) INR L MOV E,M XCHG ; DE <- AL A 1 PRES .UNCNB ; separe la liaison JTLST B,BNDRP ; ici on ne traite que les atomes XCHG ; DE <- L'ARG, HL <- AL A 1 PRES INR L ; sur le CDR MOV A,M ; on le charge INR L MOV L,M MOV H,A ; le voila SHLD AL ; MEMORISE LE RESTE MOV H,B ; HL <- parametre MOV L,C JMP BNDA ; vers la liaison, car ce n'est jamais NIL .PAGE BNDRP: JLTNN H,BNDRPP,ERLBH ; (NLISTP (CDAR AL)) l'idiot ! BNDRPP: PUSH H ; SAUVE (CDAR AL) : L'ARGUMENT MOV H,B ; POUR S'OCCUPER DE (CAAR AL) MOV L,C ; QUI EST LE PARAMETRE LISTE .UNCNB ; BC <- (CAAAR AL) HL <- (CDAAR AL) XCHG ; DE <- (CDAAR AL) HL <- AL A 1 pres JTNIL D,BNDNIL ; c'est la fin: passe au CDR de AL apres MOV A,M ; on charge (CAR AL) DCR L ; a l'envers MOV H,M ; comme je disais MOV L,A ; tout est pret pour le RPLACA MOV M,D ; (RPLACA (CAR AL) (CDAAR AL)) INR L MOV M,E ; RPLACA EN FINESSE XCHG ; DE <- (CAR AL) OU PRESQUE POP H ; HL <- (CDAR AL) L'ARGUMENT PUSH B ; SAUVE (CAAAR AL) .UNCNB ; BC <- (CADAR AL) HL <- (CDDAR AL) XCHG ; DE <- (CAR AL) A 1 PRES INR L ; POINTE SUR LE POINTEUR CDR MOV M,D ; (RPLACD (CAR AL) (CDDAR AL)) INR L ; RPLACD AUSSI EN FINESSE QUE LE RPLACA MOV M,E ; QUELLE COINCIDENCE MOV D,B ; DE <- (CADAR AL) MOV E,C JMP BNDTP ; VERS LE TEST DE TYPE .PAGE BNDNIL: INR L ; sur le CDR de AL MOV A,M ; on le charge INR L MOV L,M MOV H,A SHLD AL ; pour le coup d'apres POP H ; recupere l'argument du tout PUSH B ; et sauve le parametre BNDNL2: MOV D,M ; prend le car de l'arg INR L MOV E,M INR L ; pointe sur le CDR JFNIL M,ERRTAM ; il reste des args ! JMP BNDTP ; ca repart, sans CONS ! EVERU=. TVERU=EVERU-BVERU .PRINT TVERU .PAGE .SBTTL; Zone P : construction du bloc .=<<.+$FF> ^ > * $0100 ; page suivante BPRCT=. ; TABLE DE CHARGEMENT DE LA FONCTION CSTACK CSTAT2: .ADDR .LOCK .ADDR .PRTCT .ADDR .ESCA .ADDR .BIND .ADDR .FLET .ADDR .LAMB ; FIN DE LA TABLE ; TABLE DE DEBRANCHEMENT DE LA FONCTION CSTACK CSTAT: .BYTE CSTKV & $FF ; BLOC VERROU .BYTE CSTKP & $FF ; BLOC PROTECT .BYTE CSTKT & $FF ; BLOC TAG .BYTE CSTKS & $FF ; BLOC BIND .BYTE CSTKW & $FF ; BLOC WHERE .BYTE CSTKL & $FF ; BLOC LAMBDA ; FIN DE LA TABLE .PAGE ;***** (PROTECT FIRST . END) [SUBR F] ; ; construit un bloc de controle de la forme: ; ; PBIND ----> [ UNBP ] ADRESSE DE DESTRUCTION ; [ OLD-PBIND ] POUR SORTIE EXTRAORDINAIRE ; [ NIL ] echappement absent ; [ END ] FORME A EVALUER TOUJOURS PRTCT: .UNCNS ; DE <- FIRST HL <- END PUSH H ; SAUVE END LXI H,NIL ; l'echappement absent PUSH H ; on le place LHLD PBIND PUSH H ; SAUVE PBIND LXI H,-2 ; POUR POINTER SUR MOT SUIVANT DAD SP ; QUI SERA L'ADRESSE DE RETOUR SHLD PBIND ; NOUVEAU PBIND CALL EVALX ; EVALUE FIRST UNBP: XCHG ; DE <- RESULTAT UNBPE: POP H ; recuper pbind SHLD PBIND ; RESTAURE PBIND POP B ; l'echappement eventuel POP H ; la forme a executer de toutes facons JTNIL B,PRG1X ; pas d'echappement, c'est un PROG1 SHLD FNTEV ; sauve la forme LXI H,PRTEC ; prepare le retour JMP REXIT ; met a jour la pile, et revient ici PRTEC: LHLD FNTEV ; recupere la forme JMP PRG1X ; execute le prog1 .PAGE ;----- TRACE DES BLOCS PAR LA FONCTION CSTACK CSTKT: ; BLOC TAG CSTKV: ; BLOC LOCK CSTKP: ; BLOC PROTECT TRPBBA: ; cas du p-bind avant l'argument XCHG ; HL <- pointe sur premier mot du bloc TRPBBX: MOV E,M ; le charge INX H MOV D,M INX H ; pointe sur le deuxieme INX H INX H ; pointe sur le troisieme XCHG ; DE pointeur sur bloc ; HL faux p-bind JMP BLK1 ; le listifie et mets le nom du bloc devant CSTKS: ; BLOC BIND CSTKW: ; BLOC WHERE CSTKL: ; BLOC LAMBDA TRPB3: ; cas du p-bind en position 3 LXI H,4 ; pointeur de fin de bloc a sauter DAD D ; voila MOV A,M ; charge faux p-bind INX H MOV H,M MOV L,A ;;; BLK1 doit suivre .PAGE ;----- BLK1 : CONSTRUIT LA DESCRIPTION D'UN BLOC POUR CSTACK ; DE pointe sur l'argument du bloc ; BC nom du bloc ; HL nouveau faux p-bind BLK1: XTHL ; sauve faux p-binds PUSH H ; le dernier de laliste par dessus XCHG ; HL pointe sur l'argument MOV E,M ; charge l'argument INX H MOV D,M MOV H,B ; HL <- le nom MOV L,C CALL NEXONS ; reunit les deux POP D ; recupere la fin de la liste en construction CALL PLACP ; accroche le nouveau et le retourne. POP D ; recupere le pointeur POP B ; recupere le nombre CSTAB: DCX B ; un de moins MOV A,B ORA A ; on y est ? RM ; ouaip MOV A,D ; le faux p-bind ORA E ; y a encore des blocs ? RZ ; NAN PUSH B ; sauve le nombre PUSH H ; sauve la liste INX D ; saute poids faible d'appel LDAX D ; charge fort i.e. type SUI UNBVE ^ ; pour commencer a zero ADD A ; 2 octest par objet MOV L,A MVI H,CSTAT ^ ; adresse de la table MOV C,M ; charge le nom du bloc INR L MOV B,M ; rebelotte faible LDAX D ; recharge poids fort d'appel INX D ; c'est toujours ca de fait SUI < UNBVE ^ > - < CSTAT & $FF > ; sur le debut de la table MOV L,A ; pointe dans la table MOV L,M ; un seul octet PCHL ; on y va EPRCT=. TPRCT=EPRCT-BPRCT .PRINT TPRCT .PAGE .SBTTL; Zone T : test de recursivite terminale .=<<.+$FF> ^ > * $0100 ; POUR SE PLACER DANS LA PAGE SUIVANTE BTAG=. ; TABLE DES DEBRANCHEMENTS DU TEST DE RECURSIVITE TERMINALE RTTST: .BYTE TAGT & $FF .BYTE TAGS & $FF .BYTE TAGW & $FF .BYTE TAGL & $FF .BYTE TAGR & $FF ; FIN DE LA TABLE ;! !TEST DE RECURSIVITE TERMINALES DES ECHAPPEMENTS! ; Les blocs tag servent a la fois de declarations et activations ; d'echappement. Le test de recursivite terminale se fait sur ; l'echappement e ncours, etant donne qu'un bloc declarant et ; activant un mem echappement n' a aucun effet. ; la recursivite' croise'e est licite en cas de declarations ; mais pas en cas d'activation. En cas de difference entre ; l'echappement a construire et l'echappement actif donc ; le bloc doit etre construit. .PAGE ;----- L'APPEL PRECEDENT EST UN BLOC PROTECT TAGP: ; bloc PROTECT : test d'echappement different actif INX D ; saute le pbind INX D LDAX D ; charge faible CMP C ; c'est le meme ? INX D ; passe au fort, ca ne change pas Z LDAX D ; charge le fort, et on teste enfin JNZ TAGPS ; nan, mais c'est peut-etre NIL CMP B ; alors RZ ; youpi: c'est le meme qui est actif TAGPS: CPI HNIL ; il y en a un d'actif ? RNZ ; oui, faut construire INX D ;;; TAGR doit suivre ;----- L'APPEL PRECEDENT EST UN BLOC REC-TERM TAGR: ; un mot a sauter INX D INX D JMP RTTSB ; ca roule ;----- L'APPEL PRECEDENT EST UN BLOC LAMBDA, BIND OU WHERE TAGS: TAGW: TAGL: XCHG ; HL <- POINTEUR D <- TABLE INX H ; SAUTE LA F-VAL INX H MOV A,M ; PREND LE POINTEUR DE FIN DE BLOC INX H MOV H,M MOV L,A ; POINTE SU L'APPEL PRECEDENT JMP RTTSX ; CA ROULE .PAGE ;----- L'APPEL PRECEDENT EST UN BLOC TAG TAGT: INX D ; saute p-bind INX D ; voila qui est fait LDAX D ; PRENDS LE FAIBLE NOM CMP C ; COMPARE AU NOM NOUVEAU JNZ TAGTS ; RATE INX D LDAX D ; REBELOTTE FORT CMP B RZ ; YOUPI DCX D LDAX D ; recharge faible actif TAGTS: INX D ; saute faible actif INX D ; saute fort actif XCHG ; pour faire la comparaison CMP M ; il est vraiment actif ? RNZ ; oui, on s'arrete la DCX H ; repointe sur fort actif MOV A,M ; le charge INX H ; repointe sur suivant INX H ; c'est le fort decalre' CMP M ; c'est le meme ? RNZ ; c'est EXIT faut construire INX H ; sur l'appel suivant RTTSX: XCHG ; remet tout en place ;;; RTTSB doit suivre ;----- BOUCLE DE RECHERCHE DANS LA PILE RTTSB: INX D ; SAUTE POIDS FAIBLES LDAX D ; CHARGE SUI UNBT ^ ; PREMIERE ZONE AUTORISEE RC ; C'EST RATE PCHM: INX D ; C'EST TOUJOURS CA DE FAIT MOV L,A ; POIDS FAIBLE DE DEBRANCHEMENT MOV L,M ; CAR H EST TOUT PRET PCHL ; C'EST DANS LA PAGE .PAGE .SBTTL; Zone T : construction du bloc ;***** (UNTILEXIT NAME . BODY) [SUBR F] ;***** (TAG NOM . BODY) [SUBR F] ; PBIND ---> [ UNBT ] ADRESSE DE SORTIE DE CE BLOC ; [ OLD PBIND ] POUR SORTIE EXTRAORDINAIRE ; [ NOM ] l'ecahppement en cours ; [ NOM ] l'echappement declare' UNXIT: LXI B,.UNXIT ; en cas d'erreur LXI D,WILTX ; adresse de la boucle JMP TAGCOM ; et c'est commun ESCAP: LXI B,.ESCA ; EN CAS D'ERREUR LXI D,PROGX ; faudra executer le corps TAGCOM: PUSH D ; sauve l'adresse d'appel CALL VARCAR ; separe et controle MOV B,D ; BC <- le nom MOV C,E ; pour le test de tail-rec PUSH H ; SAUVE LE CORPS LXI H,4 ; POUR POINTER SUR L'APPEL PRECEDENT DAD SP MVI D,RTTST ^ ; ADRESSE DE LA TABLE UNE FOIS POUR TOUTES CALL RTTSX ; TEST DE RECURSIVITE TERMINALE POP D ; recupere le corps RZ ; c'est tout bon, execute l'adresse empile'e POP H ; prend l'adresse PUSH B ; place le nom en tant que declaration PUSH B ; rebelotte, en tant qu'actif MOV B,H ; BC <- l'adresse MOV C,L LHLD PBIND ; SAUVE LE VIEUX PBIND PUSH H ; ca y est LXI H,-2 ; POUR POINTER SUR LE MOT SUIVANT DAD SP ; VOILA SHLD PBIND ; NOUVEAU POINTEUR CALL AP0S ; execute "PUSH B RET" UNBT: XTHL ; sauve resultat et SHLD PBIND ; RESTAURE pbind POP H ; recupere le resultat POP B ; l'echappement actif POP D ; l'echappement declare' MOV A,D CMP B ; c'est le meme que l'actif ? MOV A,E ; pour liberer DE LXI D,XPOPJ ; si c'est pas le meme JNZ REXIX ; c'est pas le meme, vers le relancement CMP C ; rebelotte faible RZ ; il n'y aplus a s'echapper JMP REXIX ; on le relance .PAGE .SBTTL; Zone T : EXIT ;***** (EVEXIT NAME . BODY) [SUBR F] ;***** (EXIT NAME . BODY) [SUBR F] ; l'implantation d'exit est totalement a priori, et non ; a posteriori: la pile est mise a jour pour prevenir ; qu'un echappement a ete demande', et le nom de l'echappement ; est memorise' dans le prochain bloc d'echappement, ; qui le relancera le cas echeant EVXIT: CALL EVARG ; evalue le nom LXI B,.EVXIT ; en cas d'erreur XCHG CALL VARCAP ; controle le nom JMP XITCOM ; et c'est commun NEXIT: LXI B,.EXIT ; en cas d'erreur CALL VARCAR ; separe le nom et le controle XITCOM: MOV B,D ; BC <- le nom de l'echappement MOV C,E LXI D,PROGX ; il faudra executer HL ;;; REXIX doit suivre ;----- REXIT : activation d'un ecahppement ; ; BC = nom de l'echappement ; HL = adresse de retour apres mise a jour de la pile ; DE n'est pas detruit REXIX: XCHG REXIT: SHLD RDLAMB ; range l'adresse de retour XCHG ; 12 - 1000l$$1000t$$ SHLD FONCT ; et son agument LHLD PBIND ; pour pointer sur le dernier bloc JMP EXPANS ; en voiture pour l'expansion .PAGE ;----- boucle d'expansion des blocs EXPANL: INX H ; la forme INX H ; on la saute INX H ; le pointeur de fin de bloc INX H ; on le saute MOV E,M ; charge le pbind INX H ; rebelotte forte MOV D,M DCX H ; revient DCX H ; pointe sur le pointeur de fin du bloc MOV M,D ; pour enblo=pbind DCX H ; rebelotte faible MOV M,E ; voila XCHG ; HL = pbind, donc pointe sur le bloc precedent EXPANS: INX H ; saute poids faibles MOV A,M ; charge fort INX H ; c'est toujours ca de fait SUI UNBS ^ ; c'est un bloc de sauvegarde ? JNC EXPANL ; ouaip , ca roule INX H ; saute le p-bind (cas du bloc d'echappement) INX H ; sur la place reserve'e MOV M,C ; place l'echappement INX H ; rebelotte forte MOV M,B ;;; TRTPS doit suivre .PAGE ;----- boucle de test recursivite' terminale a posteriori TRTPS: LHLD PBIND ; pointe sur le premier bloc TRTPSR: SPHL ; ca ne sera jamais execute, ca POP H ; prend le type du bloc MOV A,H ; dans A SUI UNBS ^ ; c'est un bloc de sauvegarde ? JC EXEXI ; nan POP B ; prend la forme XTHL ; sauve le type, prend le pointeu de fin expanse' MVI D,RSTST ^ ; la table de debranchement CALL RSTSX ; fait le test de recursivite' terminale POP D ; recupere le type du bloc POP H ; p-bind (= enblo) JZ TRTPSR ; ca marche, au suivant PUSH H ; remet p-bind PUSH H ; remet enblo (c'est la meme chose) PUSH B ; remet la forme XCHG ; HL <- type ;;; EXEXI doit suivre EXEXI: PUSH H ; replace le type du bloc LXI H,0 ; recalcule le p-bind DAD SP SHLD PBIND ; voila LHLD FONCT ; recupere l'argument de depart XCHG ; qu'il faut mettre dns DE BNDF: LHLD RDLAMB ; l'adresse de retour PCHL ; on y va ETAG=. TTAG=ETAG-BTAG .PRINT TTAG .PAGE .SBTTL; Zone B : initialisation du bloc .=<<.+$FF> ^ > * $0100 ; PAGE SUIVANTE BBIND=. ;***** (BIND A . BODY) [SUBR F] ; Fonction generale de liaison dynamique ; C'est un LET generalise'. ; Tous les traitements de recursivite terminale sont faits. ; la forme du bloc de controle est la suivante: ; ; PBIND ---> [ UNBS ] adresse de retour ; [ (AL . BODY) ] forme, pour test de rec-term ; ---------------- ] fin de bloc meme raison ; ! [ OLD PBIND ] pour sortie extaordinaire ; ! [ F-VAL 1 ] f-val de la subrv ; ! [ SPECIFICATEUR ] pour les 2SUBRV (nom pour les 1) ; ! [ OLD VAL ] Ll'ancienne valeur a restaurer ; ! [ F-VAL 2 ] rebelotte ; ......................... etc ; ! [ (AL . BODY) ] forme, sert de marqueur ; -------> BINDF: PUSH H ; sauve la forme, pour marqueur et tout et tout MOV A,M ; HL <- (CAR HL) les objets a lieR INR L MOV L,M MOV H,A ; ca y est JMP BINDT ; en voiture .PAGE BINDL: .UNCNS ; separe le premier PUSH H ; sauve les autres XCHG ; HL <- le premier .UNCNS ; separe la var-fonct de ses args XCHG ; DE <- ses args PUSH H ; sauve le nom de la var-fonct INR L ; passe a la f-val INR L INR L INX H ; voila MOV C,M ; prends la f-val INR L MOV B,M ; dans BC INR L ; passe au f-type MOV A,M ; dans A POP H ; le nom CPI SBR1V ; c'est quoi ? JZ BINDE ; ok CPI SBR2V JNZ ERBIND ; n'importe quoi XCHG ; DE <- les args .UNCNS ; on n'evalue pas XCHG ; DE <- fin des args, HL <- specificateur BINDE: XTHL ; recupere le reste, range le specificateur ou le nom PUSH H ; sauve le reste CALL EVBAX ; evalue l'arg en sauvant BC XTHL ; range la valeur et recupere la suite PUSH B ; range la f-val BINDT: JTLST H,BINDL ; ca roule LXI H,0 ; prepare la descente dans la pile DAD SP ; pointe sur le dernier mot empile' PUSH H ; meilleur que JUMP ;;; BIND2S doit suivre BIND2S: POP H ; recupere le point de parcours BIND2T: MOV C,M ; au suivant INX H MOV B,M INX H ; tout est pret JTLST B,BIND2F ; c'est la forme, c'est fini BIND2L: PUSH B ; resauve f-val (car c'est long de la prendre) PUSH H ; sauve le pointeur de parcours INX H ; saute la valeur INX H ; car on n'en est qu'au GET MOV A,M ; prend le specificateur (pour 2subrv) INX H MOV H,M MOV L,A ; voila LXI D,BIND2G ; prepare le retour PUSH D ; voila PUSH B ; le get RET ; on y va, et on revient ici .PAGE BIND2G: XCHG ; DE <- la valeur a sauvegarder POP H ; restaure le point de parcours MOV C,M ; echange les valeurs MOV M,E INX H ; rebelotte faible MOV B,M MOV M,D ; voila INX H ; pointe sur le specificateur (2subrv) MOV E,M ; on le charge INX H MOV D,M INX H ; pointe sur le suivant XTHL ; recupere la f-val, sauve le parcours PUSH B ; fait de la place (new val) DCX H ; prend l'adresse du set MOV B,M DCX H MOV C,M LXI H,BIND2S ; prepare le retour XTHL ; voila, et recupere new val PUSH B ; le set RET ; on l'execute et ca repart .PAGE .SBTTL; Zone B : lancement du corps BIND2F: PUSH H ; sauve la fon du bloc MVI D,RSTST ^ ; la table CALL RSTSX ; fait le test de tail recursion MOV D,B ; DE <- la forme MOV E,C JZ SYPTR ; chouette ! LHLD PBIND ; vieux pbind XTHL ; le sauve et recupere pointeur de fin de bloc PUSH H ; le sauve PUSH D ; sauve la forme LXI H,-2 ; pour pointer apres DAD SP SHLD PBIND ; new pbind CALL PROGDX ; on evalue le corps UNBS: UNBSE: SHLD VESCA ; le resultat POP H ; forme on s'en fout POP H ; fin de bloc SHLD ENBLO ; ca sert en cas d'echappement POP H ; le p-bind SHLD PBIND ; on le restaure ; en voiture pour les deliaisons UNBSET: LHLD VESCA ; reprend le resultat XCHG ; dans DE POP H ; suivant JTLST H,UNBG ; c'est la fin UNBSEL: DCX H ; prend le set MOV B,M DCX H MOV C,M LXI H,UNBSET ; l'adresse de retour POP D ; la valeur a restaurer XTHL ; le specificateur (pour les subr2v) XCHG ; tous en place PUSH B ; le set RET ; en fait call ;----- RECURSIVITE TERMINALE : il n'y a plus qu'a ecraser le bloc SYPTR: POP H ; recupere le pointeur de fin de bloc SPHL ; et ecrase tout ! JMP PROGDX ; et jumpe ! .PAGE ;----- BINDI1 : liaison dynamique d'une variable fonction interne ; ; ce module est utilise' actuellement par: ; TRACEVAL ITEVAL IMPLODE EXPLODE ; pour toutes ces fonctions, il faut positionner l'indicateur a 1 ; pour indiquer qu'elles sont en activite', ; et restaurer l'ancienne valeur de l'indicateur, ; meme en cas d'echappement. ; On construit donc un bloc BIND interne, de forme "SYSTEM" ; memorisant la valeur de l'indicateur et son adresse. ; ; HL = adresse de retour ; DE a mettre dans HL avant le retour ; BC = adresse de l'indicateur BINDI1: SHLD A4 ; fait de la place LXI H,$FFFF ; marqueur de fin de bloc PUSH H ; en bonne place LDAX B ; prend la valeur actuelle de l'indicateur CALL CRANA ; l'interne dans HL MVI A,1 ; positionne l'indicateur a "actif" STAX B ; voila PUSH H ; sauve la valeur a restaurer PUSH B ; sauve l'adresse de l'indicateur LXI B,IDNIB1 ; l'adresse de la routine de restauration PUSH B ; c'est un 'set' interne LHLD PBIND ; le bloc precedent PUSH H LXI H,10 ; taille du bloc DAD SP ; donc adresse de fin de bloc PUSH H ; en bonne place LXI H,.SYS ; le nom = la forme PUSH H LXI H,UNBS ; simule l'appel apartir de la zone S PUSH H LXI H,0 DAD SP SHLD PBIND ; nouveau pbind LHLD A4 ; recupere le troisieme arg PUSH H ; pour simuler un JMP XCHG ; HL <- l'arg .IFNE ITEVAL LXI B,.EVLIT ; pour CEVLIT seulement, la fonction .ENDC ; de ITEVAL RET ; don cJMP .ADDR IDNIB1 IDNIB1: ; le 'set' interne pour BINDI1 MOV M,E ; restaure l'indicateur RET ; et c'est tout EBIND=. TBIND=EBIND-BBIND .PRINT TBIND .PAGE .SBTTL; Zone W : test de recursivite terminale pour les blos de sauvegarde .=<<.+$FF> ^ > * $0100 ; PAGE SUIVANTE BWHER=. ; TABLE DE DEBRANCHEMENTS DU TEST DE RECURSIVITE TERMINALE RSTST: .BYTE SYPT & $FF .BYTE SYPS & $FF .BYTE SYPW & $FF .BYTE SYPL & $FF .BYTE SYPR & $FF ; FIN DE LA TABLE .PAGE ;----- L'APPEL PRECEDENT EST UN BLOC TAG SYPT: ; TAG : 3 mots a sauter INX D INX D INX D INX D ;;; SYPR DOIT SUIVRE ;----- L'APPEL PRECEDENT EST UN BLOC REC-TERM SYPR: ; 1 mot a sauter INX D INX D JMP RSTSB ; ca tourne ;----- L'APPEL PRECEDENT EST UN BLOC DE SAUVEGARDE SYPL: ; bloc lambda SYPW: ; bloc flet SYPS: ; bloc bind LDAX D ; prends la forme faible INX D ; pour etre synchrone CMP C ; compare avec l'actuelle JNZ SYPLS ; rate, mais on continue LDAX D ; charge CMP B RZ ; youpi ! SYPLS: INX D ; saute la fin de la forme XCHG ; HL <- pointeur, D <- table forte MOV A,M ; le pointeur de fin de bloc INX H MOV H,M MOV L,A ; sur l'appel precedent RSTSX: XCHG ; remet en place ;;; RSTSB doit suivre ;----- BOUCLE DE RECHERCHE DANS LA PILE RSTSB: INX D ; saute poids faibles LDAX D SUI UNBT ^ ; premiere zone autorisee RC ; c'est rate' INX D ; saute poids fort, c'est toujours ca de ffait MOV L,A ; prend l'index MOV L,M ; cahrge la table, car H est tout pre^t PCHL ; et on y va .PAGE .SBTTL; Zone W : initialisation du bloc ;***** (FLET AL . BODY) [SUBR F] ; Construit un bloc de controle de forme: ; ; PBIND ---> [ UNBW ] ADRESSE DE RETOUR ; [ (AL . BODY) ] POUR ENVIRRONEMENT PERIME ; ----------------- ] FIN DE BLOC, MEME RAISON ; ! [ OLD PBIND ] POUR SORTIE EXTRAORDINAIRE ; ! [ NOM 1 ] PREMIER PARAMETRE ; ! [ FVAL 1 ] SON ANCIENNE F-VAL ; ! [ FTYPE 1 ] SON ANCIEN FTYPE ; . ............ ETC ; ! [ $FFFF ] MARQUEUR ; -------> WHERE: SHLD FONCT ; sauve la forme MOV B,H ; et dans BC pour le tset MOV C,L MOV D,M ; DE <- a-liste INR L MOV E,M PUSH D ; sauve la a-liste LXI H,2 ; saute a-liste pour le calcul de fin de bloc DAD SP SHLD ENBLO ; MEMORISE LA FIN DU BLOC MVI D,RSTST ^ ; c'est a table CALL RSTSX ; fais le test de tail-rec JZ SBNDWT ; youpi, c'est iteratif LXI H,$FFFF ; le marqueur XTHL ; le place et recupere a-liste JMP WHERT ; en voiture pour les liaisons, en zone W .PAGE ;---- recursivite terminale : fais les liaisons, et BC contient la forme SBNDWL: .UNCNS ; DE <- LIAISON HL <- RESTE PUSH H ; FAIT DE LA PLACE XCHG ; HL <- LIAISON .UNCNS ; DE <- NOM HL <- F-VAL XCHG INR L INR L INR L INX H ; HL POINTE SUR LA F-VAL MOV M,E ; UN DEFEXPR EXPEDITIF ! INR L MOV M,D INR L MVI M,14 ; LE F-TYPE DES EXPRS SBNDWT: POP H ; AU SUIVANT JTLST H,SBNDWL ; S'IL EN RESTE MOV H,B ; HL <- la forme MOV L,C JMP PROGD ; on l'execute .PAGE WHERL: .UNCNS ; HL <- RESTE DE A-LISTE, DE <- LIAISON PUSH H ; FAIT DE LA PLACE XCHG ; HL <- LIAISON .UNCNB ; BC <- NOM HL <- FVAL XCHG ; DE <- F-VAL LXI H,4 ; OFFSET F-VAL DAD B ; VOILA QUI EST FAIT MOV A,M ; CHARGE OLD FAIBLE F-VAL MOV M,E ; NEW FAIBLE MOV E,A ; OLD INR L ; REBELOTTE FORTE MOV A,M MOV M,D MOV D,A ; DE <- OLD F-VAL INR L ; PASSE AU FTYPE MOV A,M ; OLD F-TYPE MVI M,14 ; NEW F-TYPE = EXPR TOUJOURS CALL CRANA ; INTERNONS L'ANCIEN XTHL ; LE SAUVE ET RECUPERE LA A-LISTE PUSH D ; SAUVE OLD F-VAL PUSH B ; SAUVE LE NOM INTACT WHERT: JTLST H,WHERL ; AU SUIVANT S'IL EN RESTE .PAGE LHLD PBIND ; TERMINONS LA CONSTRUCTION DU BLOC PUSH H ; SAUVE PBIND (SANS BLAGUE) LHLD ENBLO ; POINTEUR DE FIN DE BLOC PUSH H ; CA RESSEMBLE BEAUCOUP AUX LAMBDA LHLD FONCT ; FORME ; 13 - 1000l$$1000t PUSH H ; OUF C'EST LE DERNIER XCHG ; DANS DE LXI H,-2 ; POUR POINTER SUR L'ADRESSE DE RETOUR DAD SP ; J'AI DEJA VU CA QUELQUE PART SHLD PBIND ; BON SANG MAIS C'EST BIEN SUR CALL PROGDX ; JE L'AURAIS PARIE UNBW: XCHG ; DE <- LE RESULTAT UNBWE: POP H ; FORME ON S'EN FOUT POP H ; le fin de bloc SHLD ENBLO ; ca sert pour les echappements terminaux POP H ; le p-bind SHLD PBIND ; C'EST BIEN PARCE QUE C'EST LUI JMP UNBWT ; EN VOITURE POUR LES DELIAISONS UNBWL: LXI H,4 ; OFFSET F-VAL DAD B ; VOILA QUI EST FAIT POP B ; OLD F-VAL MOV M,C ; RESTAURE FAIBLE INR L MOV M,B ; RESTAURE FORTE POP B ; LE F-TYPE INR L ; ON POINTE DESSUS MOV M,C ; RESTAURE UNBWT: POP B ; AU SUIVANT MOV A,B ; S'IL EN RESTE INR A ; C'EST LE MARQUEUR ? JNZ UNBWL ; NAN, CONTINUE A DELIER LHLD ENBLO ; recupere le pointeur de fin de bloc SPHL ; ca sert dans le cas d'un echappement XCHG ; remets le resultat RET ; et voila EWHER=. TWHER=EWHER-BWHER .PRINT TWHER .PAGE .SBTTL; Zone L : Letrec .=<<.+$FF> ^ > * $0100 ; POUR SE POSITIONNER A LA PAGE SUIVANTE BLAMB=. ;***** (LETREC AL . BODY) [SUBR F] ; (DF LETREC (AL . BODY) ; (ENV (MAPCAR (LAMBDA (X) (CONS (CAR X) (CONS NIL NIL))) AL) ; (MAPC (LAMBDA (Y) (DISPLACE (CAAR Y) (EVAL (CADR Y)))) AL) ; (EPROGN BODY) ) ) ; Un situation un peu speciale ici: entre la modification des c-vals ; et l'evaluation du corps, se placent plusieurs appels a EVAL. ; Si un EXIT a lieu durant ces evaluations, les deliaisons doivent ; etre faites, bien que l'adresse de retour ne soit pas UNBL. ; On procede donc ainsi: entiere construction du bloc apres ; l'initialisation des parametres, puis evaluations des arguments ; au moyen d'un sous-programme en zone F, mais ; en empilant quand meme l'adresse UNBL, qui sera depilee ; si aucun echappement ne se pduit. Sinon la fonction EXIT ; ne fera pas ainsi de difference entre ce bloc et le bloc normal ; et les tests de recursivites terminales seront stoppes par ; l'adresse en zone F. ; Lorsque tous les arguments sont evalues, il y a un branchement ; a l'appel normal de ce bloc. ; D'autre part il faut tester tout de suite l'indicateur d'enveloppe, ; sinon il faudrait l'interner et le sauver. LETREC: CALL TVPALL ; TEST D'ENVIRONNEMENT PERIME ET INITIALISATIONS PUSH H ; a priori pas terminal, place l'appeleante JNZ LETRT ; c'est bien ca, vers les liaisons LXI H,PROGD ; a priori c'est pas enveloppe' XTHL ; il faudra alors executer le corps ORA A ; tes l'enveloppe JNZ SLTRCT ; c'est ca. fais les liaisons pusi executera LXI H,BNDR ; enveloppe': faut construire unbloc R XTHL ; le retour est pret JMP SLTRCT ; mem chose .PAGE ;----- recursivite' terminale : affecte directement les valeurs SLTRCL: PUSH D ; SAUVE LA A-LISTE CALL NCNSN ; FABRIQUE LE DOUBLET D'INITIALISATION MOV B,H ; DANS BC MOV C,L POP H ; RECUPERE LA A-LISTE .UNCNS ; SEPARE LES LIAISONS XCHG ; DE <- LE RESTE HL <- LIAISON MOV A,M ; PREND LE NOM INR L MOV L,M MOV H,A ; DANS HL MOV M,B ; FORCE LA C-VAL INR L MOV M,C SLTRCT: JTLST D,SLTRCL ; Y EN A ENCORE LHLD FONCT ; RECUPERE LA FORME PUSH H ; POUR LA RETROUVER MOV A,M ; PREND LA A-LISTE INR L MOV L,M MOV H,A ; ET VOILA CALL LETR2T ; AFFECTE LES VRAIES VALEURS POP H ; LA FORME RET ; ET VOILA .PAGE LETRL: PUSH D ; SAUVE LA A-LISTE CALL NCNSN ; DOUBLET D'INITIALISATION MOV B,H ; DANC BC MOV C,L POP H ; RECUPERE LA A-LISTE .UNCNS ; AU SUIVANT XCHG ; HL <- COUPLE (NOM FORME A EVALUER) MOV A,M ; PREND LE NOM INR L ; LA FORME C'EST AU COUP SUIVANT MOV L,M MOV H,A ; HL <- LE NOM MOV A,M ; ECHANGE DES C-VALS MOV M,B MOV B,A ; C'ETAIT LES POIDS FORTS INR L ; AUX POIDS FAIBLES MOV A,M MOV M,C MOV C,A ; BC <- OLD C-VAL DCR L ; HL <- LE NOM PUSH B ; SAUVE L'ANCIENNE C-VAL PUSH H ; ET LE NOM LETRT: JTLST D,LETRL ; CA REPART LHLD PBIND ; CONSTRUISONS LA FIN DU BLOC PUSH H ; ET D'UN LHLD ENBLO ; LE POINTEUR DE FIN DE BLOC PUSH H ; ET DE DEUX LHLD FONCT ; LA FORME PUSH H ; ET DE TROIS MOV D,M ; DE NOUVEAU LA A-LISTE INR L MOV E,M ; DANS DE LXI H,UNBL ; en cas d'echappement PUSH H ; tout est pret LXI H,0 ; CALCUL DU NOUVEAU PBIND DAD SP ; QUI POINTE SUR BUNBL SHLD PBIND ; ET VOILA XCHG ; HL <- A-LISTE CALL LETR2T ; EN VOITURE C'EST COMMUN AU CAS ITERATIF POP PSW ; enleve la fausse adresse POP D ; RECUPERE LA FORME JMP BUNBL ; ET L'EXECUTE DEVANT LE MODULE DE DESTRUCTION .PAGE ;----- ETABLISSEMENTS DES CIRCULARITES DANS LETREC LETR2L: .UNCNS ; SEPARE LA A-LISTE PUSH H ; SAUVE LA SUITE CALL EVSETX ; DE <- (CVAL (CAR DE)) HL <- (EVAL (CADR DE)) JFLST H,LETERR ; CA DOIT ETRE UNE LISTE .RPLCB ; (RPLACB DE HL) CREE UNE LISTE CIRCULAIRE,SUR POP H ; AU SUIVANT LETR2T: JTLST H,LETR2L ; S'IL EN RESTE RET .PAGE .SBTTL; Zone L : construction du bloc ;----- FIN DE CONSTRUCTION D'UN BLOC LAMBDA ; DE = LA FONCTION ; BC = POINTEUR SUR L'APPEL PRECEDENT ; ; LA PREMIERE PHASE DE CONSTRUCTION ETAIT ASSURE PAR BND1 ; LA DEUXIEME PAR DNB1 ; OU ALORS EN UNE SEULE FOIS PAR BND. ; ON PROCEDE MAINTENANT AUX EMPILEMENTS PERMETTANT LE TRAITEMENT ; DES ECHAPPEMENTS ET DES ENVIRONNEMENT PERIMES ; la forme du bloc de controle construit est la suivante: ; ; PBIND ---> [ UNBL ] ADRESSE DE DESTRUCTION DU BLOC ; [ F-VAL ] POUR TEST ENV. PERIMES ; ----------------- ] FIN DE BLOC, MEME RAISON ; ! [ OLD PBIND ] POUR SORTIE EXTRAORDINAIRE ; ! [ NOM 1 ] PREMIER PARAMETRE ; ! [ VAL 1 ] PREMIERE VALEUR ; . ........... ETC ; ! [ APPELANTE ] POUR SELF ET SERT DE MARQUEUR ; -------> .PAGE FEXF: ; FIN DES FEXPR ET ASSIMILEES LHLD SELFM ; RECUPERE LA FONCTION LETF: ; FIN DES LETS XCHG ; DE <- LA FONCTION LHLD ENBLO ; RECUPERE LE POINTEUR DE FIN DE BLOC MOV B,H ; DOIT ETRE DANS BC MOV C,L DNB1VX: ; FIN DES EXPRS LHLD PBIND PUSH H ; SAUVE PBIND PUSH B ; SAUVE LE POINTEUR DE FIN DE BLOC LXI H,-4 ; POUR POINTER SUR LES DEUX PROCHAINS MOTS DAD SP SHLD PBIND ; NOUVEAU PBIND BUNBL: ; POINT D'ENTREE DE LETREC PUSH D ; SAUVE LA FORME CALL PROGDX ; ET L'EVALUE ; UNBL DOIT SUIVRE UNBL: XCHG ; DE <- LE RESULTAT UNBLE: POP H ; DEPILE LA F-VAL POP H ; le pointeur de fin de bloc SHLD ENBLO ; pour les echappements POP H ; DEPILE PBIND SHLD PBIND ; ET LE RESTAURE JMP UNBLF ; EN VOITURE UNBLB: POP B ; VALEUR SUIVANTE MOV M,B ; RESTAURE C-VAL INR L MOV M,C UNBLF: POP H ; AU NOM SUIVANT JFLST H,UNBLB ; C'EST UN NOM, CONTINUONS SHLD SELFM ; RESTAURE LA FONCTION EN COURS UNBG: ; fin de destruction d'un bloc de sauvegarde LHLD ENBLO ; le fin de bloc SPHL ; ca sert pour les echappements XCHG ; remet le resultat RET ; et voila .PAGE .SBTTL; Zone L : test de recursivite's terminales pour a-listes ;----- TVPALL : appel du test de recursivite terminale ; pour ENVQ et LETREC ; A L'ENTREE : ; HL = FORME ; AU RETOUR: ; BC = FORME ; DE = A-LISTE ; HL = SELFM i.e. fonction appelante ; FONCT = FORME ; ENBLO = POINTEUR DE FIN DE BLOC (= SP) ; A = INDICATEUR D'ENVELOPPE ; Z = INDICATEUR DE RECURSIVITE TERMINALE TVPALL: SHLD FONCT ; sauve la forme MOV B,H ; et dans BC pour le tset MOV C,L MOV D,M ; DE <- a-liste INR L MOV E,M PUSH D ; sauve la a-liste LXI H,4 ; SAUTE A-LISTE ET APPEL DE TVPAL DAD SP SHLD ENBLO ; MEMORISE LA FIN DU BLOC XCHG ; le met dans DE MVI H,3 ; indic d'enveloppe CALL TENVPE ; EXECUTE LE TEST MOV A,H ; A <- l'indicateur d'enveloppe POP D ; RECUPERE LA A-LISTE LHLD SELFM ; la fonction appelante RET ; RETOUR AVEC Z POSITIONNE ET D INDICATEUR ELAMB=. TLAMB=ELAMB-BLAMB .PRINT TLAMB .PAGE .SBTTL; Zone R : test de recursivite terminale des Lambda .=<<. + $FF > ^ > * $0100 ; PAGE SUIVANTE BRECT=. ; TABLE DES DEBRANCHEMENT SUR TYPE D'APPEL PRECEDENT ENVPT: ; .REPT <<< $FF + EEXPR > - BEXPR > ^ > .BYTE ENVE & $FF .BYTE ENVE & $FF ; .ENDM ; .REPT <<< $FF + ESBRN > - BSBRN > ^ > .BYTE ENVN & $FF .BYTE ENVN & $FF ; .ENDM ; .REPT <<< $FF + ESBRM > - BSBRM > ^ > .BYTE ENVM & $FF .BYTE ENVM & $FF .BYTE ENVM & $FF ; .ENDM ; .REPT <<< $FF + ESBR3 > - BSBR3 > ^ > .BYTE ENV3 & $FF .BYTE ENV3 & $FF ; .ENDM ; .REPT <<< $FF + ESBR2 > - BSBR2 > ^ > .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF .BYTE ENV2 & $FF ; .ENDM ; .REPT <<< $FF + ESBR1 > - BSBR1 > ^ > .BYTE ENV1 & $FF .BYTE ENV1 & $FF .BYTE ENV1 & $FF .BYTE ENV1 & $FF ; .ENDM .BYTE ENVV & $FF .BYTE ENVV & $FF .BYTE ENVP & $FF .BYTE ENVT & $FF .BYTE ENVT & $FF .BYTE ENVS & $FF .BYTE ENVS & $FF .BYTE ENVW & $FF .BYTE ENVW & $FF .BYTE ENVL & $FF .BYTE ENVL & $FF .BYTE ENVR & $FF .BYTE ENVR & $FF ; FIN DE LA TABLE DES DEBRANCHEMENTS SUR L'APPEL PRECEDENT .PAGE ;----- TEST D'ENVIRONNEMENT PERIME ; ; DE = POINTEUR SOUS LE BLOC DE CONTROLE EN QUESTION ; BC = LA FONCTION DE CE MEME BLOC ; H = 3 initialisation du type de recursion terminale ; ; au retour: ; Z = 0 si ce n'est pas une recursivite terminale ; Z = 1 sinon et: ; H = 4 si une seule enveloppe et de type MSUBR ; H = 3 si recursivite directe (ni bloc ni enveloppe) ; H = 1 si recursivite croisee avec S,T,W,L,R ; H = 0 si enveloppe(s) differente(s) ; le petit nombre de registre du 8080 et l'absence ; d'instructions d'affectation sur bit conduit a une ; gestion pour le moins opaque de l'indicateur de type ; Les effets des instructions sur l'indicateur de type sont: ; ; MSUBR : le met a 1 si premier passage (i.e. = 3) ; le met a 0 sinon ; SUBR : le met a 0 systematiquement ; BLOC : le met a 1 si que des blocs ont ete rencontre (1 ou 3) ; le met a 0 sinon .PAGE ;! ! CAS DES ENVELOPPES ! ;----- L'APPEL PRECEDENT EST UNE SUBR A 1,2 OU 3 ARGUMENTS ENV3: INX D ; 2 MOTS A SAUTER INX D ENV2: INX D ; 1 MOT A SAUTER INX D ENV1: XRA A ; A <- 0, de toutes facons il faudra empiler JMP TENVPA ; CA ROULE ;----- L'APPEL PRECEDENT EST UNE NSUBR ENVN: ; NSUBR non associatives XRA A ; indic d'enveloppe ENVM: ; NSUBR associatives ADD A ; 4 -> 8 3 -> 6 1 -> 2 0 -> 0 ANI 4 ; 0 4 0 0 XCHG ; HL pointe sur le pointeur MOV E,M ; on le prend INX H MOV D,M ; et ca pointe sur l'appel precedent JMP TENVPA ; ca repart ;----- L'APPEL PRECEDENT EST UNE EXPR ENVE: XCHG ; HL POINTE SUR LE POINTEUR ! MOV E,M ; on le prend INX H MOV D,M LDAX D ; prend la faible fonction CMP C ; COMPARE LES FAIBLES RNZ ; L'ENVELOPPE N'EST PAS LA MEME INX D ; passe a la forte LDAX D ; la voila CMP B RNZ INX D ; SAUTE LA FONCTION XRA A ; pour qu'il y ait construction JMP TENVPA ; C'EST REPARTI .PAGE ;! ! CAS DES ITERATIVES ! ;----- L'APPEL PRECEDENT EST UN BLOC D'ECHAPPEMENT ENVT: ; BLOC TAG : 3 MOTS LXI H,6 DAD D XCHG ; HL POINTE SUR L'APPEL PRECEDENT JMP TENVP1 ; ca roule ENVP: ; BLOC PROTECT : INTERDIT ENVV: ; BLOC VERROU : INTERDIT RET ; RETOUR AVEC Z = 0 ;----- L'APPEL PRECEDENT EST UN BLOC REC-TERM ENVR: MOV H,A ; prend l'indicateur LDAX D ; charge faible fonction INX D CMP C ; PREMIER ESSAI JNZ ENVRS ; RATE LDAX D ; au fort CMP B ; ALORS ? RZ ; YOUPI C'EST PERIME !! ET PROBABLEMENT ENVELOPPE ENVRS: MOV A,H ; reprends l'indicateur INX D ; saute forme JMP TENVP1 ; CA ROULE .PAGE ;----- L'APPEL PRECEDENT EST UNE LAMBDA, SYS-PROTECT OU WHERE ENVS: ENVW: ENVL: MOV H,A ; REMETS L'INDICATEUR LDAX D ; charge faible forme INX D ; POUR ETRE SYNCHRONE CMP C ; PREMIER ESSAI JNZ ENVLS ; TOUT N'EST PAS PERDU LDAX D ; rebelotte faible CMP B ; DEUXIEME ESSAI RZ ; YOUPI ! ! ! ! ! ! ! ! C'EST PERIME ! ! ! ENVLS: MOV A,H ; cf moins haut INX D ; SAUTE F-VAL FORTE XCHG ; sur le pointeur de fin bloc MOV E,M ; on le prend INX H MOV D,M TENVP1: ANI 1 ; 4 -> 0 3 -> 1 1 -> 1 0 -> 0 TENVPA: MOV H,A ; range l'indicateur d'enveloppe ;; TENVPE DOIT SUIVRE ;----- BOUCLE DE RECHERCHE DANS LA PILE TENVPE: INX D ; SAUTE LES POIDS FAIBLES LDAX D ; fort SUI BEXPR ^ ; PREMIERE ZONE AUTORISEE RC ; PAS TERMINAL RETOUR AVEC Z = 0 INX D ; C'EST TOUJOURS CA DE FAIT ET Z INCHANGE MOV L,A ; POIDS FORT D'APPEL = POIDS FAIBLES DE TABLE MOV A,H ; LIBERE H MVI H,ENVPT ^ ; ADRESSE FORTE DE LA TABLE MOV L,M ; DEBRANCHEMENT FAIBLE PCHL ; ON Y VA AVEC DE = POINTEUR A = INDIC .PAGE .SBTTL; Zone R : APPLY et FEXPRS rec-term ;----- ETABLISSEMENTS DES LIAISONS DANS APPLY OU FEXPR REC-TERM ; situation particulierement efficace: ; non seulement on change directement les c-vals, sans echange ; mais en plus cela libere la pile pour la gestion des parametres ; non atomiques! ; (DS APTR (HL DE) ; (PUSH $FFFF) ; (LET ((HL HL) (DE DE)) ; (IF (CONSP HL) ; (IFN (LISTP DE) ; (SYSERROR 'EVAL "argument atomique pour" HL) ; (PUSH (CAR HL)) ; (PUSH (CAR DE)) ; (SELF (CDR HL) (CDR DE)) ) ; (IF HL ; (CVAL HL DE) ; (WHEN DE ; (SYSERROR 'EVAL "Trop d'arguments" DE)) ) ; (POP DE) ; (WHEN (NEQ DE $FFFF) ; (POP HL) ; (SELF HL DE) ) ) ) ) SAPTR: MOV L,H ; INDIC D'ENVELOPPE MVI H,$FF ; FABRIQUE UN POINTEUR XTHL ; INDIQUERA LA FIN DES LIAISONS XCHG ; DE <- LES ARGS LDAX B ; A <- FORT PARAMETRE MOV H,A ; DANS HL INR C LDAX B ; REBELOTTE FAIBLE MOV L,A ; HL = LES PARAMETRES JMP APTRT ; VERS TEST DE TYPE DU PARAMETRE .PAGE APTRL: .UNCNB ; BC <- (CAR PARAM) HL <- (CDR PARAM) PUSH B ; ON S'EN OCCUPERA PLUS TARD JFNIL D,APTRLL ; L'ARGUMENT PEUT ETRE NIL CPI HLIST ; ca doit etre une liste JC APTRA ; le fou ! APTRLL: XCHG ; MEME CHOSE POUR LES ARGS .UNCNB PUSH B XCHG ; HL <- LES PARAM, DE <- LES ARGS APTRT: JLTNL H,APTRL,APTRN ; LE TRAITEMENT DES ATOMES SUIT MOV M,D ; UN RPLACA D'UNE RARE FINESSE INR L MOV M,E APTRS: POP D ; AU SUIVANT POP H ; PARAMETRES OU BIEN FONCTION MOV A,D ; S'IL EN RESTE INR A ; VOYONS VOIR JNZ APTRT ; IL EN RESTE MOV A,E ; A <- INDIC D'ENVELOPPE JMP BNDRS ; VERS LES TEST D'ENVELOPPE APTRN: JTNIL D,APTRS ; TEST DES ARGUMENTS EN TROP JMP ERRTA ; VERS L'IMPRESSION DE L'ERREUR .PAGE .SBTTL; Zone R : liaisons envq/env SLTQL: .UNCNS ; AVANCE DANS LA A-LISTE XCHG ; HL <- LIAISON SUIVANTE DE <- RESTE .UNCNB ; BC <- NOM HL <- VAL MOV A,H ; [jer] .UNCNB ne le fait plus STAX B ; force la c-val (H=A apres UNCNB) INR C MOV A,L STAX B ; REBELOTTE SLTQT: XCHG ; HL <- RESTE DE LA A-LISTE JTLST H,SLTQL ; Y EN A ENCORE ALVPF: LHLD FONCT ; RECUPERE LA FORME POP PSW ; RECUPERE L'INDICATEUR JMP BNDRT ; VERS LE TEST .PAGE .SBTTL; Zone R : liaisons des exprs SBNDL: POP B ; VALEUR SUIVANTE MOV M,B ; RPLACA EN FINESS INR L MOV M,C SBND: POP H ; NOM SUIVANT JFLST H,SBNDL ; C'EST PAS LA FONCTION MOV A,D ; l'indicateur d'enveloppe ;;; BNDRS DOIT SUIVRE ;----- TEST D'ENVELOPPE ; HL = FONCTION ; A = INDICATEUR D'ENVELOPPE BNDRS: ; ENTREE D'APPLY ET FEXPR SHLD SELFM ; FONCTION EN COURS, L'AUTRE C'EST FINI ;;; BNDRT DOIT SUIVRE BNDRT: ; ENTREE DU TEST D'ENVELOPPE ORA A JNZ PROGD ; ITERATION TOTALE ! ;;; BNDR DOIT SUIVRE ;----- BNDR : CONSTRUCTION D'UN BLOC POUR ENVELOPPEES ; HL = FONCTION ; ; ce bloc n'est utile que pour les tests de recursivite' terminale ; le PBIND ne pointe jamais sur de tels blocs, ; car ils ne sont d'aucune utilite' pour les restaurations. ; cette zone s'apparente donc plus a la zone E, ; qu'aux zones des uatres blocs. ; Seule la fonction est empile'e BNDR: PUSH H ; place la forme, pour les tests CALL PROGD ; execute le cdr UNBR: POP PSW ; la fonction on s'en tape RET ; ET C'EST TOUT ERECT=. TRECT=ERECT-BRECT .PRINT TRECT .PAGE ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;!! !! ;!! ATTENTION !! ;!! !! ;!! IL NE DOIT PLUS Y AVOIR !! ;!! D'APPEL DIRECT A EVAL !! ;!! AU DELA DE CETTE ZONE !! ;!! !! ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ;*********************************************************** ;***** Fin du code (qui peut se trouver en ROM) ****** ;*********************************************************** CODEE=. ; fin du code CODES=CODEE-CODEB ; taille du code ROM .PRINT CODES ; taille du code .IFEQ ROM ; si code en ROM .ENDC .PAGE .SBTTL; Zone d'initialisation : NIL et constantes litterales ; ZONE D'INITIALISATION DE NIL .IFNE ROM .=. ; le transfert se fera ! .IFF .=NIL ; le transfert sera donc ineffectif ! .ENDC ; [jer] .MKLS=. G100: ZBNIL: .ADDR .NIL,.NIL .ADDR 0,0,0 .BYTE 3 .ASCII 'nil ' ZENIL=. ;----- Debut de la zone des litteraux a copier .IFNE ROM .=. .IFF .=<<. + $100> & $FF00> - 64 - 8 ; ! cette formule se retrouve en BATOM= ... .ENDC IMEMS=. IMEM=BATOM - . ; MODIFICATION D'INSTRUCTIONS IN 0 ; CF: LA FONCTION IN. JMP CRANA ; INTERNE LA DATA LUE. OUT 0 ; CF: LA FONCTION OUT. RET ; ET C'EST TOUT. .PAGE ; TABLE DES CARACTERES .ADDR $8508,$8888 ; MACRO-CAR: ^C .ADDR $4444,$4443 ; 08 BSP TAB LF VT FF RC SI SO .ADDR $8888,$8888 ; 10 ^P ... ^W .ADDR $0888,$8888 ; 18 ^X ^Y ^Z ... .ADDR $874C,$5588 ; 20 SP ! " # $ % & ' .ADDR $88AB,$9188 ; 28 ( ) * + , - . / .ADDR $8888,$8888 ; 30 0 ... 7 .ADDR $8288,$8888 ; 38 8 9; < = > ? .ADDR $8888,$8888 ; 40 @ A B C ... G .ADDR $8888,$8888 ; 48 H I ... N O .ADDR $8888,$8888 ; 50 P Q ... V W .ADDR $8588,$588C ; 58 X Y Z [ \ ] ^ _ .ADDR $8888,$8888 ; 60 MINUSCULES .ADDR $8888,$8888 ; 68 " " .ADDR $8888,$8888 ; 70 " " .ADDR $8888,$8868 ; 78 " " RUBOUT. .PAGE ; ZONE DES ATOMES A PARTIR DE UNDEF. ; FORME D'UN ATOME : ; [ CVAL ] ; [ PLIST ] ; [ F-VAL ] ; [ F-TYP - P-TYPE ] ; [ A-LINK ] ; [ P-LEN PN1 ] ; [ PN2 PN3 ] ; ... ; L'ATOME UNDEF ; sert aussi de fonction de verrouillage du stepper ; et ne figure pas dans l'oblist ; car ca provoque l'erreur ERUND innoportunement ; et la fonction ne doit pas pouvoir etre redefinie .VERST=. + IMEM .ADDR .UNDF,.NIL ; C-VAL P-LIST .ADDR VERSTE ; F-VAL .BYTE SBR2,0 ; F-TYP, P-TYP .ADDR NIL ; A-LINK .BYTE 5 ; P-LEN .ASCII 'undef' ; P-NAME ; atome fantome servant de fonction de verrouillage du toplevel .ATCB=. + IMEM ; la fonction de verrouillage du toplevel .ADDR .UNDF,.NIL ; cval et plist mais on s'en fout .ADDR FVACB ; LA F-VAL , fonction de verrouillage .BYTE SBR2,0 ; c'est une 2subr, pas de ptype .ADDR 0 ; faux a-link .BYTE 0 ; pas de p-name .BYTE 0 ; pour cadrer ; TABLE DES F-TYP (CF EVALT & TYPFT ) SBR0=2 ; SUBR 0 SBR1=4 ; SUBR 1 SBR2=6 ; SUBR 2 SBR3=8 ; SUBR 3 SBRN=10 ; SUBR N SBRM=20 ; SUBR N associatives SBRF=12 ; SUBR F SBR1V=22 ; subr 1V SBR2V=24 ; subr 2V SUBR0=. + IMEM MAKST 0 .BYTE 5 .ASCII '0subr' SUBR1=. + IMEM MAKST 0 .BYTE 5 .ASCII '1subr' SUBR2=. + IMEM MAKST 0 .BYTE 5 .ASCII '2subr' SUBR3=. + IMEM MAKST 0 .BYTE 5 .ASCII '3subr' SUBRN=. + IMEM MAKST 0 .BYTE 5 .ASCII 'nsubr' SUBRF=. + IMEM MAKST 0 .BYTE 5 .ASCII 'fsubr' SUBR1V=. + IMEM MAKST 0 .BYTE 6 .ASCII 'subr1v ' SUBR2V=. + IMEM MAKST 0 .BYTE 6 .ASCII 'subr2v ' EXPR=. + IMEM MAKST 0 .BYTE 4 .ASCII 'expr ' FEXPR=. + IMEM MAKST 0 .BYTE 5 .ASCII 'fexpr' MAKRO=. + IMEM MAKST 0 .BYTE 5 .ASCII 'macro' .T=. + IMEM MAKST 0 .BYTE 1 .ASCII 't' EKSTS=. ; FIN CONSTANTES REELLES .PAGE .SBTTL; Zone d'initialisation : variables ; DEBUT DES VARIABLES EN FRONTIERE DE H .IFNE ROM .=. .IFF .=<. + $100> & $FF00 ; ! cette formule se retrouve en BATO1= ... .ENDC IMEM1=. ; DEBUT 2EME ZONE .IFNE ROM BATO1= + $100> & $FF00 .IFF BATO1=. .ENDC IMEM=BATO1-IMEM1 ; le vieux HVAR=<. + IMEM> ^ .PAGE .SBTTL; VARIABLES : LES ATOMES AVEC C-VALS DEFINIES ; ATTENTION ! ; LES 3 ATOMES SUIVANTS DOIVENT ETRE DANS LA MEME PAGE ! .LAMB=. + IMEM ; [jer] .MKNW=. + IMEM ; [jer] .ADDR <<. + IMEM> ^> ! <<. + IMEM> * 256 & $FF00> ; [jer] .ADDR .NIL ; [jer] .ADDR FLAMB ; [jer] .BYTE SBRF ; [jer] .BYTE 2 ; [jer] .ADDR .T ; [jer] ; [jer] .ADDR .MKLS ; [jer] .MKLS=.MKNW MAKAT FLAMB,SBRF,2 .BYTE 6 .ASCII 'lambda ' .MLAM=. + IMEM ; [jer] .MKNW=. + IMEM ; [jer] .ADDR <<. + IMEM> ^> ! <<. + IMEM> * 256 & $FF00> ; [jer] .ADDR .NIL ; [jer] .ADDR FMLAMB ; [jer] .BYTE SBRF ; [jer] .BYTE 2 ; [jer] .ADDR .LAMB ; [jer] ; [jer] .ADDR .MKLS ; [jer] .MKLS=.MKNW MAKAT FMLAMB,SBRF,2 .BYTE 7 .ASCII 'mlambda ' .FLAM=. + IMEM ; [jer] .MKNW=. + IMEM ; [jer] .ADDR <<. + IMEM> ^> ! <<. + IMEM> * 256 & $FF00> ; [jer] .ADDR .NIL ; [jer] .ADDR FFLAMB ; [jer] .BYTE SBRF ; [jer] .BYTE 2 ; [jer] .ADDR .MLAM ; [jer] .ADDR .MKLS ; [jer] .MKLS=.MKNW MAKAT FFLAMB,SBRF,2 .BYTE 7 .ASCII 'flambda ' ; [jer] .MKNW=. + IMEM .QUOT=. + IMEM ; [jer] .ADDR <<. +IMEM> ^> ! <<. + IMEM> * 256 & $FF00> ; [jer] .ADDR .NIL ; P-LIST ; [jer] .ADDR QUOTE ; F-VAL ; [jer] .BYTE SBRF,0 ; F-TYP ; [jer] .ADDR .FLAM ; [jer] ; [jer] .ADDR .MKLS ; A-LINK ; [jer] .MKLS=.MKNW MAKAT QUOTE,SBRF,0 .BYTE 5 .ASCII 'quote' .PAGE .SBTTL; VARIABLES : LES ERREURS .MSBST=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erios' ; entree/sortie .MSLEC=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ersxt' ; erreur de syntaxe .MSTAP=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erwna' ; trop d'argument .MSLIP=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erwla' ; liaison impossible .MSARI=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erari' ; overflow/underflow/undefined .MSCNS= . + IMEM MAKST 0 .BYTE 5 .ASCII 'ernum' ; cdr numerique .MSPLC=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ernva' ; arg doit etre une variable .MSNAT=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ernaa' ; arg doit etre un litteral .MSNNB=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ernna' ; arg doit etre un nombre .MSNLS=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ernla' ; arg doit etre une liste .MSOOB= . + IMEM MAKST 0 .BYTE 5 .ASCII 'eroob' ; argument hors-limite .MSUND=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erudv' ; variable indefinie .MSUDF=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erudf' ; fonction indefinie .MSUDT=. + IMEM MAKST 0 .BYTE 5 .ASCII 'erudt' ; echappement indefini .MSATO=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ferat' ; zone atome pleine .MSFM=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ferls' ; zone liste pleine .MSFS=. + IMEM MAKST 0 .BYTE 5 .ASCII 'ferfs' ; pile pleine .PAGE .SBTTL; VARIABLES : EVALUATEURS .EVAL=. + IMEM MAKAT EVAL,SBR1,0 .BYTE 4 .ASCII 'eval ' .APPLY=. + IMEM MAKAT APPLY,SBR2,0 .BYTE 5 .ASCII 'apply' .FNCL=. + IMEM MAKAT FUNCAL,SBRN,0 .BYTE 7 .ASCII 'funcall ' MAKAT MAP,SBRN,0 .BYTE 3 .ASCII 'map ' MAKAT MAPLIS,SBRN,0 .BYTE 7 .ASCII 'maplist ' MAKAT MAPCON,SBRN,0 .BYTE 6 .ASCII 'mapcon ' MAKAT MAPC,SBRN,0 .BYTE 4 .ASCII 'mapc ' MAKAT MAPCAR,SBRN,0 .BYTE 6 .ASCII 'mapcar ' MAKAT MAPCAN,SBRN,0 .BYTE 6 .ASCII 'mapcan ' .MPOB=. + IMEM MAKAT MPOBL,SBR1,0 .BYTE 10 .ASCII 'mapcoblist ' .BIND=. + IMEM MAKAT BINDF,SBRF,2 .BYTE 4 .ASCII 'bind ' .ENV=. + IMEM MAKAT LETQ,SBRF,2 .BYTE 3 .ASCII 'env ' MAKAT LETQQ,SBRF,2 .BYTE 4 .ASCII 'envq ' .LETR=. + IMEM MAKAT LETREC,SBRF,2 .BYTE 6 .ASCII 'letrec ' .FLET=. + IMEM ; 14 - 1000l$$1000t$$ MAKAT WHERE,SBRF,2 .BYTE 4 .ASCII 'flet ' .SELF=. + IMEM MAKAT SELF,SBRF,0 .BYTE 4 .ASCII 'self ' .EXIT=. + IMEM MAKAT NEXIT,SBRF,2 .BYTE 4 .ASCII 'exit ' .EVXIT=. + IMEM MAKAT EVXIT,SBRF,2 .BYTE 6 .ASCII 'evexit ' .UNXIT=. + IMEM MAKAT UNXIT,SBRF,2 .BYTE 9 .ASCII 'untilexit' .ESCA=. + IMEM MAKAT ESCAP,SBRF,2 .BYTE 3 .ASCII 'tag ' .LOCK=. + IMEM MAKAT LOCK,SBRF,2 .BYTE 4 .ASCII 'lock ' .PRTCT=. + IMEM MAKAT PRTCT,SBRF,2 .BYTE 7 .ASCII 'protect ' .IFNE BIG MAKAT EVLIS,SBR1,0 .BYTE 5 .ASCII 'evlis' .ENDC ; de BIG MAKAT PROGN,SBR1,1 .BYTE 6 .ASCII 'eprogn ' MAKAT PRG1,SBRF,1 .BYTE 5 .ASCII 'prog1' .PROGN=. + IMEM MAKAT PROGN,SBRF,1 .BYTE 5 .ASCII 'progn' MAKAT AIF,SBRF,2 .BYTE 2 .ASCII 'if ' .IFNE BIG MAKAT AIFN,SBRF,2 .BYTE 3 .ASCII 'ifn ' MAKAT WHEN,SBRF,2 .BYTE 4 .ASCII 'when ' MAKAT UNLES,SBRF,2 .BYTE 6 .ASCII 'unless ' .ENDC ; de BIG MAKAT COND,SBRF,4 .BYTE 4 .ASCII 'cond ' MAKAT SELQ,SBRF,5 .BYTE 7 .ASCII 'selectq ' MAKAT AOR,SBRF,1 .BYTE 2 .ASCII 'or ' MAKAT AAND,SBRF,1 .BYTE 3 .ASCII 'and ' MAKAT WHILE,SBRF,2 .BYTE 5 .ASCII 'while' .IFNE BIG MAKAT UNTIL,SBRF,2 .BYTE 5 .ASCII 'until' .REPT=. + IMEM MAKAT REPT,SBRF,2 .BYTE 6 .ASCII 'repeat ' .ENDC ; de BIG .PAGE .SBTTL; VARIABLES : OPERATEURS .DE=. + IMEM MAKAT DE,SBRF,3 .BYTE 2 .ASCII 'de ' .DF=. + IMEM MAKAT DF,SBRF,3 .BYTE 2 .ASCII 'df ' .DM=. + IMEM MAKAT DM,SBRF,3 .BYTE 2 .ASCII 'dm ' .DMC=. + IMEM MAKAT DMC,SBRF,3 .BYTE 3 .ASCII 'dmc ' .SHRP=. + IMEM MAKAT DFSHR,SBRF,3 .BYTE 5 .ASCII 'sharp' .IFNE BIG .GETFN=. + IMEM MAKAT GETFN,SBR1,0 .BYTE 6 .ASCII 'getdef ' MAKAT FINFN,SBR1,0 .BYTE 6 .ASCII 'findfn ' .ENDC ; de BIG .SYNON=. + IMEM MAKAT SYNON,SBR2,0 .BYTE 7 .ASCII 'synonym ' MAKAT NULL,SBR1,0 .BYTE 4 .ASCII 'null ' MAKAT CTEP,SBR1,0 .BYTE 9 .ASCII 'constantp' .ATOM=. + IMEM MAKAT ATOM,SBR1,0 .BYTE 4 .ASCII 'atom ' MAKAT NLISTP,SBR1,0 .BYTE 6 .ASCII 'nlistp ' MAKAT CONSP,SBR1,0 .BYTE 5 .ASCII 'consp' .IFNE BIG MAKAT LITATO,SBR1,0 .BYTE 7 .ASCII 'symbolp ' .BOUND=. + IMEM MAKAT BOUND,SBR1,0 .BYTE 6 .ASCII 'boundp ' .MKUNB = . + IMEM MAKAT MKUNB,SBR1,0 .BYTE 10 .ASCII 'makunbound ' .REMFN=. + IMEM MAKAT REMFN,SBR1,0 .BYTE 5 .ASCII 'remfn' .ENDC ; de BIG MAKAT LISTP,SBR1,0 .BYTE 5 .ASCII 'listp' MAKAT NUMBP,SBR1,0 .BYTE 7 .ASCII 'numberp ' MAKAT PEQ,SBR2,0 .BYTE 2 .ASCII 'eq ' MAKAT PNEQ,SBR2,0 .BYTE 3 .ASCII 'neq ' MAKAT PEQUAL,SBR2,0 .BYTE 5 .ASCII 'equal' .IFNE BIG MAKAT NEQUAL,SBR2,0 .BYTE 6 .ASCII 'nequal ' .ENDC ; de BIG .SORT=. + IMEM MAKAT SORT,SBR2,0 .BYTE 10 .ASCII 'alphalessp ' MAKAT PMEMQ,SBR2,0 .BYTE 4 .ASCII 'memq ' .IFNE BIG MAKAT PMEMBR,SBR2,0 .BYTE 6 .ASCII 'member ' .ENDC ; de BIG MAKAT PASSQ,SBR2,0 .BYTE 4 .ASCII 'assq ' .IFNE BIG MAKAT CASSQ,SBR2,0 .BYTE 5 .ASCII 'cassq' .ENDC ; de BIG .CHRNT=.+IMEM MAKAT CHRNTH,SBR2,0 .BYTE 6 .ASCII 'chrnth ' .CRPOS=. + IMEM MAKAT CRPOS,SBR2,0 .BYTE 6 .ASCII 'chrpos ' .CNTH=. + IMEM MAKAT CNTH,SBR2,0 .BYTE 3 .ASCII 'nth ' .NTH=. + IMEM MAKAT NTH,SBR2,0 .BYTE 6 .ASCII 'nthcdr ' .CAR =. + IMEM MAKAT CAR,SBR1,0 .BYTE 3 .ASCII 'car ' .CDR = . + IMEM MAKAT CDR,SBR1,0 .BYTE 3 .ASCII 'cdr ' MAKAT CAAR,SBR1,0 .BYTE 4 .ASCII 'caar ' MAKAT CADR,SBR1,0 .BYTE 4 .ASCII 'cadr ' MAKAT CDAR,SBR1,0 .BYTE 4 .ASCII 'cdar ' MAKAT CDDR,SBR1,0 .BYTE 4 .ASCII 'cddr ' .IFNE BIG MAKAT CAAAR,SBR1,0 .BYTE 5 .ASCII 'caaar' MAKAT CAADR,SBR1,0 .BYTE 5 .ASCII 'caadr' MAKAT CADAR,SBR1,0 .BYTE 5 .ASCII 'cadar' MAKAT CADDR,SBR1,0 .BYTE 5 .ASCII 'caddr' MAKAT CDAAR,SBR1,0 .BYTE 5 .ASCII 'cdaar' MAKAT CDADR,SBR1,0 .BYTE 5 .ASCII 'cdadr' MAKAT CDDAR,SBR1,0 .BYTE 5 .ASCII 'cddar' MAKAT CDDDR,SBR1,0 .BYTE 5 .ASCII 'cdddr' MAKAT LAST,SBR1,0 .BYTE 4 .ASCII 'last ' .ENDC ; de BIG .CONS=.+IMEM MAKAT PCONS,SBR2,0 .BYTE 4 .ASCII 'cons ' MAKAT PXONS,SBR2,0 .BYTE 5 .ASCII 'xcons' .LIST=.+IMEM MAKAT LISTN,SBRN,1 .BYTE 4 .ASCII 'list ' .RPLCA=. + IMEM MAKAT PRPLA,SBR2,0 .BYTE 6 .ASCII 'rplaca ' .RPLCD=. + IMEM MAKAT RPLCD,SBR2,0 .BYTE 6 .ASCII 'rplacd ' .RPLC3= . + IMEM MAKAT RPLC3,SBR3,0 .BYTE 5 .ASCII 'rplac' .RPLCB=. + IMEM MAKAT RPLCB,SBR2,0 .BYTE 8 .ASCII 'displace ' MAKAT PLAC1,SBR2,0 .BYTE 6 .ASCII 'placdl ' .IFNE BIG .SET=. + IMEM MAKAT PSET,SBRN,0 .BYTE 3 .ASCII 'set ' .ENDC ; de BIG .SETQ=. + IMEM MAKAT SETQ,SBRF,6 .BYTE 4 .ASCII 'setq ' .NEXTL=. + IMEM MAKAT NEXTL,SBRF,0 .BYTE 5 .ASCII 'nextl' .NEWL=. + IMEM MAKAT NEWL,SBRF,0 .BYTE 4 .ASCII 'newl ' .NEWR=. + IMEM MAKAT NEWR,SBRF,0 .BYTE 4 .ASCII 'newr ' .INCR=. + IMEM MAKAT FINCR,SBRF,0 .BYTE 4 .ASCII 'incr ' .DECR=. + IMEM MAKAT DECR,SBRF,0 .BYTE 4 .ASCII 'decr ' .NCONC=. + IMEM MAKAT NCONC,SBRM,0 .BYTE 5 .ASCII 'nconc' .IFNE BIG MAKAT PFREV,SBR2,0 .BYTE 7 .ASCII 'nreconc ' .ENDC ; de BIG MAKAT PREV,SBR2,0 .BYTE 7 .ASCII 'reverse ' .APP=.+IMEM MAKAT APPND,SBRM,0 .BYTE 6 .ASCII 'append ' .IFNE BIG .MCONS=.+IMEM MAKAT MCONS,SBRM,0 .BYTE 5 .ASCII 'mcons' .ENDC ;DE BIG MAKAT KWOTE,SBR1,0 .BYTE 5 .ASCII 'kwote' MAKAT ACONS,SBR3,0 .BYTE 5 .ASCII 'acons' MAKAT SUBST,SBR3,0 .BYTE 5 .ASCII 'subst' .IFNE BIG MAKAT COPY,SBR1,0 .BYTE 4 .ASCII 'copy ' MAKAT SUBLS,SBR2,0 .BYTE 6 .ASCII 'sublis ' .ENDC ; DE BIG .IFNE BIG .GET=. + IMEM MAKAT GETP,SBR2,0 .BYTE 7 .ASCII 'getprop ' .PUT=. + IMEM MAKAT PUTP,SBR3,0 .BYTE 7 .ASCII 'putprop ' .IFNE BIG .ADDP=. + IMEM MAKAT ADDP,SBR3,0 .BYTE 7 .ASCII 'addprop ' .ENDC ; de BIG .REMP=. + IMEM MAKAT REMP,SBR2,0 .BYTE 7 .ASCII 'remprop ' .PAGE .SBTTL; VARIABLES : FONCTIONS ARITHMETIQUES MAKAT LENGT,SBR1,0 .BYTE 6 .ASCII 'length ' .IFNE BIG .MIN=. + IMEM MAKAT MIN,SBRM,0 .BYTE 3 .ASCII 'min ' .MAX=. + IMEM MAKAT MAX,SBRM,0 .BYTE 3 .ASCII 'max ' MAKAT PLENG,SBR1,0 .BYTE 7 .ASCII 'plength ' .ENDC ; de BIG. MAKAT LOGAN,SBR2,0 .BYTE 6 .ASCII 'logand ' MAKAT LOGOR,SBR2,0 .BYTE 5 .ASCII 'logor' MAKAT LOGXO,SBR2,0 .BYTE 6 .ASCII 'logxor ' .IFNE FLOAT .EQN=. + IMEM MAKAT EQN,SBR2,0 .BYTE 3 .ASCII 'eqn ' .NEQN=. + IMEM MAKAT NEQN,SBR2,0 .BYTE 4 .ASCII 'neqn ' .FGE=. + IMEM MAKAT FGE,SBR2,0 .BYTE 2 .ASCII 'ge ' .FLT=. + IMEM MAKAT FLT,SBR2,0 .BYTE 2 .ASCII 'lt ' .FGT=. + IMEM MAKAT FGT,SBR2,0 .BYTE 2 .ASCII 'gt ' .FLE=. + IMEM MAKAT FLE,SBR2,0 .BYTE 2 .ASCII 'le ' .ADD1=. + IMEM MAKAT ADD1,SBR1,0 .BYTE 4 .ASCII 'add1 ' .SUB1=. + IMEM MAKAT SUB1,SBR1,0 .BYTE 4 .ASCII 'sub1 ' .DIV=. + IMEM MAKAT PDIV,SBR2,0 .BYTE 3 .ASCII 'div ' .REM=. + IMEM MAKAT PREM,SBR2,0 .BYTE 3 .ASCII 'rem ' .ENDC ; DE FLOAT .IFNE BIG .ABS=. + IMEM MAKAT ABS,SBR1,0 .BYTE 3 .ASCII 'abs ' .SCALE=. + IMEM MAKAT SCALE,SBR3,0 .BYTE 5 .ASCII 'scale' .ENDC ; de BIG .ADD1=. + IMEM MAKAT ADD1,SBR1,0 .BYTE 2 .ASCII '1+ ' .SUB1=. + IMEM MAKAT SUB1,SBR1,0 .BYTE 2 .ASCII '1- ' .AADD=. + IMEM MAKAT NPLUS,SBRM,0 .BYTE 1 .ASCII '+' .asub=. + IMEM MAKAT PSUB,SBRN,0 .BYTE 1 .ASCII '-' .mul=. + IMEM MAKAT NTIMES,SBRM,0 .BYTE 1 .ASCII '*' .div=. + IMEM MAKAT PDIV,SBR2,0 .BYTE 1 .ASCII '/' .rem=. + IMEM MAKAT PREM,SBR2,0 .BYTE 1 .ASCII '\' .chint= . + IMEM MAKST 128 .BYTE 2 .ASCII '? ' .cheq= . + IMEM .EQN=. + IMEM MAKAT EQN,SBR2,0 .BYTE 1 .ASCII '=' .neqn=. + IMEM MAKAT NEQN,SBR2,0 .BYTE 2 .ASCII '<> ' .fge=. + IMEM MAKAT FGE,SBR2,0 .BYTE 2 .ASCII '>= ' .fgt=. + IMEM MAKAT FGT,SBR2,0 .BYTE 1 .ASCII '>' .fle=. + IMEM MAKAT FLE,SBR2,0 .BYTE 2 .ASCII '<= ' .flt=. + IMEM MAKAT FLT,SBR2,0 .BYTE 1 .ASCII '<' .page .SBTTL; VARIABLES : MACRO CARACTERES ;[jer].MKNW=. + IMEM .ASTR=. + IMEM MAKAT RDMAE,SBR0,0 ;[jer] .ADDR <<. +IMEM> ^> ! <<. + IMEM> * 256 & $FF00> ;[jer] .ADDR .NIL ; P-LIST ;[jer] .ADDR RDMAE ; F-VAL ;[jer] .ADDR SBR0 ; F-TYP ,, P-TYP ;[jer] .ADDR .MKLS ; A-LINK ;[jer].MKLS=.MKNW .BYTE 1 .ASCII '&' MAKAT RDMAQ,SBR0,0 .BYTE 1 .ASCII $27 ; le ' !! MAKAT FLEXE,SBR0,0 .BYTE 1 .ASCII '^' .IFNE BIG MAKAT ASTOP,SBR0,0 .BYTE 1 .BYTE 3 ; ^C .ENDC ; de BIG MAKAT CROOUV,SBR0,0 .BYTE 1 .ASCII '[' .CROF=.+IMEM MAKAT 0,0,0 .BYTE 1 .ASCII ']' .UNPAK=.+IMEM MAKAT 0,0,0 .BYTE 1 .ASCII '!' .PAGE .SBTTL; VARIABLES : ENTREES/SORTIES .BOL=. + IMEM MAKAT BOL,SBR0,0 .BYTE 3 .ASCII 'bol ' .EOL=. + IMEM MAKAT EOL,SBR0,0 .BYTE 3 .ASCII 'eol ' .IFNE FILE .EOF=. + IMEM MAKAT FEOF,SBR0,0 .BYTE 3 .ASCII 'eof ' .ENDC ; de FILE .INPUT=. + IMEM MAKAT DIOI,SBR1,0 ; toujours a cause de (INPUT T) .BYTE 5 .ASCII 'input' .OUPUT=. + IMEM MAKAT DOOI,SBR1,0 ; toujours a cause de (OUTPUT T) .BYTE 6 .ASCII 'output ' .IFNE K7 MAKAT KIOI,SBR1,0 .BYTE 8 .ASCII 'inputape ' MAKAT KOOI,SBR1,0 .BYTE 9 .ASCII 'outputape' MAKAT CLOAD,SBR0,0 .BYTE 5 .ASCII 'cload' MAKAT CSAVE,SBR0,0 .BYTE 5 .ASCII 'csave' .ENDC ; de K7 .IFNE COLOR ; UNIQUEMENT POUR LE SYSTEME MOSTEK. MAKAT COLX,SBR1,0 .BYTE 5 .ASCII 'adrix' MAKAT COLXY,SBR2,0 .BYTE 6 .ASCII 'adrixy ' MAKAT COLC,SBR1,0 .BYTE 6 .ASCII 'coulix ' MAKAT COLD,SBR3,0 .BYTE 8 .ASCII 'couldose ' MAKAT COLT,SBR1,0 .BYTE 5 .ASCII 'coult' .ENDC ; de COLOR .IFNE EDITRS .ETV=. + IMEM MAKAT EDF,SBR1,0 .BYTE 5 .ASCII 'editv' MAKAT CLS,SBR1,0 .BYTE 5 .ASCII 'clear' MAKAT DISPL,SBR2,0 .BYTE 7 .ASCII 'display ' MAKAT POINT,SBR3,0 .BYTE 5 .ASCII 'point' MAKAT WIND,SBR1,0 .BYTE 6 .ASCII 'window ' .ENDC ; de EDITRS .PRIN=. + IMEM MAKAT PRINT,SBRN,1 .BYTE 5 .ASCII 'print' MAKAT PRIN1,SBRN,1 .BYTE 4 .ASCII 'prin ' MAKAT EXPLO,SBR1,0 .BYTE 7 .ASCII 'explode ' MAKAT TERPR,SBR1,0 .BYTE 6 .ASCII 'terpri ' MAKAT FLUSU,SBR0,0 .BYTE 5 .ASCII 'flush' .PRNCH=. + IMEM MAKAT PRNC,SBR2,0 .BYTE 6 .ASCII 'princh ' MAKAT PRNK,SBR2,0 .BYTE 6 .ASCII 'princn ' .READ=. + IMEM MAKAT READU,SBR0,0 .BYTE 4 .ASCII 'read ' .TOPL=. + IMEM MAKAT TOPLV,SBR0,0 .BYTE 8 .ASCII 'toplevel ' MAKAT READC,SBR0,0 .BYTE 6 .ASCII 'readch ' MAKAT READK,SBR0,0 .BYTE 6 .ASCII 'readcn ' .IFNE BIG MAKAT PEEKC,SBR0,0 .BYTE 6 .ASCII 'peekch ' MAKAT PEEKK,SBR0,0 .BYTE 6 .ASCII 'peekcn ' MAKAT TERD,SBR0,0 .BYTE 6 .ASCII 'teread ' .ENDC ; de BIG MAKAT ASCII,SBR1,0 .BYTE 5 .ASCII 'ascii' .CASC=. + IMEM MAKAT CASCI,SBR1,0 .BYTE 6 .ASCII 'cascii ' .CONCA=. + IMEM MAKAT CONCAT,SBRM,0 .BYTE 6 .ASCII 'concat ' .IMPLD=. + IMEM MAKAT IMPLO,SBR1,0 .BYTE 7 .ASCII 'implode ' MAKAT FINP,SBR1,0 .BYTE 2 .ASCII 'in ' MAKAT FOUT,SBR2,0 .BYTE 3 .ASCII 'out ' MAKAT TYI,SBR0,0 .BYTE 3 .ASCII 'tyi ' MAKAT TYS,SBR0,0 .BYTE 3 .ASCII 'tys ' .TYO=. + IMEM MAKAT TYO,SBRN,0 .BYTE 3 .ASCII 'tyo ' .PAGE .SBTTL; VARIABLES : VARIABLES-FONCTIONS 2 .FVAL=. + IMEM MAKAT VFGET,SBR2V,0 .BYTE 5 .ASCII 'valfn' .TYPFN=. + IMEM MAKAT FTGET,SBR2V,0 .BYTE 6 .ASCII 'typefn ' .CVAL=. + IMEM MAKAT CVGET,SBR2V,0 .BYTE 4 .ASCII 'cval ' .ENDC ; de BIG .PLIST=. + IMEM MAKAT PLIST,SBR2V,0 .BYTE 5 .ASCII 'plist' .INBU=. + IMEM MAKAT INBGET,SBR2V,0 .BYTE 5 .ASCII 'inbuf' .OUTBU=. + IMEM MAKAT OUBGET,SBR2V,0 .BYTE 6 .ASCII 'outbuf ' .PRTP=. + IMEM MAKAT PTGET,SBR2V,0 .BYTE 5 .ASCII 'ptype' .TYPCN=.+IMEM MAKAT TAGET,SBR2V,0 .BYTE 6 .ASCII 'typecn ' .TYPCH=. + IMEM MAKAT TCGET,SBR2V,0 .BYTE 6 .ASCII 'typech ' .PAGE .SBTTL; VARIABLES : VARIABLES-FONCTIONS 1 .PRLVL=. + IMEM MAKAT LVGET,SBR1V,0 .BYTE 10 .ASCII 'printlevel ' .PRLIN=. + IMEM MAKAT LNGET,SBR1V,0 .BYTE 9 .ASCII 'printline' .PRLGR=. + IMEM MAKAT LGGET,SBR1V,0 .BYTE 11 .ASCII 'printlength ' .INMAX=. + IMEM MAKAT INXGT,SBR1V,0 .BYTE 5 .ASCII 'inmax' .INPS=. + IMEM MAKAT INPGT,SBR1V,0 .BYTE 5 .ASCII 'inpos' .OUTPS=. + IMEM MAKAT OUTPG,SBR1V,0 .BYTE 6 .ASCII 'outpos ' .LINLG=. + IMEM MAKAT RMGET,SBR1V,0 .BYTE 7 .ASCII 'rmargin ' .LMARG=. + IMEM MAKAT LMGET,SBR1V,0 .BYTE 7 .ASCII 'lmargin ' .STBA=. + IMEM MAKAT BAGET,SBR1V,0 .BYTE 5 .ASCII 'obase' .STPR=. + IMEM MAKAT SPGET,SBR1V,0 .BYTE 6 .ASCII 'sprint ' .STRD=. + IMEM MAKAT SRGET,SBR1V,0 .BYTE 5 .ASCII 'icase' .PROMP=. + IMEM MAKAT PRGET,SBR1V,0 .BYTE 6 .ASCII 'prompt ' .PAGE .SBTTL; VARIABLES : FONCTIONS SYSTEME .TRVAL=. + IMEM MAKAT TRVAL,SBR1,1 .BYTE 8 .ASCII 'traceval ' MAKAT FADRES,SBR1,0 .BYTE 3 .ASCII 'loc ' MAKAT FVAG,SBR1,0 .BYTE 3 .ASCII 'vag ' .MEMRY= . + IMEM MAKAT MEMGET,SBR2V,0 .BYTE 7 .ASCII 'memoryb ' MAKAT CALLN,SBR2,0 .BYTE 5 .ASCII 'calln' .CAL=. + IMEM MAKAT FCAL,SBRN,1 .BYTE 4 .ASCII 'call ' .IFNE BIG MAKAT XCT,SBR1,0 .BYTE 7 .ASCII 'execute ' .ENDC ; de BIG .IFNE BIG .IFNE FILE .VINI=. + IMEM .IFNE TRSDOS ! TRSDS2 MAKST 0 .BYTE 10 .ASCII 'LELISP/INI ' .ENDC ; de TRSDOS ! TRSDS2 .IFNE CPM MAKST 0 .BYTE 11 .ASCII 'LELISP INI ' .ENDC ; de FILE .ENDC ; de CPM MAKAT VERSF,SBR0,0 .BYTE 7 .ASCII 'version ' .SYS=. + IMEM MAKAT SYSTM,SBR0,0 .BYTE 6 .ASCII 'system ' .SYSTM=. + IMEM .IFNE CPM MAKAT ADJST,SBR1,0 .IFF MAKST 0 .ENDC .IFNE TRS .BYTE 5 .ASCII 'trs80' .ENDC .IFNE MDS .BYTE 3 NI=.ASCII 'mds ' .ENDC .IFNE SOR .BYTE 8 .ASCII 'sorcerer ' .ENDC .IFNE IMSAI .BYTE 5 .ASCII 'imsai' .ENDC .IFNE TRSII .BYTE 5 .ASCII 'trsii' .ENDC .IFNE H89CPM .BYTE 6 .ASCII 'h89cpm ' .ENDC .IFNE Z89CPM .BYTE 6 .ASCII 'h89cpm ' .ENDC .IFNE LEBLAN .BYTE 7 .ASCII 'leblanc ' .ENDC .IFNE MICRAL .BYTE 6 .ASCII 'micral ' .ENDC .IFNE SILZ .BYTE 4 .ASCII 'silz ' .ENDC .IFNE LOGAX .BYTE 6 .ASCII 'lx529e ' .ENDC .ENDC ; de BIG .IFNE LAP .BCOD=. + IMEM MAKST 0 .BYTE 7 .ASCII '$bcode$ ' .ECOD=. + IMEM MAKST 0 .BYTE 7 .ASCII '$ecode$ ' .ENDC ; de LAP .CSTAK=. + IMEM MAKAT CSTAK,SBR1,0 .BYTE 6 .ASCII 'cstack ' .IFNE ITEVAL .EVLIT=. + IMEM MAKAT ITEVAF,SBR1,0 .BYTE 6 .ASCII 'iteval ' .ENDC ; ITEVAL .STPEV=. + IMEM MAKAT STEPIN,SBR1,0 .BYTE 6 .ASCII 'stepin ' .STPEQ=. + IMEM MAKAT STEPOU,SBR1,0 .BYTE 7 .ASCII 'stepout ' .BREAK=. + IMEM MAKAT BREAK,SBR0,0 .BYTE 5 .ASCII 'break' .SYSER=. + IMEM MAKAT ERRSTD,SBR3,0 .BYTE 8 .ASCII 'syserror ' MAKAT OBLST,SBR0,0 .BYTE 6 .ASCII 'oblist ' .GC=. + IMEM ; 15 - 1000l$$1000t$$ MAKAT GCF,SBR0,0 .BYTE 2 .ASCII 'gc ' .GCALR=. + IMEM MAKAT GCALR,SBR1,0 .BYTE 7 .ASCII 'gcalarm ' MAKAT GCINF,SBR0,0 .BYTE 6 .ASCII 'gcinfo ' ; DERNIER ATOME LATOM=. + IMEM ; ADRESSE DU DERNIER ATOME. MAKAT ASTOP,SBR0,0 .BYTE 3 .ASCII 'end ' ; ATTENTION : IMEM PEUT RECOUVRIR UN PEU LA PILE ; C'EST PAS GENANT (JUSQU'A 54FF SOUS MDS) IMEME=. - 1 ; FIN ZONE A TRANSFERER. EATOM=. + IMEM ; FIN ATOMES SYSTEMES. ATMSZ=IMEME-ZBNIL ; taille de la zone atome de base .PRINT ATMSZ ; taille des atomes systeme .PRINT ATMSZ+CODES ; taille totale. ;----- Pour la version 8086 .=..FLST+1 .ASCII 'fin' ;----- FIN DE L'INTERPRETE. .END START