uses
sysutils;

TYPE
FDATAB = RECORD
data : String[200];
next : Byte;
end;
FHEAD = RECORD
name 	: String[50];
exch    : String[50];
wo	: Integer;
end;
VAR

libdata		: ARRAY[0..2500] of FDATAB;
libid		: ARRAY[0..2500] of FHEAD;
filename	: Ansistring;
libname		: Ansistring;
dummy,temp      : Ansistring;
fhlb,fhid	: Integer;
fhcode          : Text;
Procedure BPclearlibBP;
VAR
i : Integer;
begin
For i := 0 to 2500 DO
  BEGIN
      libdata[i].data := '';
      libdata[i].next := 0;
      libid[i].name := '';
      libid[i].exch := '';
      libid[i].wo := 0;
  END;
END;
Function TrimAllBP( s : AnsiString) : AnsiString;
VAR
i,l,x,y : Integer;
a : AnsiString;
begin
L := Length(s);
IF L > 0 THEN
  BEGIN
      For i := 1 to L DO
        BEGIN
            IF Byte(s[i]) > 32 THEN
              BEGIN
                  x := i;
                  BREAK;
              END;
        END;
      For i := L Downto 1 DO
        BEGIN
            IF Byte(s[i]) > 32 THEN
              BEGIN
                  y := i;
                  BREAK;
              END;
        END;
      For i := x to y DO
        BEGIN
            a:= a+ CHAR(s[i]);
        END;
  END
ELSE
    BEGIN
      a := '';
  END;
TRIMALLBP := a;
END;
PROCEDURE OpenReadBP(VAR fh : Text; name : AnsiString);
begin
Assign(fh,name);
Reset(fh);
END;
Function ExtractBP(ss : AnsiString;cc : AnsiString) : AnsiString;
VAR
fcxdb : Byte;
begin
fcxdb := Pos(cc,ss);
ExtractBP := LeftStr(ss,fcxdb-1);
END;
Procedure putlib(macin,hdname,dbstr : String);
VAR
i,j,mk   : Integer;
BEGIN
mk := 0;

For i := 0 to 2500 DO
  BEGIN
      IF libid[i].name = '' THEN
        BEGIN
            hdname := TrimAllBP(hdname);
            
            libid[i].name := hdname;
            libid[i].exch := UpCase(macin);
            For j := 0 to 2500 DO
              BEGIN
                  IF libdata[j].data = '' THEN
                    BEGIN
                        IF mk = 0 THEN
                          BEGIN
                              libid[i].wo := j;
                              mk := 1;
                          END;
                        IF j > 2480 then
                          BEGIN
                              Writeln ( 'WARNING: Blocknumer: ',j,' from 2500 is reached');
                              Writeln ( 'The Library is nearly full!');
                          END;
                        IF Length(dbstr) > 200 THEN
                          BEGIN
                              libdata[j].data := LeftStr(dbstr,200);
                              Delete(dbstr,1,200);
                              libdata[j].next := 1;
                          END
                        ELSE
                            BEGIN
                              libdata[j].data := dbstr;
                              libdata[j].next := 0;
                              BREAK;
                          END;
                    END;
              END;
            BREAK;
        END;
  END;
END;
Procedure PutFuPs(fname : String);
VAR
isin        : Integer;
tempdat,temphd,tempmac  : Ansistring;
begin
isin := 0;
OpenReadBP(fhcode,fname);
While not eof(fhcode) DO
  BEGIN
      Readln(fhcode,temp);
      temp := TrimAllBP(temp);
      IF Length(temp) > 1 THEN
        BEGIN
            dummy := TrimAllBP(UpCase(temp));
            Repeat
            IF (LeftStr(dummy,9) = 'FUNCTION ') THEN
              Begin
                  tempdat := temp + chr(13) + chr(10);
                  DELETE(temp,1,9);
                  temphd := TrimAllBP(ExtractBP(temp,'('));
                  IF temphd = '' THEN
                    BEGIN
                        temphd := TrimAllBP(temp);
                    END;
                  isin := 1;
                  tempmac := '';
              BREAK;
              END;
            IF  (LeftStr(dummy,10) = 'PROCEDURE ') THEN
              BEGIN
                  tempdat := temp + chr(13) + chr(10);
                  DELETE(temp,1,10);
                  temphd := TrimAllBP(ExtractBP(temp,'('));
                  IF temphd = '' THEN
                    BEGIN
                        temphd := TrimAllBP(temp);
                    END;
                  isin := 1;
                  tempmac := '';
              BREAK;
              END;
            IF  (LeftStr(dummy,8) = 'EXMACRO ') and (isin = 1) THEN
              BEGIN
                  DELETE(dummy,1,8);
                  tempmac := TrimAllBP(dummy);
              BREAK;
              END;
            IF  (dummy = 'END PROC') or (dummy = 'ENDPROC') or (dummy = 'END PROCEDURE') or (dummy = 'END FUNC') or (dummy = 'ENDFUNC') or (dummy = 'END FUNCTION') THEN
              BEGIN
                  tempdat := tempdat+temp+ chr(13) + chr(10);
                  isin := 0;
                  IF tempmac = '' THEN
                    BEGIN
                        tempmac := UpCase(temphd);
                    END;
                  IF (Length(tempmac) > 50) OR (Length(temphd) > 50) THEN
                    BEGIN
                        Writeln ( 'ERROR Function or Procedure name too long');
                    END
                  ELSE
                      BEGIN
                        putlib(tempmac,temphd,tempdat);
                    END;
              BREAK;
              END;
            IF  isin = 1  THEN
              BEGIN
                  tempdat := tempdat+temp+ chr(13) + chr(10);
              END;
            UNTIL true;
        END;
