⟦5b5c48667⟧

Mikados K File

PROGRAM REORGANZ;
CONST MAXRECSIZE=1000;
      PROGRAMNR=1;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
NIVEAU=(MENIG,SERGENT,LØJTNANT,KAPTAJN,MAJOR,OBERST,GENERAL,HSM,UMULIUS);
POSTADR=0..MAXRECSIZE;
COMMBUF =ARRAY (POSTADR) OF INTEGER;(*commbuf(0)=filnr,resten er posten*)
POINTREC=^COMMBUF;
NAME    =STRING(10);
PCB     =^INTEGER;
MESSAGETYPE=(ÅBEN,LUK,LÆSPOST,LÆSPOSTX,NÆSTE,NÆSTEX,SLET,SLETX,GEMPOST,
             INDSÆT,INITIER,UTILMELD,UAFMELD,PTILMELD,PAFMELD,STOPSYS,        
             RETURNHEAD,RETURNSTAT);                                    
MESSAGE =RECORD
           KOMMANDO:MESSAGETYPE;
           INFO,IREC:INTEGER 
         END;
AR=ARRAY (-4..-4) OF INTEGER;
VAR    PARM:^PARMARRAY;
       USERNIVEAU:NIVEAU;
       F:STRING(18);
       QUQ:^INTEGER;
       IER,IREC,STATUSER,MODE,REMUSERS,
       FILNR,I,FRANR,TILNR:INTEGER;
       FNAVN,REGNAVN,DESCNAVN:STRING(18);
       SEMAFOR:NAME;
       FILEINIT:BOOLEAN;
       SNYD:AR;
       CPPCB:PCB;
       COMREC:POINTREC;
       BESKED:MESSAGE;
(*$P*)
PROCEDURE D23;
BEGIN
  GOTOXY(1,23);WRITE(' ':79);GOTOXY(1,23)
END;
PROCEDURE BAD(IDENT,STATUS:INTEGER);
BEGIN
  D23;
  WRITE('BAD',IDENT:5,STATUS:5);
  READLN
