(* 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               *)


  procedure ouvre_fichier_labels;
    begin
      b_fichier_labels_ouvert:= true;
      (*$i-*)
      assign(fichier_labels, nom_fichier_labels);
      reset(fichier_labels);
      (*$i+*)
      if ioresult<> 0
        then begin
            write('pas de fichier ', nom_fichier_labels, ' Cr‚er ? ');
            choix1:= f_lis_commande(['C', 'Q']);
            if choix1= 'C'
              then begin
                 assign(fichier_labels, nom_fichier_labels);
                 rewrite(fichier_labels);
               end
             else b_fichier_labels_ouvert:= false;
          end
        else writeln('a ouvert le fichier ', nom_fichier_labels);
    end; 

  procedure ajoute_fin_fichier_labels(p_adresse: integer; p_type_label: t_type_label);
    begin
      if not b_fichier_labels_ouvert
        then exit;

      fiche_label.adresse:= p_adresse;
      fiche_label.type_label:= p_type_label;
      fiche_label.nom:= '';

      seek(fichier_labels, filesize(fichier_labels));
      write(fichier_labels, fiche_label);
    end; 

  procedure modifie_type_fiche_labels(p_numero_fiche: integer; p_type_label: t_type_label);
    var l_fiche_label: t_fiche_label;
    begin
      if not b_fichier_labels_ouvert
        then exit;

      seek(fichier_labels, p_numero_fiche);
      read(fichier_labels, l_fiche_label);

      l_fiche_label.type_label:= p_type_label;

      seek(fichier_labels, p_numero_fiche);
      write(fichier_labels, l_fiche_label);
    end; 

  procedure modifie_fiche_labels(p_numero_fiche: integer;
                        p_nom: string15; p_type_label: t_type_label);
    var l_fiche_label: t_fiche_label;
    begin
      if not b_fichier_labels_ouvert
        then exit;

      seek(fichier_labels, p_numero_fiche);
      read(fichier_labels, l_fiche_label);

      l_fiche_label.nom:= p_nom;
      l_fiche_label.type_label:= p_type_label;

      seek(fichier_labels, p_numero_fiche);
      write(fichier_labels, l_fiche_label);
    end; 

  function f_normalise_label(p_nom: string15): string15;
    var l_indice: integer;
    begin
      for l_indice:= length(p_nom)+ 1 to 15 do
        p_nom:= concat(p_nom, ' ');
      f_normalise_label:= p_nom;
    end; 

  procedure ajoute_reference(p_pointeur: t_pointeur_label);
    var l_pt_auxiliaire: t_pointeur_reference;
    begin
      new(l_pt_auxiliaire);
      l_pt_auxiliaire^.adresse:= adresse_debut_ligne;
      l_pt_auxiliaire^.suivante:= nil;

      if p_pointeur^.pt_reference= nil
        then 
             p_pointeur^.pt_reference:= l_pt_auxiliaire
        else 
             p_pointeur^.pt_derniere_reference^.suivante:= l_pt_auxiliaire;

      p_pointeur^.pt_derniere_reference:= l_pt_auxiliaire;
    end; 

  function f_construis_label(p_adresse: integer; p_type_label: t_type_label): string15;
    var l_label: string15;
    begin
      l_label:= concat('C__', f_entier_hexadecimal(p_adresse), '        ');
      case p_type_label of
        call_valide_instruction : l_label[2]:= 'i';
        call_valide : ;
        call_instruction : begin
                             l_label[1]:= 'c';
                             l_label[2]:= 'i';
                           end;
        call : l_label[1]:= 'c';
        relatif_instruction : begin
                                l_label[1]:= 'r';
                                l_label[2]:= 'i';
                              end;
        relatif : l_label[1]:= 'r';
      end; 
      f_construis_label:= l_label;
    end; 

  function f_ajoute_label_call(p_adresse: integer): string15;
    var l_type_label: t_type_label;

    procedure teste_apres_ret_jmp;
      var l_indice_tampon: integer;
      begin
        l_indice_tampon:= p_adresse- adresse_debut_tampon;
        if (l_indice_tampon- 3> 0) and (l_indice_tampon< $7FFF)
          then
            if (tampon[l_indice_tampon- 1]= $C3) 
                or (tampon[l_indice_tampon- 2]= $EB) 
                or (tampon[l_indice_tampon- 3]= $E9) 
                or (tampon[l_indice_tampon- 3]= $C2) 
              then l_type_label:= call_valide
              else l_type_label:= call
          else l_type_label:= call;
      end; 

    procedure ajoute_label(var pv_pointeur: t_pointeur_label);

      procedure modifie_label_deja_entre;
        var l_mettre_a_jour: boolean;
        begin
          l_mettre_a_jour:= false;

          if pv_pointeur^.type_label in [relatif_instruction, relatif]
            then begin
                if pv_pointeur^.type_label= relatif_instruction
                  then
                    if l_type_label= call_valide
                      then l_type_label:= call_valide_instruction
                      else l_type_label:= call_instruction;
                l_mettre_a_jour:= true;
              end
            else
              if (l_type_label= call_valide)
                  and (pv_pointeur^.type_label= call_instruction)
                then begin
                    l_type_label:= call_valide_instruction;
                    l_mettre_a_jour:= true;
                  end;

          if l_mettre_a_jour
            then begin
                if pv_pointeur^.numero_fiche= -1
                  then begin
                      pv_pointeur^.numero_fiche:= filesize(fichier_labels);
                      ajoute_fin_fichier_labels(p_adresse, l_type_label);
                    end
                  else modifie_type_fiche_labels(pv_pointeur^.numero_fiche, l_type_label);
                pv_pointeur^.type_label:= l_type_label;
              end;
        end; 

      begin 
        if pv_pointeur= nil
          then begin
              new(pv_pointeur);
              pv_pointeur^.adresse:= p_adresse;
              pv_pointeur^.type_label:= l_type_label;
              pv_pointeur^.nom:= nil;
              pv_pointeur^.numero_fiche:= filesize(fichier_labels);
              pv_pointeur^.pt_labels_inferieurs:= nil; pv_pointeur^.pt_labels_superieurs:= nil;
              pv_pointeur^.pt_reference:= nil;

              if b_reference_label
                then ajoute_reference(pv_pointeur);

              ajoute_fin_fichier_labels(p_adresse, l_type_label);

              f_ajoute_label_call:= f_construis_label(p_adresse, l_type_label);
            end
          else 
            if p_adresse< pv_pointeur^.adresse
              then ajoute_label(pv_pointeur^.pt_labels_inferieurs)
              else
                if p_adresse> pv_pointeur^.adresse
                  then ajoute_label(pv_pointeur^.pt_labels_superieurs)
                  else begin
                      if b_reference_label
                        then ajoute_reference(pv_pointeur);

                      if pv_pointeur^.nom= nil
                        then begin
                            modifie_label_deja_entre;
                            f_ajoute_label_call:= f_construis_label(p_adresse,
                                    pv_pointeur^.type_label);
                          end
                        else f_ajoute_label_call:= f_normalise_label(pv_pointeur^.nom^);
                    end; 
      end; 

    begin 
      teste_apres_ret_jmp;

      ajoute_label(racine_label);
    end; 

  function f_ajoute_label_relatif(p_adresse: integer): string15;

    procedure ajoute_label(var pv_pointeur: t_pointeur_label);
      begin
        if pv_pointeur= nil
          then begin
              new(pv_pointeur);
              pv_pointeur^.adresse:= p_adresse;
              pv_pointeur^.type_label:= relatif;
              pv_pointeur^.nom:= nil;
              pv_pointeur^.numero_fiche:= -1;
              pv_pointeur^.pt_labels_inferieurs:= nil; pv_pointeur^.pt_labels_superieurs:= nil;
              pv_pointeur^.pt_reference:= nil;

              if b_reference_label
                then ajoute_reference(pv_pointeur);

              f_ajoute_label_relatif:= f_construis_label(p_adresse, relatif);
            end 
          else
            if p_adresse< pv_pointeur^.adresse
              then ajoute_label(pv_pointeur^.pt_labels_inferieurs)
              else
                if p_adresse> pv_pointeur^.adresse
                  then ajoute_label(pv_pointeur^.pt_labels_superieurs)
                  else begin
                      if b_reference_label
                        then ajoute_reference(pv_pointeur);

                      if pv_pointeur^.nom= nil
                        then f_ajoute_label_relatif:=
                             f_construis_label(p_adresse,
                                               pv_pointeur^.type_label)
                        else f_ajoute_label_relatif:= f_normalise_label(pv_pointeur^.nom^);
                    end; 
      end; 

    begin 
      ajoute_label(racine_label);
    end; 

  function f_label_debut_ligne(p_adresse: integer): string15;
    var l_pt_courant: t_pointeur_label;

    procedure modifie_label_deja_entre;
      begin
        case l_pt_courant^.type_label of
          call_valide : begin
                          l_pt_courant^.type_label:= call_valide_instruction;
                          modifie_type_fiche_labels(l_pt_courant^.numero_fiche,
                                                   call_valide_instruction);
                        end;
          call : begin
                   l_pt_courant^.type_label:= call_instruction;
                   modifie_type_fiche_labels(l_pt_courant^.numero_fiche,
                                             call_instruction);
                 end;
          relatif : begin
                      l_pt_courant^.type_label:= relatif_instruction;
                      ajoute_fin_fichier_labels(p_adresse, relatif_instruction);
                    end;
        end; 
      end; 

    begin 
      l_pt_courant:= racine_label;
      while (l_pt_courant<> nil) and (l_pt_courant^.adresse<> p_adresse) do
        if p_adresse< l_pt_courant^.adresse
          then l_pt_courant:= l_pt_courant^.pt_labels_inferieurs
          else
            if p_adresse> l_pt_courant^.adresse
              then l_pt_courant:= l_pt_courant^.pt_labels_superieurs;

      if l_pt_courant= nil
        then begin
            f_label_debut_ligne:= '               '
          end
        else begin
            if l_pt_courant^.nom= nil
              then begin
                  modifie_label_deja_entre;
                  f_label_debut_ligne:= f_construis_label(p_adresse,
                        l_pt_courant^.type_label);
                end
              else 
                   f_label_debut_ligne:= f_normalise_label(l_pt_courant^.nom^);
          end; 
    end; 

  procedure ajoute_label_donnees(p_adresse: integer;
                                 var pv_pointeur: t_pointeur_label;
                                 p_ajoute_reference: boolean;
                                 var pv_nom: string15;
                                 p_octet_mot: t_octet_mot);

    procedure ajoute(var pv_pointeur: t_pointeur_label);
      begin
        if pv_pointeur= nil
          then begin
              new(pv_pointeur);
              pv_pointeur^.adresse:= p_adresse;
              pv_pointeur^.type_label:= utilisateur_donnee;
              pv_pointeur^.nom:= nil;
              pv_pointeur^.numero_fiche:= -1;
              pv_pointeur^.pt_labels_inferieurs:= nil; pv_pointeur^.pt_labels_superieurs:= nil;
              pv_pointeur^.pt_reference:= nil;

              if p_ajoute_reference
                then ajoute_reference(pv_pointeur);

              if p_octet_mot= octet
                then pv_nom:= concat('$', f_octet_hexadecimal(p_adresse))
                else pv_nom:= concat('$', f_entier_hexadecimal(p_adresse));
            end
          else
            if p_adresse< pv_pointeur^.adresse
              then ajoute(pv_pointeur^.pt_labels_inferieurs)
              else
                if p_adresse> pv_pointeur^.adresse
                  then ajoute(pv_pointeur^.pt_labels_superieurs)
                  else begin 
                      if pv_pointeur^.nom<> nil
                        then pv_nom:= pv_pointeur^.nom^
                        else
                          if p_octet_mot= octet
                            then pv_nom:= concat('$', f_octet_hexadecimal(p_adresse))
                            else pv_nom:= concat('$', f_entier_hexadecimal(p_adresse));

                      if p_ajoute_reference
                        then ajoute_reference(pv_pointeur);
                    end;
      end; 

    begin 
      ajoute(pv_pointeur);
    end; 

  procedure charge_fichier_labels;
    var l_label_minimum, l_label_maximum: integer;
        l_choix: char;

    procedure charge_labels;
      var l_numero_fiche, l_nombre_fiches_chargees, adresse: integer;

      procedure ajoute_label(var pv_pointeur: t_pointeur_label);

        procedure traite_deja;
          begin 
            if pv_pointeur^.nom<> nil
              then begin
                  if (fiche_label.nom<> pv_pointeur^.nom^)
                    then begin
                        with pv_pointeur^ do
                          write(numero_fiche:4, nom^, ' et ');
                        write(l_numero_fiche:4, fiche_label.nom, ' incoh‚rents');;
                        stop; writeln; exit;
                      end;

                end
              else
                if fiche_label.nom<> ''
                  then begin
                      new(pv_pointeur^.nom);
                      with pv_pointeur^ do
                      begin
                        nom^:= fiche_label.nom;
                        modifie_fiche_labels(numero_fiche, nom^, type_label);
                      end;
                    end;

            if fiche_label.type_label> pv_pointeur^.type_label
              then
                with pv_pointeur^ do
                begin
                  type_label:= fiche_label.type_label;
                  modifie_type_fiche_labels(numero_fiche, type_label);
                end;

            modifie_type_fiche_labels(l_numero_fiche, deja);
          end; 

        begin 
          if pv_pointeur= nil
            then begin
                new(pv_pointeur);
                with pv_pointeur^ do
                begin
                  adresse:= fiche_label.adresse;
                  numero_fiche:= l_numero_fiche;

                  type_label:= fiche_label.type_label;
                  if fiche_label.nom= ''
                    then nom:= nil
                    else begin
                        new(nom);
                        nom^:= fiche_label.nom;
                      end;
                  pt_labels_inferieurs:= nil; pt_labels_superieurs:= nil;
                  pt_reference:= nil;

                  l_nombre_fiches_chargees:= l_nombre_fiches_chargees+ 1;
                end;
              end
            else
              if fiche_label.adresse< pv_pointeur^.adresse
                then ajoute_label(pv_pointeur^.pt_labels_inferieurs)
                else
                  if fiche_label.adresse> pv_pointeur^.adresse
                    then ajoute_label(pv_pointeur^.pt_labels_superieurs)
                    else traite_deja;
        end; 

      begin 
        writeln('charge ', filesize(fichier_labels), ' fiches');
        seek(fichier_labels, 0);

        l_numero_fiche:= 0;
        l_nombre_fiches_chargees:= 0;

        while not eof(fichier_labels) do
        begin
          write('.');
          read(fichier_labels, fiche_label);

          if fiche_label.type_label<= deja
            then begin
                if (fiche_label.adresse-$8000>= l_label_minimum-$8000)
                      and (fiche_label.adresse-$8000<= l_label_maximum- $8000)
                  then begin
                      if fiche_label.type_label= utilisateur_donnee
                        then ajoute_label(racine_donnees)
                        else
                          if (fiche_label.type_label<= utilisateur_code)
                            then ajoute_label(racine_label);

                    end
              end;

          l_numero_fiche:= l_numero_fiche+ 1;
        end;
        writeln('  a charg‚: ', l_nombre_fiches_chargees);
      end; 

    begin 
      if not b_fichier_labels_ouvert
        then begin
            writeln('fichier de labels ', nom_fichier_labels, ' pas ouvert');
            exit;
          end;

      l_label_minimum:= $0; l_label_maximum:= $FFFF;
      repeat
        writeln;
        write('de $', f_entier_hexadecimal(l_label_minimum));
        writeln(' … $', f_entier_hexadecimal(l_label_maximum));
        write('Minimum, mAximum, charge laBels, Quitte ? ');
        l_choix:= f_lis_commande(['B', 'C', 'M', 'A', 'Q', ' ', k_return]);
        writeln;

        case l_choix of
         'A' : begin
                 writeln; write('adresse maximum: <$1234> ? $');
                 lis_entier_hexadecimal(29, wherey, l_label_maximum);
               end;
         'B', 'C' : charge_labels;
         'M' : begin
                 writeln; write('adresse minimum: <$5678> ? $');
                 lis_entier_hexadecimal(29, wherey, l_label_minimum);
               end;
        end; 
      until l_choix in ['B', 'Q', 'C'];
      writeln;
    end; 

  procedure liste_labels;
    type t_liste= (tous, que_code, que_donnees, que_immediats, que_noms);

    procedure liste_les_labels(p_type_liste: t_liste;
                               p1_pointeur: t_pointeur_label);

      procedure liste_label(p_pointeur: t_pointeur_label);

        procedure liste_references;
          var l_numero_reference: integer;
              l_pt_courant: t_pointeur_reference;
          begin
            l_pt_courant:= p_pointeur^.pt_reference;
            if l_pt_courant= nil
              then writeln(sortie)
              else begin
                  l_numero_reference:= 0;
                  while l_pt_courant<> nil do
                  begin
                    if ((l_numero_reference mod 8)= 0) and (l_numero_reference<> 0)
                      then write(sortie, '':23);

                    write(sortie, ' ', f_entier_hexadecimal(l_pt_courant^.adresse));

                    l_pt_courant:= l_pt_courant^.suivante;
                    l_numero_reference:= l_numero_reference+ 1;
                    if l_numero_reference mod 8= 0
                      then writeln(sortie);
                  end;

                  if l_numero_reference mod 8<> 0
                    then writeln(sortie);
                end;
          end; 

        begin 
          if p_pointeur<> nil
            then begin
                liste_label(p_pointeur^.pt_labels_inferieurs);

                if (p_type_liste= tous)
                    or ((p_type_liste= que_code) and (p1_pointeur= racine_label))
                    or ((p_type_liste= que_donnees) and (p1_pointeur= racine_donnees))
                    or ((p_type_liste= que_immediats) and (p1_pointeur= racine_immediat))
                    or ((p_type_liste= que_noms) and (p_pointeur^.nom<> nil))
                  then begin
                      write(sortie, '$', f_entier_hexadecimal(p_pointeur^.adresse), ' ');

                      case p_pointeur^.type_label of
                        call_valide_instruction : write(sortie, 'Ci');
                        call_valide :             write(sortie, 'C ');
                        call_instruction :        write(sortie, 'ci');
                        call        :             write(sortie, 'c ');
                        relatif_instruction :     write(sortie, 'ri');
                        relatif :                 write(sortie, 'r ');
                        utilisateur_code :        write(sortie, 'uc');
                        utilisateur_donnee :      write(sortie, 'ud');
                        else                      write(sortie, '  ');
                      end; 

                      if p_pointeur^.nom= nil
                        then write(sortie, '': 16)
                        else write(sortie, ' ', f_normalise_label(p_pointeur^.nom^));
                      liste_references;
                    end; 

                liste_label(p_pointeur^.pt_labels_superieurs);
              end;
        end; 

      begin 
        liste_label(p1_pointeur);
      end; 

    procedure genere_equates(p_pointeur: t_pointeur_label);
      begin 
        if p_pointeur<> nil
          then begin
              genere_equates(p_pointeur^.pt_labels_inferieurs);

              if p_pointeur^.nom<> nil
                then begin
                    write(sortie, f_normalise_label(p_pointeur^.nom^));
                    write(sortie, ' equ    $');
                    write(sortie, f_entier_hexadecimal(p_pointeur^.adresse));
                    writeln(sortie);
                  end;

              genere_equates(p_pointeur^.pt_labels_superieurs);
            end;
      end; 

    begin 
      writeln;
      writeln('liste: Tous, Code, Donn‚es, Imm‚diats, Noms');
      write('G‚n‚re fichier equates pour r‚assemblage ? ');
      choix1:= f_lis_commande(['T', 'C', 'D', 'I', 'G', 'N', 'Q', ' ']);
      writeln(sortie);
      case choix1 of
       'D' : liste_les_labels(que_donnees, racine_donnees);
       'G' : genere_equates(racine_label);
       'I' : liste_les_labels(que_immediats, racine_immediat);
       'N' : begin
               liste_les_labels(que_noms, racine_label);
               writeln(sortie);
               liste_les_labels(que_noms, racine_donnees);
             end;
       'T' : begin
               writeln(sortie);
               liste_les_labels(tous, racine_label);
               writeln(sortie);
               liste_les_labels(tous, racine_donnees);
               writeln(sortie);
               liste_les_labels(tous, racine_immediat);
             end;
      end; 
      writeln(sortie);
    end;