|
DataMuseum.dkPresents historical artifacts from the history of: MIKADOS |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about MIKADOS Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 32864 (0x8060)
Types: TextFile
Notes: Mikados_K
Names: »SPECHOVE.K«
└─⟦5630b2e42⟧ Bits:30009005 START APRIL 1985 aft april 1985 (PASCAL kildetekster)
└─⟦this⟧ »SPECHOVE.K«
└─⟦6c21327e0⟧ Bits:30008986 LINIMATIC K-FILER (IKKE HELT UPTODTATE)
└─⟦this⟧ »SPECHOVE.K«
PROGRAM SPECHOVED;
(*TILPASSES TIL SPECIELLE REGISTERVEDLIGEHOLDELSER, HÆGTER OSV.*)
CONST LNGTH=20;
TIMER=120;
MAXRECSIZE=1000;
(*@@*)
PROGRAMNR=3;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
DIRECTBUF=PACKED ARRAY (1..LNGTH) OF CHAR;
CLOCKRECORD = RECORD
DATE:PACKED ARRAY (1..10) OF CHAR;
TIME:PACKED ARRAY (1..8) OF CHAR
END;
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;
CLOCK:^CLOCKRECORD;
STIMER,SV,TT,OFFSET,MIN,SEC,SEC100:INTEGER;
TÆNDT,HOWL,ALARM,STOPWATCH:BOOLEAN;
ALARMTIME:PACKED ARRAY (1..8) OF CHAR;
DBUF:DIRECTBUF;
USERNIVEAU:NIVEAU;
F:STRING(18);
QUQ:^INTEGER;
IER,IREC,STATUSER,MODE,REMUSERS,
FILNR,I:INTEGER;
FNAVN,REGNAVN,DESCNAVN:STRING(18);
SEMAFOR:NAME;
FILEINIT:BOOLEAN;
SNYD:AR;
CPPCB:PCB;
COMREC:POINTREC;
BESKED:MESSAGE;
(*$P*)
(*$L-*)
PROCEDURE BAD(IDENT,STATUS:INTEGER);
BEGIN
GOTOXY(1,23);
WRITE('BAD',IDENT:5,STATUS:5);
READLN
END;
(*$P*)
PROCEDURE SETUP(VAR BUFFER:DIRECTBUF;LENGTH:INTEGER);
EXTERNAL;
FUNCTION AVAIL:BOOLEAN;
EXTERNAL;
FUNCTION NEXT:CHAR;
EXTERNAL;
PROCEDURE FINIS;
EXTERNAL;
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;
(*$P*)
(*$IUR*)
(*$P*)
(*$IUDFØR*)
(*$IFISFPROC*)
(*$P*)
(*$L+*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
MAXNØGLER=9;
(*@@*)
MAXPOST=500;
MAXHÆGTER=9;
MAXHPOST=20;
MAXIDENT=9;
TYPE
NFELT=^FELTBESKRIVELSE;
SKÆRMPOS=RECORD
X,Y:INTEGER
END;
FTYPE=(HELTAL,DOBBTAL,REEL,TEKST);
VTYPE=(HINTERVAL,DINTERVAL,RINTERVAL,DATO,CPR);
BESKRIVELSESTYPE=(FELTDESC,VALIDESC);
FELTBESKRIVELSE=RECORD
NÆSTEVAL:NFELT;
FELTNAVN:STRING(8);
CASE DESCTYPE:BESKRIVELSESTYPE OF
FELTDESC:
(INDPOS,UDPOS:SKÆRMPOS;
KIKKENIVEAU,ÆNDRENIVEAU:NIVEAU;
EDITERING:INTEGER;
LEDETEKST,FØLGETEKST:STRING;
INDEKS,
LÆNGDE,
HÆGTE,
FORAN0:INTEGER;
CASE FELTTYPE:FTYPE OF
REEL:(DEC:INTEGER);
HELTAL,DOBBTAL,TEKST:());
VALIDESC:
(CASE VALIDITETSTYPE:VTYPE OF
HINTERVAL:(MIN,MAX:INTEGER);
DINTERVAL:(MIN1,MIN2,MAX1,MAX2:INTEGER);
RINTERVAL:(RMIN,RMAX:REAL);
DATO,CPR:())
END;
ARAR=PACKED ARRAY (-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
(*@@EVT. TOTAL POSTERKLÆRING,FLERE POSTER*)
PPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
CONTENTS: ARRAY (1..MAXPOST) OF INTEGER
END;
HPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
CONTENTS: ARRAY (1..MAXHPOST) OF INTEGER
END;
VAR FELT:NFELT;
HUSKNIV:NIVEAU;
PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
NØGLER:ARRAY (1..MAXNØGLER) OF NFELT;
HÆGTER:ARRAY (1..MAXHÆGTER) OF NFELT;
IDENT:ARRAY (1..MAXIDENT) OF NFELT;
ANTALIDENT,
LINES,OPTION,I,J,ANTALFELTER,ANTALNØGLER,ANTALHÆGTER:INTEGER;
LINE:STRING;
POST:PPOST;
HÆGTEREC:ARRAY (1..MAXHÆGTER) OF HPOST;
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
I:INTEGER;
BEGIN
IF LINES>0 THEN PAGE(LIST); (*$R-*)
WRITELN('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN'); (*$R+*)
CH:=' ';EDIT(CH);
ICLOSE(POST.A);
FOR I:=1 TO ANTALHÆGTER DO ICLOSE(HÆGTEREC(I).A);
(*@@LUK EVT. ANDRE DATAFILER*)
EXIT(REGVEDL)
END;
PROCEDURE OFEJL(VAR REC:AR);
VAR I:INTEGER;
BEGIN
GOTOXY(1,20); (*$R-*)
WRITELN('REGISTERFEJL ',IER,' I ',REC(-3),
' . SITUATIONEN ER FORSØGT REDDET.'); (*$R+*)
WRITELN('TAST 0, HVIS DER SKAL FORTSÆTTES');
REPEAT GOTOXY(40,21);READLN;READ(I) UNTIL IORESULT=0;
IF I<>0 THEN ERROR(REC);
CLEARSCREEN
END;
(*$P*)
(*$L-*)
(*$IHLÆSDESC*)
(*$P*)
(*$IMOVETOLI*)
(*$P*)
(*$L+*)
PROCEDURE MAINTAIN;
VAR J,NØGLENR,HNR,HINDEKS:INTEGER;
HCHANGED,HÆGTSØG:BOOLEAN;
CH:STRING(1);
(*$P*)
(*$L-*)
(*$ISØGPOST*)
(*$P*)
(*$L+*)
PROCEDURE UDPÅLIST;
BEGIN
REPEAT
GOTOXY(1,23);
WRITELN('Antal poster, 0 for resten');
GOTOXY(28,23);
READLN;READ(J)
UNTIL (IORESULT=0) AND (J>=0);
REPEAT
IF (LINES+2+ANTALFELTER)>=72 THEN
BEGIN
IF LINES<>100 THEN PAGE(LIST);
WRITELN(LIST,REGNAVN,' UDSKRIFT');
WRITELN(LIST);
LINES:=2
END;
PRINTPOST;
J:=J-1;
WRITELN(LIST);WRITELN(LIST);LINES:=LINES+2;
NEXTREC(POST.A);
IF (IER=-2) AND (J>0) THEN IER:=0
UNTIL (J=0) OR (IER<>0);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A) ELSE IER:=0
END;
(*$P*)
PROCEDURE SLETPOST;
BEGIN
GOTOXY(1,20);
CH:='J';
WRITELN('Sletning korrekt J/N');
GOTOXY(22,20);EDIT(CH);
IF CH='J' THEN
BEGIN
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
SÆTHÆGTE;
SÆTNØGLE
END;
DELETE(POST.A);
IF IER=-9 THEN
BEGIN
WRITELN('Eneste post, kan ikke slettes, RETURN');
READLN;
IER:=0
END
ELSE (*@@SLET EVT. ANDRE TILHØRENDE POSTER*)
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
GETRECX(HÆGTEREC(HNR).A);
IF NOT (-IER IN (.0,6.)) THEN ERROR(HÆGTEREC(HNR).A);
DELETE(HÆGTEREC(HNR).A);
IF NOT (-IER IN (.0,6.)) THEN ERROR(HÆGTEREC(HNR).A);
IER:=0
END
END
ELSE GETREC(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
(*$P*)
BEGIN (*MAINTAIN*)
CLEARSCREEN;
IF OPTION<>4 THEN
BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS;
NULPOST;
HÆGTSØG:=FALSE;
IF ANTALHÆGTER>0 THEN SØGPOST;
IF NOT HÆGTSØG THEN
BEGIN
J:=1;
LÆSFELT(NØGLER(J));
WHILE (J<ANTALNØGLER) AND NOT EOF DO
BEGIN
J:=J+1;
LÆSFELT(NØGLER(J))
END;
USERNIVEAU:=HUSKNIV;
IF OPTION IN (.1,5.) THEN
GETRECX(POST.A)
ELSE
GETREC(POST.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(POST.A);
IF EOF THEN
BEGIN
IF IER=-6 THEN
BEGIN
IF OPTION IN (.1,5.) THEN
NEXTRECX(POST.A)
ELSE
NEXTREC(POST.A);
IF (IER<>-1) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A)
END;
REPEAT
SKRIVPOST;
GOTOXY(1,23);
CH:='F';
WRITELN('Rigtig post R, Flere poster F, Stop S');
GOTOXY(39,23);
EDIT(CH);
IF CH(1) IN (.'f','r','s'.) THEN
CH(1):=CHR(ORD(CH(1))-32);
IF CH='F' THEN
BEGIN
IF OPTION IN (.1,5.) THEN
NEXTRECX(POST.A)
ELSE
NEXTREC(POST.A);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A)
END
UNTIL CH<>'F';
GOTOXY(1,23);WRITELN(' ':77);
IF (OPTION IN (.1,5.)) AND (CH<>'R') THEN GETREC(POST.A);
(*FOR AT FJERNE XCLUSIV-STATUS*)
IF OPTION=2 THEN CH:='S'
END
ELSE
BEGIN
IF IER=0 THEN
BEGIN
CH:='R';
SKRIVPOST
END
ELSE
BEGIN
CH:='S';
GOTOXY(1,23);WRITELN('Posten findes ikke, RETURN');
GOTOXY(28,23);READLN
END
END
END
END;
IF (OPTION=4) OR (CH='R') THEN
CASE OPTION OF
1: BEGIN
REPEAT
REPEAT
GOTOXY(1,23);
J:=0;
WRITELN('Feltnr, 0 for færdig ',J,' ':57);
GOTOXY(22,23);READLN;
IF NOT (EOLN OR (INPUT^=' ')) THEN READ(J)
UNTIL (IORESULT=0) AND (J>=0) AND (J<=ANTALFELTER);
IF J>0 THEN BEGIN (*@@EVT. BEHANDLING AF ANDRE POSTER*)
HNR:=0;
IF PICTURE(J)^.HÆGTE>0 THEN
BEGIN
REPEAT
HNR:=HNR+1
UNTIL PICTURE(J)^.HÆGTE=HÆGTER(HNR)^.HÆGTE;
SÆTHÆGTE;
END;
LÆSFELT(PICTURE(J));SKRIVFELT(PICTURE(J));
IF HNR>0 THEN
BEGIN
HCHANGED:=FALSE;
CASE PICTURE(J)^.FELTTYPE OF (*$R-*)
HELTAL :HCHANGED:=(HÆGTEREC(HNR).A(1)<>
POST.A(PICTURE(J)^.INDEKS));
DOBBTAL:HCHANGED:=(
(HÆGTEREC(HNR).A(1)<>
POST.A(PICTURE(J)^.INDEKS)) OR
(HÆGTEREC(HNR).A(2)<>
POST.A(PICTURE(J)^.INDEKS+1)));
TEKST:FOR HINDEKS:=1 TO PICTURE(J)^.FORAN0 DO
IF HÆGTEREC(HNR).AA(HINDEKS)<>
POST.AA(PICTURE(J)^.INDEKS-1+HINDEKS)
THEN HCHANGED:=TRUE
END
END; (*$R+*)
IF HCHANGED THEN
BEGIN
SÆTNØGLE;
GETRECX(HÆGTEREC(HNR).A);
IF IER=0 THEN DELETE(HÆGTEREC(HNR).A);
SÆTHÆGTE;
SÆTNØGLE;
INSERT(HÆGTEREC(HNR).A);
IF IER<>0 THEN ERROR(HÆGTEREC(HNR).A)
END
END
UNTIL J=0;
PUTREC(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
2: BEGIN GOTOXY(1,24);WRITE('Tryk RETURN ');READLN END;
3: UDPÅLIST;
4: BEGIN
NULPOST;
SKRIVPOST;
FOR J:=1 TO ANTALFELTER DO
BEGIN
IF PICTURE(J)^.ÆNDRENIVEAU=UMULIUS THEN
BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS
END;
LÆSFELT(PICTURE(J));
SKRIVFELT(PICTURE(J));
IF PICTURE(J)^.ÆNDRENIVEAU=UMULIUS THEN USERNIVEAU:=HUSKNIV
END;
USERNIVEAU:=HUSKNIV;
IF NOT FILEINIT THEN
BEGIN
FILEINIT:=TRUE;
REPEAT
GOTOXY(1,23);
WRITELN('ANTAL INITIALISERINGSPOSTER');
GOTOXY(30,23);
READLN;READ(IREC)
UNTIL (IORESULT=0) AND (IREC>0);
INITIATE(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
INSERT(POST.A);
IF IER<>0 THEN
IF IER=-7 THEN
BEGIN
WRITELN('Posten findes, RETURN');READLN
END
ELSE ERROR(POST.A)
ELSE (*@@EVT. INDSÆT/VEDL AF ANDRE POSTER*)
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
SÆTHÆGTE;
SÆTNØGLE;
INSERT(HÆGTEREC(HNR).A);
IF IER<>0 THEN ERROR(HÆGTEREC(HNR).A)
END
END;
5: SLETPOST
END
END;
(*$P*)
BEGIN (*REGVEDL*)
CLEARSCREEN;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL); (*$X-*)
LÆSDESC;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL);READLN; (*$X-*)
MODE:=3;(*SKRIV*)
FOR I:=1 TO ANTALHÆGTER DO
BEGIN
IOPEN(HÆGTEREC(I).A);
IF IER<>0 THEN OFEJL(HÆGTEREC(I).A)
END;
LINES:=100; (*$R-*)
POST.A(-3):=FILNR; (*$R+*)
IOPEN(POST.A);IF IER<>0 THEN OFEJL(POST.A);
(*@@EVT. ÅBNING AF ANDRE ANDRE DATAFILER*)
REPEAT
CLEARSCREEN;
GOTOXY(10,10);
WRITELN(REGNAVN,' R E G I S T E R - V E D L I G E H O L D E L S E');
GOTOXY(10,12);
WRITELN('0 Færdig');
WRITELN(' ':9,'1 Ændring');
WRITELN(' ':9,'2 Udskrift på skærm');
WRITELN(' ':9,'3 Udskrift på printer');
WRITELN(' ':9,'4 Oprettelse');
WRITELN(' ':9,'5 Sletning');
REPEAT
GOTOXY(10,19);
WRITELN('Vælg 0-5');
GOTOXY(21,19);UR;
OPTION:=SV
UNTIL (OPTION>=0) AND (OPTION<=5);
IF OPTION>0 THEN MAINTAIN
UNTIL OPTION=0;
IF LINES<>100 THEN PAGE(LIST);
ICLOSE(POST.A);
FOR I:=1 TO ANTALHÆGTER DO ICLOSE(HÆGTEREC(I).A);
(*@@EVT. LUKNING AF ANDRE DATAFILER*)
CLEARSCREEN;
IF IER<>0 THEN BAD(6,IER)
END;
(*$P*)
BEGIN
ALARM:=CLOCK^.DATE(9)='1';
IF ALARM THEN FOR I:=1 TO 8 DO ALARMTIME(I):=CLOCK^.DATE(I);
HOWL:=FALSE;STOPWATCH:=FALSE;TÆNDT:=FALSE;
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);
(*@@TILPASSES*)
DESCNAVN:='????????:P?:05:J';
REGNAVN:='123456789012345678';
REGVEDL;
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('L *1',CONCAT('HOVED:P1,',FNAVN),QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.