END;
(*$P*)
PROCEDURE ALLOCA(VAR ADDRESS:POINTREC;LENGTH:INTEGER;
                 VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE DEALLO(ADDRESS:POINTREC;VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE SENDM(RECEIVER:PCB;VAR CONTENTS:MESSAGE;
                LENGTH:INTEGER;VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE RECEIV(VAR SENDER:PCB;VAR CONTENTS:MESSAGE;
                 VAR LENGTH:INTEGER);
EXTERNAL;
PROCEDURE RESERV(RESOURCE:NAME;EXCLUSIVE,WAIT:BOOLEAN;
                 VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE RELEAS(RESOURCE:NAME;VAR STATUS:INTEGER);
EXTERNAL;
(*$IUDFØR*)
(*$IFISFPROC*)
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
      MAXNØGLER=9;
      MAXPOST=500;
TYPE
ARAR=PACKED ARRAY (-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
PPOST=RECORD
      AA:ARAR;
      A:AR;
      AAA:RAR;
      CONTENTS: ARRAY (1..MAXPOST) OF INTEGER
END;
VAR ANTALIDENT,
    LINES,OPTION,I,J:INTEGER;
    LINE:STRING;
    POST:PPOST;
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
    I:INTEGER;
BEGIN
  D23;
                                                                     (*$R-*)
  WRITE('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN');      (*$R+*)
  CH:=' ';EDIT(CH);
  IF CH='Æ' THEN BEGIN IER:=0;EXIT(ERROR) END;
  POST.A(-3):=TILNR;
  ICLOSE(POST.A);
  POST.A(-3):=FRANR;                                            (*$R+*)
  ICLOSE(POST.A);                                                
  EXIT(REGVEDL)
END;
(*$P*)
BEGIN (*REGVEDL*)
  MODE:=3;(*SKRIV*)
                                                                       (*$R-*)
  POST.A(-3):=TILNR;                                                  
  IOPEN(POST.A);IF IER<>0 THEN ERROR(POST.A);
  INITIATE(POST.A);IF IER<>0 THEN ERROR(POST.A);
  POST.A(-3):=FRANR;                                                  
  IOPEN(POST.A);IF IER<>0 THEN ERROR(POST.A);
  FOR I:=1 TO POST.A(-4) DO POST.A(I):=0;
  NEXTREC(POST.A);IF NOT (-IER IN (.0..2,9.)) THEN ERROR(POST.A);
  IER:=0;
  WHILE IER=0 DO
  BEGIN
    POST.A(-3):=TILNR;
    INSERT(POST.A);IF IER<>0 THEN ERROR(POST.A);
    POST.A(-3):=FRANR;
    NEXTREC(POST.A)
  END;
  IF IER<>-2 THEN ERROR(POST.A);
  ICLOSE(POST.A);
  POST.A(-4):=1;
  POST.A(-3):=TILNR;                                                  (*$R+*)
  ICLOSE(POST.A);
  IF IER<>0 THEN BAD(6,IER)
END;
(*$P*)
PROCEDURE DOIT;
TYPE
FILDESC=RECORD
  FILNAVN,DESCNAVN,POSTNAVN,REGNAVN:STRING(18);
  VEDLNIVEAU:NIVEAU;
  ZONESIZE:INTEGER
END;
FILEDESC=FILE OF FILDESC;
ISF=FILE OF ARRAY (1..232) OF INTEGER;
VAR ISFFILES:FILEDESC;
    ISFFNAVN:STRING(18);
    SCH:STRING(1);
    J,I,AKNR:INTEGER;
    F,F1:ISF;
PROCEDURE IOC;
VAR CH:STRING(1);
    IOR:INTEGER;
BEGIN
  IOR:=IORESULT;
  IF IOR<>0 THEN
  BEGIN
    CLEARSCREEN;
    D23;
    WRITE('Pladefejl ',IOR:5,' RETURN ');
    CH:=' ';
    EDIT(CH);
    IF CH<>'R' THEN EXIT(DOIT)
  END
END;
(*$P*)
BEGIN
  ISFFNAVN:='ISFFILES:P2:0000:S';
  REWRITE(ISFFILES,ISFFNAVN);IOC;
  REPEAT
    CLEARSCREEN;
    SEEK(ISFFILES,1);IOC;
    GET(ISFFILES);IOC;
    FILNR:=0;
    WHILE ISFFILES^.FILNAVN(1)<>'@' DO
    BEGIN
      FILNR:=FILNR+1;
      WRITELN(FILNR:4,' ',ISFFILES^.REGNAVN,'-register');
      GET(ISFFILES);IOC
    END;
    REPEAT
      D23;WRITE('Vælg register ');
      READLN;READ(FRANR)
    UNTIL (IORESULT=0) AND (FRANR>=0) AND (FRANR<=FILNR);
    IF FRANR>0 THEN
    BEGIN
      SEEK(ISFFILES,FRANR);IOC;
      GET(ISFFILES);IOC;
      RESET(F,ISFFILES^.FILNAVN);IOC;
      SEEK(F,1);IOC;
      GET(F);IOC;
      TILNR:=FILNR+1;
      ISFFILES^.FILNAVN(2+POS(':',ISFFILES^.FILNAVN)):='1';
      SEEK(ISFFILES,TILNR);IOC;
      PUT(ISFFILES);IOC;
      REWRITE(F1,ISFFILES^.FILNAVN);IOC;
      SEEK(F1,1);IOC;
      FOR I:=1 TO 100 DO F1^(I):=F^(I);
      IREC:=F^(22);
      F1^(22):=0;
      F1^(20):=0;
      F1^(21):=0;
      F1^(23):=0;
      PUT(F1);IOC;
      CLOSE(F1);IOC;
      CLOSE(F);IOC;
      CLOSE(ISFFILES);IOC;
      REGVEDL;
      REWRITE(ISFFILES,ISFFNAVN);IOC;
      ISFFILES^.FILNAVN(1):='@';
      SEEK(ISFFILES,TILNR);IOC;
      PUT(ISFFILES);IOC
    END
  UNTIL FRANR=0;
  CLOSE(ISFFILES);IOC
END;
(*$P*)
BEGIN
  SEMAFOR:='ALLOCOMBUF';
  I:=ORD(PARM^(1))-48;
  USERNIVEAU:=MENIG;
  WHILE I>0 DO
  BEGIN
    USERNIVEAU:=SUCC(USERNIVEAU);
    I:=I-1
  END;                                                                 (*$R-*)
  SNYD(-3):=0;
  FOR I:=6 DOWNTO 2 DO SNYD(-3):=10*SNYD(-3)+ORD(PARM^(I))-48;
  IF PARM^(7)='-' THEN SNYD(-3):=-SNYD(-3);                            (*$R+*)
  UDFØR(PTILMELD,SNYD);
  UDFØRT(PTILMELD,SNYD);
  IF IER<>0 THEN BAD(1,IER);
  DOIT;
  F:='HOVED   *1';
  UDFØR(PAFMELD,SNYD);
  UDFØRT(PAFMELD,SNYD);
  IF IER<>0 THEN BAD(2,IER);
  FNAVN:='       ';
  FOR I:=1 TO 7 DO FNAVN(I):=PARM^(I);
  CHAIN(F,FNAVN,QUQ);
  IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.
DataMuseum.dk

MIKADOS

⟦5b5c48667⟧ TextFile

Derivation

Mikados K File

Full view
