Code:VARIABLE FindFlag 128 STRING$ WORK$ : EnrMessage01 ( n --- adr,len ) CASE FRENCH OF S" Dépassemnt de numéro de ligne dans un Enregistrement" ENDOF ENGLISH OF S" Overflow of line number of FileBuffer" ENDOF GERMAN OF S" Keine Zeile mit diesem Nummer in dem FileBuffer" ENDOF ENDCASE ; : EnrMessage02 ( n --- adr,len ) CASE FRENCH OF S" Taille fichier trop grande pour être chargé dans un Enregistrement" ENDOF ENGLISH OF S" Can not load the file, Size owerflow of the FileBuffer." ENDOF GERMAN OF S" Kan Dateie nich laden, FileBuffer zu kleine" ENDOF ENDCASE ; : EnrMessage03 ( n --- adr,len ) CASE FRENCH OF S" Transfert imposible, Buffer destination, Taille insufisante" ENDOF ENGLISH OF S" Can not move the Buffer, Destination Buffer have Size owerflow " ENDOF GERMAN OF S" Kan die Daten nicht ubergeben, Endbuffer zu kleine" ENDOF ENDCASE ; VARIABLE Ehandle : CRLF <CRLF> 1+ W@ ; ( --- CRLF ) \ Retourne 0A0D HEX : ASCIIBUFFER ( <nom> taille --- adr0 ) \ Creation entete de l'enregistrement CREATE \ On cré la structure, on initialise le début de la liste, Here 24 + >R 0 , ( here ) \ Compile un position de réserve 1 , ( here + 4 ) \ Compile le Num R@ , ( here + 8 ) \ Compile l'adresse de début de la première ligne R@ , ( here + 12 ) \ On compile l'adresse 0 de début de liste R@ 2 + , ( here + 16 ) \ On compile la première adresse libre dans la liste DUP , ( here + 20 ) \ On compile la taille max 2 , ( here + 24 ) \ On compile la taille courante 1 , ( here + 28 ) \ On compile le compteur d'éléments 0 C, ( here + 29 ) 0 C, ( here + 30 ) 0D C, ( here + 31 ) \ On compile une butée basse pour la recherche aléatoire dans 0A C, ( here + 32 ) \ le buffer 0D R@ C! \ On initialise le buffer avec une ligne vide 0A R@ 1+ C! \ DUP ALLOT \ On réserve la zone mémoire R> CELL + SWAP CELL - BLANK DOES> 24 + \ Décallage d'adresse sur le début de la liste ; IMMEDIATE DEFER ENREGISTREMENT$ ' ASCIIBUFFER IS ENREGISTREMENT$ DECIMAL { =============================== POUR MEMOIRE, ON UTILISE LA MEME STRUCTURE QUE POUR UNE ZLISTE =========================== =========================================================================================================================== } : BufLast@ 8CELL - 2@ ; ( adrr0 --- adrx0,n ) \ Retourne l'adresse de début et le num de la dernière ligne accédée : BufLast! 8CELL - 2! ; ( adrx0,n,adr0 --- ) \ Met à jour l'adresse de début et le num de la dernière ligne accédée : +DECAL ( adrx --- adr+nx0 ) \ Décallage avant du pointeur d'adresse de lignes dans un enregistrement. 1- BEGIN 1+ DUP W@ CRLF = UNTIL 2+ ; : -DECAL ( adrx --- adr-nx0 ) \ Décallage arrière du pointeur d'adresse de lignes dans un enregistrement 2- BEGIN 1- DUP W@ CRLF = UNTIL ; : BufferAccesTest ( Zadr0,n --- Zadr0,n ) \ Teste l'accès à la liste OVER ( zadr0,n --- zadr0,n,zadr0 ) Zcounter @ ( zadr0,n,zadr0 --- zadr0,n,x ) OVER ( zadr0,n,x --- zadr0,n,x,n ) < ( zadr0,n,x,n --- zadr0,n,flag ) OVER 1 < OR WABORT( EnrMessage01 ) ( zadr0,n,flag --- zadr0,n ) ; : GetBline ( Eadr0,n --- Eadr0,Enradrx ) \ Retourne l'adresse de début d'une chaine numéro n dans la liste. \ L'accès est sécurisé. En fait cette fonction déplace le pointeur de liste sur l'adresse \ de début d'une chaine n. BufferAccesTest ( Eadr0,n --- Eadr0,n ) >R DUP BufLast@ ( Eadr0,n --- Eadr0,Ladrx,nx ) R> 2DUP ( Eadr0,Ladrx,nx --- Eadr0,Ladrx,nx,n ) > ( Eadr0,Ladrx,nx,n --- Eadr0,Ladrx,nx,n,flag ) \ test sens de déplacement IF ( nx > n = déplacement arrière .... ) ( Eadr0,Ladrx,nx,n, --- ... ) ?DO ( Eadr0,Ladrx --- ... ) 2DUP 2+ >= IF LEAVE THEN \ On quitte si butée basse -DECAL LOOP 2+ ELSE SWAP ?DO +DECAL LOOP THEN ; { ========================================================================================================================= } : LFCOUNT ( addr0 --- addr0,n ) \ A partir d'une adresse de début de ligne, retourne la longueur de celle-ci DUP DUP IF 65535 13 SCAN DROP OVER - THEN ; : BUFPLACE ( from n to -- ) \ Déplace une chaine Ascii de adr1, vers adr2 et place les caractères de contrôle 0A0D en \ fin de chaine. TUCK OVER + >R CMOVE CRLF R> W! ; : INSERT%LINE ( adr,len,Ehandle,n --- ) \ Insert une ligne n dans l'enregistrement spécifié par Ehandle \ Met à jour l'entête de l'enregistrement. >R R@ \ Sauvegarde du numéro de la ligne accédée GetBline ( adr,len,Zadr0,n --- adr,len,Zadr0,Zadrx ) DUP >R \ Sauvegarde de l'adresse de début de cette ligne OVER ( adr,len,Zadr0,Zadrx --- adr,len,Zadr0,Zadrx,Zadr0 ) 5CELL - @ ( adr,len,Zadr0,Zadrx,Zadr0 --- adr,len,Zadr0,Zadrx,Zadrfree ) 2DUP SWAP - ( adr,len,Zadr0,Zadrx,Zadrfree,--- adr,len,Zadr0,Zadrx,Zadrfree,Zadrx, ) ( adr,len,Zadr0,Zadrx,Zadrfree,Zadrx,Zadrfree --- adr,len,Zadr0,Zadrx,Zadrfree,decalx ) OVER ( adr,len,Zadr0,Zadrx,Zadrfree,decalx --- adr,len,Zadr0,Zadrx,Zadrfree,decalx,Zadrfree ) 5 PICK + 2+ ( adr,len,Zadr0,Zadrx,Zadrfree,decalx,Zadrfree --- ???? len ) SWAP ( adr,len,Zadr0,Zadrx,Zadrfree-1,decalx,free+nx --- adr,len,Zadr0,Zadrx,Zadrfree-1,free+nx,decalx ) +MOVE ( adr,len,Zadr0,Zadrx,Zadrfree-1,free+nx,decalx --- adr,len,Zadr0,Zadrx ) SWAP ( adr,len,Zadr0,Zadrx --- adr,len,Zadrx,Zadr0 ) >R ( adr,len,Zadrx,Zadr0 --- adr,len,Zadrx ) OVER >R ( adr,len,Zadrx, --- adr,Zadrx,len ) BUFPLACE ( adr,len,Zadrx, --- ) R> ( --- len ) R@ Zcounter 1+! 2+ ( len --- len+2 ) R@ Ztaille +! ( len+2 --- ) R@ Ztaille @ ( --- Taille ) R@ + R@ FreeZadr ! ( taille --- ) R> ( --- Ladr0 ) R> ( Ladr0 --- Ladr0,Ladrx ) SWAP ( Ladr0,Ladrx --- Ladrx,Ladr0 ) R> ( Ladrx,Ladr0, --- Ladrx,Ladr0,n ) SWAP ( Ladrx,Ladr0,n --- Ladrx,n,Ladr0 ) BufLast! ; : APPEND%LINE ( adr,len,Ehandle --- ) \ Ajoute une ligne à la suite d'un enregistrement pointé par EHANDLE. DUP Zcounter @ INSERT%LINE ; : COPY%LINE ( Ehandle,n --- adr,len, ) \ Retourne l'adresse et la longueur de la ligne n de l'enregistrement \ dont le handle est spécifé par Ehandle. 2DUP 2>R GetBline NIP LFCOUNT 2DUP Zstring$ $! Over 2R> ( adrx,lenx --- adrx,lenx,adrx,Ehandle,n ) SWAP ( adrx,lenx,adrx,Ehandle,n --- adrx,lenx,adrx,n,Ehandle ) BufLast! ( adrx,lenx,adrx,n,Ehandle --- adrx,lenx, ) ; : DELETE%LINE ( Zadr0,n --- adr,len, ) \ Supprime une chaine dans un Enregistrement, retourne la chaine supprimée. DUP >R OVER SWAP GetBline LFCOUNT \ On met la ligne sur la pile --- Zadr0,Zadrlx,lenx 2dup Zstring$ $! 2+ >R \ On Sauve la ligne dans Ztring$ taille ligne sur R --- Zadr0,Zadrx, ) \ Calcul adresse début du bloc à déplacer DUP R@ + \ Dupplique Zadrx ajoute lenx +1 --- Zadr0,Zadrx,Zadrdeb ) \ Calcul de la taille du bloc à déplacer 2 PICK FreeZadr @ OVER - \ Prend Zadr0, Cherche freeZadr - 1 soustrait Zadrdeb --- Zadr0,Zadrx,Zadrdeb,lenbx ) -MOVE \ Transfert \ Reorganisation de la liste R> ( Zadr0 --- Zadr0,len+1 ) SWAP ( Zadr0,len+1 --- len+1,Zadr0 ) >R ( len+1,Zadr0 --- len+1 ) R@ Zcounter 1-! -1 * R@ Ztaille +! R@ Ztaille @ R@ SWAP + R@ FreeZadr ! R@ Zmaxtaille@ R@ Ztaille @ - R> FreeZadr @ SWAP BLANK R> 2DUP GETBLINE NIP swap 2 ROLL BufLast! Zstring$ ; : REPLACE%LINE ( adr,len,Ehandle,n --- adr,len, ) \ Place la ligne adr,len, à la position n dans l'enregistrement \ spécifié par EHANDLE. \ L'ancienne ligne dans l'enregistrement est écrasée. La ligne écrasée est pointée par adr,len. 2DUP DELETE%LINE 2DROP INSERT%LINE Zstring$ ; : INIT%BUF ( Ehandle, --- ) \ Efface le contenu de l'enregistrement spécifié par Ehandle, initialise tout \ les pointeurs liés à l'enregistrement. \ >R 1 R@ Zcounter ! \ Initialise le compteur de ligne à 1 2 R@ Ztaille ! \ Initialise la taille de l'enregistrement à 2 R@ 2+ R@ FreeZadr ! \ Initialise la première adresse libre dans l'enregistrement R@ 1 R@ BUFLAST! \ Initialise le pointeur de la dernière ligne accédée R@ R@ Zmaxtaille@ BLANK \ Efface le contenu de l'enregistrement actuel 13 R@ C! \ On compile <CRLF> pour construire une butée basse pour -DECAL 10 R> 1+ C! ; : FILE>BUF ( Filename,Ehandle --- ) \ Chargement de l'enregistrement spécifié par EHANDLE à partir \ d'une mémoire de masse, ( disque dur, disquette, réseau etc... ) \ Filename est le chemin\nom du fichier source. \ Cette fonction initialise complétement l'enregistrement pour les traitements a venir. \ ============== On lit la taille du fichier disque et on teste s'il peut se loger dans l'Enregistrement ============ \ ============== si oui, on installe le fichier. DUP INIT%BUF Ehandle ! R/O OPEN-FILE THROW >R ( c-addr u fam --- ) R@ FILE-SIZE THROW D>S DUP Ehandle @ Zmaxtaille@ > WABORT( EnrMessage02 ) Ehandle @ SWAP R@ READ-FILE ( c-addr u1 fileid --- u2 ior ) THROW Ehandle @ Ztaille ! R> CLOSE-FILE THROW Ehandle @ >R R@ Ztaille @ ( Ehandle ) R@ + 1+ ( Ehandle ) R@ FreeZadr ! \ ============== On initialise les pointeurs de l'enregistrement selon le fichier chargé ============================ PAD OFF EHandle @ BEGIN PAD 1+! LFCOUNT + 2+ DUP Ehandle @ FreeZadr @ >= UNTIL DROP PAD @ Ehandle @ Zcounter ! 13 R@ Ztaille @ R@ + C! \ Ajoute une fermeture de ligne LFCR en fin d'enregistrement 10 R@ Ztaille @ R@ + 1+ C! 2 R@ FREEZADR +! 2 R> Ztaille +! ; : BUF! ( Ehandle1 to Ehandle2 --- ) \ Copie un enregistrement Ehandle1 vers un enregistrement Ehandle2. \ Le contenu précédent de l'enregistrement destination est écrasé. OVER Ztaille @ OVER Zmaxtaille@ > ( Ehandle1,Ehandle2, --- Ehandle1,Ehandle2,flag ) WABORT( EnrMessage03 ) ( Ehandle1,Ehandle2,flag --- Ehandle1,Ehandle2, ) DUP INIT%BUF ( Ehandle1,Ehandle2, --- Ehandle1,Ehandle2, ) OVER DUP Ztaille @ 2 PICK SWAP MOVE ( Ehandle1,Ehandle2, --- Ehandle1,Ehandle2, ) OVER Ztaille @ OVER Ztaille ! OVER FreeZadr @ OVER FreeZadr ! OVER Zcounter @ OVER Zcounter ! 2DROP ; : BUF>FILE ( Ehandle,Filename --- ) \ Transfert de l'enregistrement spécifié par EHANDLE vers la mémoire de masse. \ ( disque dur, disquette, réseau etc... ) WORK$ ERASE$ WORK$ $! EHANDLE ! WORK$ R/W CREATE-FILE 0<> ABORT" Erreur Fichier" >R EHANDLE @ DUP Ztaille @ R@ WRITE-FILE THROW R> CLOSE-FILE THROW ; : FINDFIRSTWORD ( adr,len,Ehandle --- Zstring$,n ) \ Cherche un mot dans un Texte buffer, retourne n, numéro de la \ ligne ou le mot est trouvé. Zstring$ contient la ligne pour exploitation s'il y a lieu. \ Si le mot est trouvé n est différent de zéro si non n = 0 \ Le mot FINDFIRSTWORD initialise le pointeur BufLast sur la première ligne. On pourra se servir \ de buflast pour procéder à une recherche séquentielle dans le buffer de texte. Voir le mot \ FINDNEXTWORD FindFlag OFF EHANDLE ! WORK$ $! EHANDLE @ Zcounter @ 1 ?DO EHANDLE @ I COPY%LINE ( Ehandle,n --- adr,len, ) WORK$ SEARCH(NC) NIP NIP IF I FindFlag ! LEAVE THEN LOOP Zstring$ FindFlag @ ; : FINDNEXTWORD ( adr,len,Ehandle --- Zstring$,n ) \ Cherche un mot dans un texte buffer. La recherche commence \ à partir de la position suivante pointée par BUFLAST@. Si le mot recherché est trouvé, alors \ n est le numéro de la ligne contenant ce mot. Zstring$ contient cette ligne pour un traitement \ éventuel. FindFlag OFF EHANDLE ! WORK$ $! EHANDLE @ Zcounter @ EHANDLE @ BufLast@ NIP ?DO EHANDLE @ I COPY%LINE ( Ehandle,n --- adr,len, ) WORK$ SEARCH(NC) IF I FindFlag ! LEAVE THEN LOOP Zstring$ FindFlag @ ; : TYPE%BUF ( Ehandle --- ) \ Affiche le contenu d' un enregistrement DUP Zcounter @ 0 ?DO LFCOUNT 2DUP CR TYPE + 2+ LOOP DROP ; \\
-----
Envoyé par Ludwig1 