END;
Close(fhcode);
END;
Procedure SaveLib(thelib : String);
begin
fhid := FileCreate(thelib+'.id');
FileWrite(fhid,libid,sizeof(libid));
FileClose(fhid);
fhlb := FileCreate(thelib+'.lb');
FileWrite(fhlb,libdata,sizeof(libdata));
FileClose(fhlb);
END;
Procedure LoadLib(thelib : String);
begin
fhid := FileOpen(thelib+'.id',fmOpenRead);
FileRead(fhid,libid,sizeof(libid));
FileClose(fhid);
fhlb := FileOpen(thelib+'.lb',fmOpenRead);
FileRead(fhlb,libdata,sizeof(libdata));
FileClose(fhlb);
END;




{Aufruf: lib01 FunctCodeFile LIBname}
BEGIN

libname := Paramstr(2);
Repeat
IF (Paramstr(1) = '') OR (Paramstr(1) = UpCase('-H')) OR (Paramstr(1) = UpCase('HELP')) OR (Paramstr(1) = UpCase('-HELP')) THEN
  Begin
      Writeln ( '-----------------------------------------------------------------------');
      Writeln ( 'mlib <Function-/Procedure- Sourefile> <libname> [-new]');
      Writeln ();
      Writeln ( 'The Option -new overwrites an existing Library with the same name.');
      Writeln ();
      Writeln ( '1. Param: Function/Procedure Sourcefile');
      Writeln ( '2. Param: Library Name');
      Writeln ( '3. Param: Optional -new');
      Writeln ();
      Writeln ( 'Example: mlib myfunctions.txt MyLib new');
      Writeln ( 'This generates a new Libfile with name: MyLib.lb and MyLib.id');
      Writeln ( 'the Functions and Procedures are declared in the File: myfunctions.txt');
      Writeln ( 'If a Library with the same name exists, then the Library is deleted and');
      Writeln ( 'with the new Functions/Procedures replaced.');
      Writeln ();
      Writeln ( 'Example: mlib myf.bas NewLib');
      Writeln ( 'If a Library with the name "NewLib" exists, then the new Functions/Procs');
      Writeln ( 'are appended, else a new one is created.');
      Writeln ( 'If no library name is given, the default name "mlibdummy" is used.');
      Writeln ();
      Writeln ( 'mlib is used to create a Library file for:');
      Writeln ( 'BasPas the Basic to Pascal Compiler');
      Writeln ( 'Written by Andrea Tobian-Mezger 2003');
      Writeln ();
      Writeln ( 'More files and infos in: http://groups.yahoo.com/group/BasPas');
      Writeln ( '_________________________________________________________________________');
      halt(0);
  BREAK;
  END;
IF  (UpCase(Paramstr(2)) = '-NEW') or (Paramstr(2) = '') THEN
  BEGIN
      filename := Paramstr(1);
      libname := 'mlibdummy';
      BPclearlibBP;
  BREAK;
  END;
IF  Paramstr(3) = '' THEN
  BEGIN
      filename := Paramstr(1);
      libname := Paramstr(2);
      BPclearlibBP;
      Loadlib(libname);
  BREAK;
  END;
IF  (UpCase(Paramstr(3)) = '-NEW') or (UpCase(Paramstr(3)) = 'NEW') THEN
  BEGIN
      filename := Paramstr(1);
      libname := Paramstr(2);
      BPclearlibBP;
      BREAK
  END
ELSE
  BEGIN
      HALT(1);
  END;
UNTIL true;


PutFuPs(filename);
SaveLib(libname);




{Macroname,HeaderString für Indexfile + Gesammtstring der Func oder Proc}


{filename in der die Funktionen und Proceduren enthalten sind}




END.
