TP3/Resources/DESASS/ZONES.PAS

(* programme comment‚ et expliqu‚ dans le livre *)
(* LE DESASSEMBLEUR 8086 COLIBRI, publi‚ par    *)
(*           L'INSTITUT PASCAL:                 *)
(*      26 Rue Lamartine, 75009 PARIS           *)
(*           Tel: (1) 42.85.10.82               *)


(*$r+*)
program gestion_zones_de_desassemblage;
  type string2= string[2];
       string4= string[4];
       string64= string[64];
       string127= string[127];
       set_of_char= set of char;

       t_fiche= record
                  debut: integer;
                  type_zone: char;
                end;

       t_pointeur_zone= ^t_cellule_zone;
       t_cellule_zone= record
                         debut: integer;
                         type_zone: char;
                         numero_fiche: integer;
                         pt_inferieurs, pt_superieurs: t_pointeur_zone;
                       end;

  var choix, choix1: char;

      nom_fichier: string64;
      fiche: t_fiche;
      fichier: file of t_fiche;
      resultat_entree_sortie: byte;

      racine_zones: t_pointeur_zone;
      sommet_tas: ^integer;

  procedure stop;
    var l_stop: char;
    begin
      read(kbd, l_stop);
    end; 

  function f_octet_hexadecimal(p_octet: byte): string2;
    const kt_hexa: array[0..15] of char= '0123456789ABCDEF';
    begin
      f_octet_hexadecimal:= concat(kt_hexa[p_octet div 16],
                                      kt_hexa[p_octet mod 16]);
    end; 

  function f_entier_hexadecimal(p_entier: integer): string4;
    begin
      f_entier_hexadecimal:= concat(f_octet_hexadecimal(hi(p_entier)),
                                    f_octet_hexadecimal(lo(p_entier)));
    end; 

  function f_lis_commande(p_ensemble_ok: set_of_char): char;
    var l_touche: char;
    begin
      repeat
        read(kbd, l_touche);
        l_touche:= upcase(l_touche); write(l_touche);
      until l_touche in p_ensemble_ok;
      f_lis_commande:= l_touche;
    end; 

  function f_fichier_existe(p_nom_fichier: string64): boolean;
    begin
      assign(fichier, p_nom_fichier);
      (*$i-*)
      reset(fichier);
      (*$i+*)
      f_fichier_existe:= ioresult= 0;
      close(fichier);
    end; 

  procedure change_nom_fichier;
    begin
      write('nom <a:zones.dta> ? '); readln(nom_fichier);
    end; 

  procedure cree_fichier;
    begin
      if f_fichier_existe(nom_fichier)
        then begin
            writeln;
            write('le fichier existe d‚j…. D‚truire, Quitter ? ');
            if f_lis_commande(['D', 'Q'])<> 'D'
              then begin
                  writeln;
                  exit;
                end;
          end;

      assign(fichier, nom_fichier);
      rewrite(fichier);
      close(fichier);
    end; 

  procedure ouvre_fichier;
    begin
      assign(fichier, nom_fichier);
      (*$i-*)
      reset(fichier);
      (*$i+*)
      resultat_entree_sortie:= ioresult;
      if resultat_entree_sortie<> 0
        then writeln('le fichier ', nom_fichier, ' n''a pas ‚t‚ ouvert');
    end; 

  procedure affiche_fiche(p_numero, p_debut: integer; p_type_zone: char);
    begin
      write(p_numero: 5);
      write(' $', f_entier_hexadecimal(p_debut));
      write(p_type_zone: 2);
    end; 

  procedure liste_fichier;
    var l_numero_fiche: integer;
        l_dernier_numero: integer;
    begin
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;

      repeat
        write('num‚ro d‚but <0> ? '); readln(l_numero_fiche);
      until (l_numero_fiche>= 0) and (l_numero_fiche< filesize(fichier));
      write('num‚ro fin  <', filesize(fichier)- 1, '> ? '); readln(l_dernier_numero);
      seek(fichier, l_numero_fiche);

      while not eof(fichier) and (l_numero_fiche<= l_dernier_numero) do
      begin
        read(fichier, fiche);

        with fiche do
          affiche_fiche(l_numero_fiche, debut, type_zone);
        writeln;

        l_numero_fiche:= l_numero_fiche+ 1;
      end;

      close(fichier);
    end; 

  procedure ajoute_fichier;
    begin
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;

      seek(fichier, filesize(fichier));

      repeat
        writeln;
        writeln('ajoute la fiche: ', filepos(fichier));
        write('adresse d‚but <$1234> ? '); readln(fiche.debut);
        repeat
          write('type Code, Ascii, Hex ? ');
          read(kbd, fiche.type_zone); writeln(fiche.type_zone);

          if fiche.type_zone in ['A', 'H', 'C']
            then fiche.type_zone:= chr(ord(fiche.type_zone)+ 32);
        until fiche.type_zone in ['c', 'h', 'a'];

        write(fichier, fiche);

        write('Continuer, Quitter ? ');
        read(kbd, choix1); writeln(choix1);
      until upcase(choix1)= 'Q';

      close(fichier);
    end; 

  procedure modifie_fichier;
    var l_numero_fiche: integer;
    begin
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;

      repeat
        writeln;
        repeat
          write('modifie la fiche num‚ro <0..', filesize(fichier)- 1, '> ? ');
          readln(l_numero_fiche);
        until (l_numero_fiche>= 0) and (l_numero_fiche<= filesize(fichier));

        seek(fichier, l_numero_fiche); read(fichier, fiche);

        with fiche do
          affiche_fiche(l_numero_fiche, debut, type_zone);
        writeln;

        write('adresse d‚but <$1234> ? '); readln(fiche.debut);
        repeat
          write('type Code, Ascii, Hex ? ');
          read(kbd, fiche.type_zone); writeln(fiche.type_zone);

          if fiche.type_zone in ['A', 'H', 'C']
            then fiche.type_zone:= chr(ord(fiche.type_zone)+ 32);
        until fiche.type_zone in ['c', 'h', 'a', '?'];

        seek(fichier, l_numero_fiche); write(fichier, fiche);

        write('Continuer, Quitter ? ');
        read(kbd, choix1); writeln(choix1);
      until upcase(choix1)= 'Q';

      close(fichier);
    end; 

  procedure supprime_fiche;
    var l_numero_fiche: integer;
    begin
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;

      repeat
        writeln;
        repeat
          write('supprimer la fiche num‚ro <0..', filesize(fichier)- 1, '> ? ');
          readln(l_numero_fiche);
        until (l_numero_fiche>= 0) and (l_numero_fiche< filesize(fichier));

        seek(fichier, l_numero_fiche); read(fichier, fiche);

        with fiche do
          affiche_fiche(l_numero_fiche, debut, type_zone);

        write('. sUpprime ? '); read(kbd, choix1); writeln(choix1);
        if upcase(choix1)= 'U'
          then begin
              fiche.type_zone:= '?';
              seek(fichier, l_numero_fiche); write(fichier, fiche);
            end;

        write('Continuer, Quitter ? ');
        read(kbd, choix1); writeln(choix1);
      until upcase(choix1)= 'Q';

      close(fichier);
    end; 

  procedure ajoute_depuis_fichier_text;

    var l_entree: text;
        l_nom_entree: string64;
        l_ligne_entree: string127;

        l_indice: integer;
        l_debut: integer;
        l_type: char;
        l_erreur_numerique: boolean;
        l_erreur_entree: boolean;
        l_fin_fichier_actuelle: integer;

    procedure calcule_debut;
      var l_caractere: char;
      begin
        l_erreur_numerique:= false;
        l_debut:= 0;
        repeat
          l_caractere:= upcase(l_ligne_entree[l_indice]);
          if l_caractere in ['0'..'9']
            then l_debut:= l_debut* 16+ ord(l_caractere)- 48
            else
              if l_caractere in ['A'..'F']
                then l_debut:= l_debut* 16+ ord(l_caractere)- 55
                else
                  if l_caractere<> ' '
                    then l_erreur_numerique:= true;
          l_indice:= l_indice+ 1;
        until l_erreur_numerique or (l_caractere= ' ');
      end; 

    begin 
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;
      seek(fichier, filesize(fichier));
      l_fin_fichier_actuelle:= filesize(fichier);

      write('nom du fichier d''entr‚e <zones.pas> ? '); readln(l_nom_entree);
      assign(l_entree, l_nom_entree);
      (*$i-*)
      reset(l_entree);
      (*$i+*)
      if ioresult<> 0
        then begin
            write('erreur ouverture ', l_nom_entree);
            close(l_entree);
            close(fichier);
            exit;
          end;

      l_erreur_entree:= false;

      while not eof(l_entree) do
      begin
        writeln;
        readln(l_entree, l_ligne_entree);
        write(l_ligne_entree);

        if length(l_ligne_entree)> 0
          then
            if l_ligne_entree[1]= '$'
              then begin
                  l_indice:= 2;

                  calcule_debut;
                  if l_erreur_numerique
                    then begin
                        writeln; write('^': l_indice);
                        write(' erreur num‚rique');
                        l_erreur_entree:= true;
                      end
                    else begin
                        while l_ligne_entree= ' ' do
                          l_indice:= l_indice+ 1;

                        l_type:= l_ligne_entree[l_indice];
                        if not (l_type in ['c', 'h', 'a'])
                          then begin
                              writeln; write('^': l_indice);
                              write(' erreur de type de zone: que c a h');
                              l_erreur_entree:= true;
                            end
                          else begin
                              fiche.debut:= l_debut;
                              fiche.type_zone:= l_type;
                              write(fichier, fiche);
                              write(' ok. A ajout‚');
                            end; 
                      end; 
                end 
              else write('ne commence pas par $');

        writeln;
      end;

      if l_erreur_entree
        then begin
            writeln('Il y a eu des erreurs. Supprime toutes les entr‚es');
            stop;

            seek(fichier, l_fin_fichier_actuelle);
            truncate(fichier);
          end;
      close(fichier);

      close(l_entree);
    end; 

  procedure construis_index;
    var l_numero_fiche: integer;
        l_adresse_debut, l_adresse_fin: integer;

    procedure ajoute(var p: t_pointeur_zone);
      begin
        if p= nil
          then begin
              new(p);
              p^.debut:= fiche.debut;
              p^.type_zone:= fiche.type_zone;
              p^.numero_fiche:= l_numero_fiche;
              p^.pt_inferieurs:= nil; p^.pt_superieurs:= nil;
            end
          else
            if fiche.debut- $8000< p^.debut- $8000
              then ajoute(p^.pt_inferieurs)
              else
                if fiche.debut- $8000> p^.debut- $8000
                  then ajoute(p^.pt_superieurs)
                  else begin
                      writeln('mˆme d‚but. Ajouter ? ');
                      read(kbd, choix1); writeln(choix1);
                      if upcase(choix1)= 'a'
                        then ajoute(p^.pt_superieurs);
                    end;
      end; 

    begin 
      ouvre_fichier;
      if resultat_entree_sortie<> 0
        then exit;

      l_numero_fiche:= 0;
      write('adresse d‚but <$1234> ? '); readln(l_adresse_debut);
      write('adresse fin   <$ABCD> ? '); readln(l_adresse_fin);

      release(sommet_tas);
      racine_zones:= nil;

      while not eof(fichier) do
      begin
        read(fichier, fiche);

        with fiche do
        begin
          if (debut- $8000>= l_adresse_debut- $8000) and (debut- $8000<= l_adresse_fin- $8000)
            then begin
                affiche_fiche(l_numero_fiche, debut, type_zone);

                if fiche.type_zone in ['a', 'h', 'c']
                  then ajoute(racine_zones)
                  else write(' -- non ajout‚');
                writeln;
              end
        end;
        l_numero_fiche:= l_numero_fiche+ 1;
      end;

      close(fichier);
    end; 

  procedure liste_index;

    procedure affiche(p: t_pointeur_zone);
      begin
        if p<> nil
          then begin
              affiche(p^.pt_inferieurs);

              with p^ do
                affiche_fiche(numero_fiche, debut, type_zone);
              writeln;

              affiche(p^.pt_superieurs);
            end;
      end; 

    begin 
      affiche(racine_zones);
    end; 

  procedure interroge_index;
    var l_adresse_debut, l_adresse_fin: integer;
        l_premiere_adresse: boolean;
        l_numero_fiche: integer;
        l_doit_ajouter_fin: boolean;
        l_type_zone: char;

    procedure affiche(p: t_pointeur_zone);
      begin
        if p<> nil
          then begin
              affiche(p^.pt_inferieurs);

              with p^ do
              begin
                if (debut- $8000>= l_adresse_debut- $8000)
                     and (debut- 1- $8000<= l_adresse_fin- $8000)
                  then begin
                      if l_premiere_adresse
                        then l_premiere_adresse:= false
                        else begin
                            writeln(f_entier_hexadecimal(debut- 1),
                                    l_type_zone: 2);
                            l_doit_ajouter_fin:= false;
                          end;

                      if (debut- $8000<= l_adresse_fin- $8000)
                        then begin
                            write(numero_fiche: 4, ' $', f_entier_hexadecimal(debut), '-');
                            l_type_zone:= type_zone;
                            l_doit_ajouter_fin:= true;
                          end;
                    end;
              end;

              affiche(p^.pt_superieurs);
            end;
      end; 

    begin 
      write('adresse d‚but <$1234> ? '); readln(l_adresse_debut);
      write('adresse fin   <$ABCD> ? '); readln(l_adresse_fin);

      l_premiere_adresse:= true;
      l_doit_ajouter_fin:= false;
      affiche(racine_zones);
      if l_doit_ajouter_fin
        then writeln(f_entier_hexadecimal(l_adresse_fin), l_type_zone: 2);
    end; 

  procedure initialise;
    begin
      nom_fichier:= 'zones.dta';

      mark(sommet_tas);
      racine_zones:= nil;
    end; 

  begin 
    initialise;
    repeat
      writeln;
      writeln(nom_fichier);
      writeln('Cr‚e, Ajoute, Liste, Modifie, sUupprime, Nom');
      writeln('aJoute depuis text');
      write  ('Tri, liSte index, Interroge, Quitte ? ');

      read(kbd, choix); writeln(choix); choix:= upcase(choix);

      case choix of
       'A' : ajoute_fichier;
       'C' : cree_fichier;
       'I' : interroge_index;
       'J' : ajoute_depuis_fichier_text;
       'L' : liste_fichier;
       'M' : modifie_fichier;
       'N' : change_nom_fichier;
       'R' : supprime_fiche;
       'S' : liste_index;
       'T' : construis_index;
       'U' : supprime_fiche;
      end;
    until choix= 'Q';
  end.