(*******************************************************************************

    :Program.    Originalname		: ModList.mod
    :Program.    Vorschlag (A.Lüdtke)	: M2P.mod
    :Contents.   Ausdrucken von Modula-Sources mit Hervorhebung der
    :Contents.   Modula-Schlüsselwörter und Kommentare
    :Author.     Ursprüngliche PC-Version: CHIP/Tool-Praxis Modula-2/Sonderheft
    :Author.     Amiga-Version: Andreas Kopp
    :Author.     Anpassung an Amiga-Druckertreiber : Nicolas Benezan [bne]
    :Address.    Andreas Kopp, Grünbaumstrasse 83  D-5650 Solingen 1
    :Phone.      (0)212 / 42381
    :Copyright.  Public Domain
    :Language.   Modula-2
    :Translator. M2Amiga A+L V3.2d
    :History.    V1.0 A. Kopp   25.Mar.1989 (Amiga Version)
    :History.    V1.1 [bne]     29.Mar.1989 (Druckeranpassung, SingleSheet)
    :History.    V1.2b [bne]     2.Apr.1989 (Ctrl-C Bug fixed);
    :History.    V1.3 A.Lüdtke  10.Dez.1989
    :History.    Tabs durch 1..8*Space ersetzt, FF am Ende des Textes, bei FF
    :History.    im Text neue Seite beginnen, Steuerzeichen durch ^Buchstabe
    :History.    fett darstellen, Dateiname, Datum und Zeit auf jeder Seite
    :History.    anzeigen, auf Preferences (Paperlength und Spacing)
    :History.    reagieren.

*******************************************************************************)

MODULE M2P;

FROM Dos		IMPORT Date, DateStamp;
FROM Str		IMPORT Length, Concat;
FROM Arts		IMPORT Requester, Terminate, wbStarted;
FROM Heap		IMPORT Allocate, Deallocate;
FROM ASCII		IMPORT eol, cr, lf, esc, ht, ff, nul, bs, vt, so, us;
FROM SYSTEM		IMPORT ADR, ADDRESS, FFP;
FROM Terminal		IMPORT WriteLn, WriteString, ReadLn, waitCloseGadget;
FROM Arguments		IMPORT GetArg, NumArgs;
FROM Intuition		IMPORT GetPrefs, Preferences, PreferencesPtr, single,
	draft, letter, pica, elite, fine, sixLPI, eightLPI;
FROM FileSystem		IMPORT File, Response, ReadChar, WriteChar, WriteBytes,
	WriteByteBlock, Lookup, Close;
FROM Conversions	IMPORT ValToStr;


CONST
  MaxZeichen		= 255;
  BoldOn		= "[1m";	BoldOnLen		= 3;
  BoldOff		= "[22m";	BoldOffLen		= 4;
  ItalOn		= "[3m";	ItalOnLen		= 3;
  ItalOff		= "[23m";	ItalOffLen		= 4;

VAR
  Puffer		: ARRAY [0..MaxZeichen] OF CHAR;
  Zeichen		: CHAR;
  Zustand		: (ZeichenLesen, WortLesen, String1, String2,
			   Kommentar, FileEnde);
  ZeilenNr		: CARDINAL;
  SeitenNr		: CARDINAL;
  ZeichenZahl		: CARDINAL;
  KommentarTiefe	: CARDINAL;
  SingleSheet		: BOOLEAN;
  InFile		: File;
  OutFile		: File;
  InputName		: ARRAY [0..31] OF CHAR;
  OutputName		: ARRAY [0..31] OF CHAR;
  Len			: INTEGER;
  Dummy			: LONGINT;
  count			: CARDINAL;
  CharCount		: CARDINAL;
  DatString		: ARRAY [0..40] OF CHAR;
  ZeilenProSeite	: CARDINAL;
  ZeichenProZeile	: CARDINAL;


(* --- Preferences auslesen und gesetzte Parameter feststellen --- *)

PROCEDURE ReadPrefs;
VAR
  Prefs:PreferencesPtr;
BEGIN
  Allocate(Prefs,SIZE(Preferences));
  GetPrefs(Prefs,SIZE(Preferences));
  WITH Prefs^ DO
    SingleSheet		:= paperType = single;
    ZeilenProSeite	:= paperLength;
    IF printSpacing = eightLPI THEN
      ZeilenProSeite := CARDINAL( 1.33 * (FFP(ZeilenProSeite) + 0.5));
    END;
    ZeichenProZeile	:= printRightMargin - printLeftMargin;
    IF printRightMargin <= printLeftMargin THEN
      ZeichenProZeile := 10;
    END;
    IF (printRightMargin - printLeftMargin) > MaxZeichen THEN
      ZeichenProZeile := MaxZeichen;
    END;
  END;
  Deallocate(Prefs);
END ReadPrefs;

(* --------- Lokales Modul zur gepufferten Eingabe eines Zeichens ---------- *)

MODULE GepuffertesLesen;

IMPORT ReadChar, InFile, FileEnde, Zustand;
EXPORT Read, PushBack;

VAR ZeichenPuffer : CHAR;

PROCEDURE Read ( VAR Zeichen : CHAR);
BEGIN
  IF ZeichenPuffer=0C THEN
    ReadChar(InFile,Zeichen);
    IF InFile.eof THEN
      Zustand := FileEnde;
    END;
  ELSE
    Zeichen := ZeichenPuffer;
    ZeichenPuffer := 0C;
  END;
END Read;

PROCEDURE PushBack(Zeichen : CHAR);
BEGIN
  ZeichenPuffer := Zeichen;
END PushBack;

BEGIN (* Initialisierung *)
  ZeichenPuffer := 0C;
END GepuffertesLesen;

(* ----- Lokales Modul zur Bestimmung, ob es sich bei einem Bezeichner ----- *)
(* ----- um ein Schluesselwort handelt -------------------------------------- *)

MODULE ReservierteWoerter;

EXPORT ReserviertesWort;

VAR
  ResWort : ARRAY [1..40] OF ARRAY [0..15] OF CHAR;

PROCEDURE ReserviertesWort(Bezeichner : ARRAY OF CHAR) : BOOLEAN;
VAR
  von, bis, mitte : [1..40];

PROCEDURE kleiner(X,Y : ARRAY OF CHAR) : BOOLEAN;
VAR
  i, Minimum : CARDINAL;
BEGIN
  IF HIGH(X) < HIGH(Y) THEN
    Minimum := HIGH(X)
  ELSE
    Minimum := HIGH(Y)
  END;
  i := 0;
  WHILE (i < Minimum) AND (X[i] = Y[i]) AND (X[i] # 0C) AND (Y[i] # 0C) DO
    INC(i);
  END;
  RETURN X[i] < Y[i];
END kleiner;

BEGIN
  von := 1; bis := 40;
  WHILE von # bis DO
    mitte := (von+bis) DIV 2;
    IF kleiner(ResWort[mitte],Bezeichner) THEN
      von := mitte+1;
    ELSE
      bis := mitte
    END;
  END;
  RETURN NOT kleiner(ResWort[von], Bezeichner) AND
         NOT kleiner(Bezeichner,ResWort[von]);
END ReserviertesWort;

BEGIN
  ResWort[ 1]:="AND";           ResWort[21]:="LOOP";
  ResWort[ 2]:="ARRAY";         ResWort[22]:="MOD";
  ResWort[ 3]:="BEGIN";         ResWort[23]:="MODULE";
  ResWort[ 4]:="BY";            ResWort[24]:="NOT";
  ResWort[ 5]:="CASE";          ResWort[25]:="OF";
  ResWort[ 6]:="CONST";         ResWort[26]:="OR";
  ResWort[ 7]:="DEFINITION";    ResWort[27]:="POINTER";
  ResWort[ 8]:="DIV";           ResWort[28]:="PROCEDURE";
  ResWort[ 9]:="DO";            ResWort[29]:="QUALIFIED";
  ResWort[10]:="ELSE";          ResWort[30]:="RECORD";
  ResWort[11]:="ELSIF";         ResWort[31]:="REPEAT";
  ResWort[12]:="END";           ResWort[32]:="RETURN";
  ResWort[13]:="EXIT";          ResWort[33]:="SET";
  ResWort[14]:="EXPORT";        ResWort[34]:="THEN";
  ResWort[15]:="FOR";           ResWort[35]:="TO";
  ResWort[16]:="FROM";          ResWort[36]:="TYPE";
  ResWort[17]:="IF";            ResWort[37]:="UNTIL";
  ResWort[18]:="IMPLEMENTATION";ResWort[38]:="VAR";
  ResWort[19]:="IMPORT";        ResWort[39]:="WHILE";
  ResWort[20]:="IN";            ResWort[40]:="WITH";
END ReservierteWoerter;


PROCEDURE WriteEscStr(adresse : ADDRESS; len : LONGINT);
VAR
  geschrieben	: LONGINT;
BEGIN
  WriteChar(OutFile,esc);
  WriteBytes(OutFile,adresse,len,geschrieben);
END WriteEscStr;


PROCEDURE Write(Char: CHAR);
BEGIN
  WriteChar(OutFile,Char);
END Write;


PROCEDURE WriteCtrl(Char: CHAR);
BEGIN
  WriteEscStr(ADR(BoldOn),BoldOnLen);	(* Fettdruck anschalten		*)
  WriteChar(OutFile,"^");
  WriteChar(OutFile, CHAR( ORD(Zeichen) + 64));
  WriteEscStr(ADR(BoldOff),BoldOffLen);	(* Fettdruck ausschalten	*)
  INC(CharCount,2);
END WriteCtrl;


(* --- Steuerzeichen (Escape-Sequenzen) nach ISO-Norm               --- *)
(* --- werden vom PRT:-Device automatisch für den Drucker übersetzt --- *)

PROCEDURE InitDrucker;
BEGIN
  Write(esc); Write("c");		(* ISO Reset Kommando		*)
  Write(esc); Write("#"); Write("1");	(* ISO Initialisierung		*)
END InitDrucker;


PROCEDURE FettAn;
BEGIN
  WriteEscStr(ADR(BoldOn),BoldOnLen);
END FettAn;


PROCEDURE FettAus;
BEGIN
  WriteEscStr(ADR(BoldOff),BoldOffLen);
END FettAus;


PROCEDURE MarkiereWort(Bezeichner: ARRAY OF CHAR;Len: LONGINT);
BEGIN
  FettAn;
  WriteBytes(OutFile,ADR(Bezeichner),Len,Len);
  FettAus;
END MarkiereWort;


PROCEDURE KursivAn;
BEGIN
  WriteEscStr(ADR(ItalOn),ItalOnLen);	(* italics on	*)
END KursivAn;


PROCEDURE KursivAus;
BEGIN
  WriteEscStr(ADR(ItalOff),ItalOffLen);	(* italics off	*)
END KursivAus;


(* ------------------- Seitenumbruch und Zeilennummern --------------------- *)

PROCEDURE WriteCard(Val,Digits:CARDINAL);
VAR
  Error		: BOOLEAN;
  Str		: ARRAY [0..7] OF CHAR;
BEGIN
  ValToStr(Val,FALSE,Str,10,Digits," ",Error);
  IF NOT Error THEN
    WriteBytes(OutFile,ADR(Str),Length(Str),Dummy);
  END;
END WriteCard;


PROCEDURE NeueSeite;
VAR
  act	: LONGINT;
BEGIN
  IF ZeilenNr>0 THEN
    Write(CHR(12));
    IF SingleSheet THEN
      IF NOT Requester(ADR("M2P (Modula-2 Print)"),
		       ADR("Bitte nächstes Blatt einlegen"),
		       ADR("weiter"),
		       ADR("abbrechen")) THEN
	Terminate(0);
      END;
    END;
  END;
  INC(SeitenNr);
  KursivAn; FettAn;
  WriteByteBlock(OutFile,"Seite ");
  WriteCard(SeitenNr,2);
  WriteByteBlock(OutFile,"    ");
  WriteBytes(OutFile,ADR(InputName),LONGINT(Length(InputName)),act);
  WriteByteBlock(OutFile,"     ");
  WriteBytes(OutFile,ADR(DatString),LONGINT(Length(DatString)),act);
  FettAus; KursivAus;
  Write(cr); Write(lf); Write(lf);
END NeueSeite;


PROCEDURE NeueZeile;
VAR
  test : CARDINAL;
BEGIN
  Read(Zeichen);
  IF Zeichen # cr THEN
    PushBack(Zeichen);
  END;
  IF ZeilenNr MOD ZeilenProSeite = 0 THEN
    NeueSeite;
  ELSE
    Write(cr); Write(lf);
  END;
  INC(ZeilenNr);
  KursivAn;
  WriteCard(ZeilenNr,4);
  Write(":"); Write(" ");
  IF KommentarTiefe = 0 THEN
    KursivAus;
  END;
END NeueZeile;


PROCEDURE Schaltjahr( Jahr : LONGINT ) : LONGINT;
VAR
  dummy	: LONGINT;
BEGIN
  dummy := 0;
  IF (Jahr REM 4)   = 0 THEN dummy := 1 END;
  IF (Jahr REM 100) = 0 THEN dummy := 0 END;
  IF (Jahr REM 400) = 0 THEN dummy := 1 END;
  RETURN( dummy);
END Schaltjahr;


PROCEDURE TageProMonat( Monat : LONGINT;
			 Jahr : LONGINT) : LONGINT;
VAR
  dummy : LONGINT;
BEGIN
  CASE Monat OF
    1,3,5,7,8,10,12 : dummy := 31			|
    2               : dummy := 28 + Schaltjahr( Jahr)	|
    4,6,9,11        : dummy := 30
  END;
  RETURN( dummy);
END TageProMonat;


PROCEDURE ConvertDate;
VAR
  Tage	: LONGINT;
  Monat	: LONGINT;
  Jahr	: LONGINT;
  HStr	: ARRAY[1..10] OF CHAR;
  Error	: BOOLEAN;
  Datum	: Date;
BEGIN
  DateStamp(ADR(Datum));
  Tage := Datum.days + 1;	(* plus 1 da 'Tage seit 1.1.78'		*)
  Jahr := 1978;
  WHILE Tage > 366 DO
    DEC( Tage, 365 + Schaltjahr( Jahr));
    INC( Jahr);
  END;
  Monat := 1;
  WHILE Tage > 31 DO
    DEC( Tage, TageProMonat( Monat, Jahr));
    INC( Monat);
  END;
  CASE (Datum.days REM 7) OF
    0: DatString := "Sonntag "		|
    1: DatString := "Montag "		|
    2: DatString := "Dienstag "		|
    3: DatString := "Mittwoch "		|
    4: DatString := "Donnerstag "	|
    5: DatString := "Freitag "		|
    6: DatString := "Samstag "
  END;
  ValToStr( Tage, FALSE, HStr, 10, 2, " ", Error);
  Concat( DatString, HStr); Concat( DatString, ".");
  CASE Monat OF
    1:  HStr := "Januar "	|
    2:  HStr := "Februar "	|
    3:  HStr := "März "		|
    4:  HStr := "April "	|
    5:  HStr := "Mai "		|
    6:  HStr := "Juni "		|
    7:  HStr := "Juli "		|
    8:  HStr := "August "	|
    9:  HStr := "September "	|
    10: HStr := "Oktober "	|
    11: HStr := "November "	|
    12: HStr := "Dezember "	|
  END;
  Concat( DatString, HStr);
  ValToStr( Jahr, FALSE, HStr, 10, 4, "0", Error);
  Concat( DatString, HStr); Concat( DatString, "  ");
  ValToStr( Datum.minute DIV 60, FALSE, HStr, 10, 2, "0", Error);
  Concat( DatString, HStr); Concat( DatString, ".");
  ValToStr( Datum.minute REM 60, FALSE, HStr, 10, 2, "0", Error);
  Concat( DatString, HStr); Concat( DatString, " Uhr");
END ConvertDate;


(*****************************************************************************)
(***************** Hauptprogramm als endlicher Automat ***********************)
(*****************************************************************************)

BEGIN (* M2P *)
  waitCloseGadget := FALSE;	(* Damit Fenster am Ende von allein schließt *)
  WriteString(" Modula-2 Quelltext-Lister");WriteLn;
  WriteString("---------------------------");WriteLn;
  WriteLn;
  IF NumArgs()>=1 THEN
    GetArg(1,InputName,Len);
    WriteString("Die Datei ");
    WriteString(InputName);
    WriteString(" wird gedruckt...");
    WriteLn; WriteLn;
  ELSE
    WriteString("Zu druckendes Listing: ");
    WriteLn;WriteLn;
    WriteString("in>");
    ReadLn(InputName, Len);
  END;
  Lookup(InFile,InputName,512,FALSE); (* Eingabedatei öffnen *)
  IF InFile.res#done THEN
    WriteString("Quelldatei konnte nicht geöffnet werden!");
    WriteLn;
    HALT
  END;
  IF NOT wbStarted THEN
    WriteString("Ausgabedatei: (prt: für Ausgabe auf Drucker)");
    WriteLn;WriteLn;
    WriteString("out>");
    ReadLn(OutputName, Len);
  ELSE
    OutputName := "prt:"
  END;
  Lookup(OutFile,OutputName,0,TRUE); (* Ausgabedatei öffnen *)
  IF OutFile.res # done THEN
    WriteString("Ausgabedatei konnte nicht geöffnet werden!");
    WriteLn;
    Close(InFile);
    HALT
  END;
  ReadPrefs;
  InitDrucker;
  ZeilenNr	:= 0;
  SeitenNr	:= 0;
  Zustand	:= ZeichenLesen;
  Zeichen	:= eol;
  CharCount	:= 0;
  ConvertDate;
  WHILE (Zustand # FileEnde) AND (OutFile.res = done) DO
    CASE Zustand OF
    |ZeichenLesen:
      CASE Zeichen OF
      |"A".."Z":
	INC(CharCount);
        ZeichenZahl:=0;
        Puffer[ZeichenZahl]:=Zeichen;
        Zustand:=WortLesen;
      |'"':
	INC(CharCount);
        Write(Zeichen);
        Zustand:=String1;
      |"'":
	INC(CharCount);
        Write(Zeichen);
        Zustand:=String2;
      |"(":
        Read(Zeichen);
        IF Zeichen = '*' THEN
	  INC(CharCount,2);
          KursivAn;
          Write("("); Write("*");
          KommentarTiefe:=1;
          Zustand:=Kommentar;
        ELSE
	  INC(CharCount);
          Write("(");
          PushBack(Zeichen);
        END;
      |eol,cr:
	CharCount := 0;
        NeueZeile;
      |ht:
        FOR count := 1 TO 8 - (CharCount MOD 8) DO Write(" ") END;
	CharCount := CharCount + (8 - (CharCount MOD 8));
      |ff:
	NeueSeite;
      |nul..bs,vt,so..us:
	WriteCtrl(Zeichen);
      ELSE
	INC(CharCount);
        Write(Zeichen);
      END;
    |WortLesen:
      IF (Zeichen >= "A") AND (Zeichen <= "Z") THEN
        IF ZeichenZahl < ZeichenProZeile THEN
          INC(ZeichenZahl);
          Puffer[ZeichenZahl]:=Zeichen;
	  INC(CharCount);
        END;
      ELSE
        IF ZeichenZahl < ZeichenProZeile THEN
          INC(ZeichenZahl);
          Puffer[ZeichenZahl]:=0C;
        END;
        IF ReserviertesWort(Puffer) THEN
          MarkiereWort(Puffer,ZeichenZahl);
        ELSE
          WriteBytes(OutFile,ADR(Puffer),ZeichenZahl,Dummy);
        END;
        PushBack(Zeichen);
        Zustand:=ZeichenLesen;
      END;
    |String1:
      CASE Zeichen OF
      |nul..us:
	WriteCtrl(Zeichen);
      ELSE
	INC(CharCount);
	Write(Zeichen);
	IF Zeichen = '"' THEN
	  Zustand := ZeichenLesen;
	END;
      END;
    |String2:
      CASE Zeichen OF
      |nul..us:
	WriteCtrl(Zeichen);
      ELSE
	INC(CharCount);
	Write(Zeichen);
	IF Zeichen = "'" THEN
	  Zustand := ZeichenLesen;
	END;
      END;
    |Kommentar:
      CASE Zeichen OF
      |'(':
        Read(Zeichen);
        IF Zeichen="*" THEN
	  INC(CharCount,2);
          Write("("); Write("*");
          INC(KommentarTiefe);
        ELSE
	  INC(CharCount);
          Write("(");
          PushBack(Zeichen);
        END;
      |'*':
        Read(Zeichen);
        IF Zeichen=")" THEN
	  INC(CharCount,2);
          Write("*"); Write(")");
          DEC(KommentarTiefe);
          IF KommentarTiefe=0 THEN
            KursivAus;
            Zustand:=ZeichenLesen;
          END;
        ELSE
	  INC(CharCount);
          Write("*");
          PushBack(Zeichen);
        END;
      |eol:
	CharCount := 0;
        NeueZeile
      |ht:
        FOR count := 1 TO 8 - (CharCount MOD 8) DO Write(" ") END;
	CharCount := CharCount + (8 - (CharCount MOD 8));
      |nul..bs,vt..us:
	WriteCtrl(Zeichen);
      ELSE
	INC(CharCount);
        Write(Zeichen);
      END; (* CASE Zeichen *)
    END; (* CASE Zustand *)
    Read(Zeichen);
  END; (* WHILE *)
  Write(ff);
  Close(InFile);
  Close(OutFile);
END M2P.