|
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: 25280 (0x62c0)
Types: TextFile
Notes: Mikados_K
Names: »CP1LISTE.K«
└─⟦5630b2e42⟧ Bits:30009005 START APRIL 1985 aft april 1985 (PASCAL kildetekster)
└─⟦this⟧ »CP1LISTE.K«
PROGRAM CPLISTE;
CONST LNGTH=20;
MAXRECSIZE=1000;
PROGRAMNR=2;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
DIRECTBUF=PACKED ARRAY (1..LNGTH) 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(11);
DBUF:DIRECTBUF;
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;
FELTYPE:ARRAY (0..3) OF PACKED ARRAY (1..7) OF CHAR;
ELTYPE:ARRAY (0..9) OF PACKED ARRAY (1..11) OF CHAR;
GENTYPE:ARRAY (0..1) OF PACKED ARRAY (1..6) OF CHAR;
QUQ:^INTEGER;
(*$P*)
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*)
(*$IUDFØR*)
(*$P*)
(*$IFISFPROC*)
(*$P*)
PROCEDURE INITLIST;
CONST MAXPOST=150;
MAXZONES=2;
SIDEBRED=80;
TYPE
ELEMENT=^ELEMENTBESKRIVELSE;
POSITION=RECORD
X,Y:INTEGER
END;
FTYPE=(HELTAL,DOBBTAL,REEL,TEKST);
VTYPE=(HINTERVAL,DINTERVAL,RINTERVAL,DATO,CPR);
ETYPE=(LISTEDESC,PICTURE,FELT,INDKOMMANDO,UDKOMMANDO,VALIDITET,GENTAG,BEREGN,
NØGLE,KSLOP);
REPTYPE=(REPETE,WAILE);
FACTTYP=(CONSTVAR,LPEXPRP,NOTFACT);
SYMBOLTYPE=(PERIOD,EQL,LSS,GTR,NEQ,LEQ,GEQ,LPAREN,RPAREN,OTHERSYM,
PLUS,MINUS,OROP,CONSTSYM,POSTSYM,IDENTSYM,NOTOP,TEKSTSYM,
TIMES,SLASH,DIVOP,MODOP,ANDOP,SLUTSYM);
KSLOPTYPE=(EXPRESSION,SIMPLEX,TERM,FACTOR);
ELEMENTBESKRIVELSE=RECORD
NEXTELEMENT :ELEMENT;
CASE ELEMENTTYPE:ETYPE OF
LISTEDESC:
(FILES :ARRAY (.1..8.) OF INTEGER;
LINESPP :INTEGER
);
PICTURE:
(PICTPOS :POSITION;
FØRSTFELT :ELEMENT;
PICTNAVN :STRING(8)
);
INDKOMMANDO:
(GETFILREF,
GETMODE :INTEGER;
FØRSTNØGL :ELEMENT
);
UDKOMMANDO:
(PUTFILREF,
PUTMODE :INTEGER
);
NØGLE:
(NØGLETYPE :FTYPE;
NØGLEREF,
PINDEKS,
GINDEKS :INTEGER
);
GENTAG:
(LØKKETYPE :REPTYPE;
FIRSTFELT,
BETINGELSE :ELEMENT;
POSINCR :POSITION
);
BEREGN:
(UDTRYK :ELEMENT;
GEMREF, (*<0 => UDSKRIFT JVNF. FOREGÅENDE UDFELT*)
GEMINDEKS :INTEGER;
UDTRYKTYPE :FTYPE
);
VALIDITET:
(CASE VALIDITYTYPE:VTYPE OF
HINTERVAL:(MIN,MAX:INTEGER);
DINTERVAL:(MIN1,MIN2,MAX1,MAX2:INTEGER);
RINTERVAL:(RMIN,RMAX:REAL);
DATO,CPR:()
);
FELT:
(INDPOS :POSITION;
EDITERING, (*<0 => UDFELT*)
POSTREF, (*VÆRDI FÅS FRA NEXTELEMENT, BEREGNING*)
INDEKS, (*NÅR POSTREF=0 OG INDEKS<0*)
LÆNGDE,
FORAN0 :INTEGER;
CASE FELTTYPE:FTYPE OF
REEL:(DEC:INTEGER);
HELTAL,DOBBTAL,TEKST:()
);
KSLOP:
(SECOND :ELEMENT;
CASE POLISH:KSLOPTYPE OF
EXPRESSION:(EXPOP:SYMBOLTYPE);
SIMPLEX :(SIMOP1,SIMOP2:SYMBOLTYPE);
TERM :(TRMOP:SYMBOLTYPE);
FACTOR :(CASE FACTTYPE:FACTTYP OF
CONSTVAR:(CVREF,CVDEKS:INTEGER;
CVTYPE :FTYPE);
LPEXPRP,NOTFACT:())
);
END;
ELEMENTFIL=FILE OF ELEMENTBESKRIVELSE;
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;
LISTTYPE=RECORD
NAVN:STRING(30); (*LISTENS BETEGNELSE*)
DESCLIST:STRING(18); (*NAVN PÅ LISTEDEFINITIONSFILEN*)
LISTENIVEAU:NIVEAU; (*ADGANGSNIVEAUET TIL LISTEN*)
BLANKTYP, (*BLANKETTYPE*)
ZPOSTNR:INTEGER (*KONSTANTPOSTENS NR*)
END;
LISTFILE=FILE OF LISTTYPE; (*FORTEGNELSE OVER ALLE DEFINEREDE LISTER*)
ZEROFIL=FILE OF PPOST;
FILDESC=RECORD
FILNAVN:STRING(18); (*ISF-FILENS NAVN*)
DESCNAVN:STRING(18); (*NAVNET PÅ DEN ENKELTE ISF-FILS BESKRIVELSESFIL*)
POSTNAVN: STRING(18); (*NAVNET PÅ ET INDIVID I FILEN*)
REGNAVN:STRING(18); (*FILENS BETEGNELSE*)
VEDLNIVEAU:NIVEAU;(*ADGANGSNIVEAU FOR GENERELT VEDLIGEHOLDELSESPROGRAM*)
ZONESIZE:INTEGER
END;
FILEDESC=FILE OF FILDESC;(*FORTEGNELSE OVER ALLE ISF-FILER*)
SIDEFIL=FILE OF STRING(SIDEBRED);
VAR LISTEHOVED,LISTEELEMENT: ELEMENT;
NROFFILES,LINES,OPTION,I,J:INTEGER;
CH:STRING(1);
LINE:STRING;
POST:ARRAY (0..MAXZONES) OF PPOST;
AKTULIST:LISTTYPE;
ISFFILES:FILEDESC;
SIDE:SIDEFIL;
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
BEGIN
IF LINES>0 THEN PAGE(LIST); (*$R-*)
WRITELN('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN'); (*$R+*)
CH:=' ';EDIT(CH);(*IF CH='R' THEN REPORT(ZONE.H,REGISTER,1);*)
REPEAT
NROFFILES:=NROFFILES-1;
ICLOSE(POST(NROFFILES).A)
UNTIL NROFFILES=1;
EXIT(INITLIST)
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*)
PROCEDURE INITTEXT;
BEGIN
FELTYPE(0):='HELTAL ';
FELTYPE(1):='DOBBTAL';
FELTYPE(2):='REEL ';
FELTYPE(3):='TEKST ';
ELTYPE(0):='LISTEDESC ';
ELTYPE(1):='PICTURE ';
ELTYPE(2):='FELT ';
ELTYPE(3):='INDKOMMANDO';
ELTYPE(4):='UDKOMMANDO ';
ELTYPE(5):='VALIDITET ';
ELTYPE(6):='GENTAG ';
ELTYPE(7):='BEREGN ';
ELTYPE(8):='NØGLE ';
ELTYPE(9):='KSLOP ';
GENTYPE(0):='REPEAT';
GENTYPE(1):='WHILE ';
END;
(*$P*)
(*$XT*)
PROCEDURE OPLYS;
VAR I,J,OPTION,PRNIVEAU:INTEGER;
NÅET:BOOLEAN;
PROCEDURE PRINTEL(VAR EL:ELEMENT);
VAR I:INTEGER;
PROCEDURE PRINT1;
BEGIN
WITH EL^ DO
CASE ELEMENTTYPE OF
LISTEDESC:BEGIN
WRITE(LIST,'FILES');
FOR I:=1 TO 8 DO WRITE(LIST,FILES(I):3);
WRITELN(LIST);
WRITELN(LIST,' ':PRNIVEAU+3,'LINESPP',LINESPP:4)
END;
PICTURE: BEGIN
WRITELN(LIST,'NAVN ',PICTNAVN,' POSITION',
PICTPOS.X:3,PICTPOS.Y:3);
WRITELN(LIST,' ':PRNIVEAU+3,'FØRSTFELT');
PRINTEL(FØRSTFELT);
END;
INDKOMMANDO:
BEGIN
WRITELN(LIST,'GETFILREF',GETFILREF:3,
' GETMODE',GETMODE:3);
WRITELN(LIST,' ':PRNIVEAU+3,'FØRSTNØGL');
PRINTEL(FØRSTNØGL)
END;
UDKOMMANDO:WRITELN(LIST,'PUTFILREF',PUTFILREF:3,
' PUTMODE',PUTMODE:3);
NØGLE: WRITELN(LIST,'NØGLETYPE ',FELTYPE(ORD(NØGLETYPE)),
' NØGLEREF',NØGLEREF:3,
' PINDEKS',PINDEKS:3,
' GINDEKS',GINDEKS:3);
GENTAG: BEGIN
WRITELN(LIST,'LØKKETYPE ',GENTYPE(ORD(LØKKETYPE)),
' POSINCR',POSINCR.X:6,POSINCR.Y:6);
WRITELN(LIST,' ':PRNIVEAU+3,'BETINGELSE');
PRINTEL(BETINGELSE);
WRITELN(LIST,' ':PRNIVEAU+3,'FIRSTFELT');
PRINTEL(FIRSTFELT)
END;
BEREGN :BEGIN
WRITELN(LIST,'GEMREF',GEMREF:3,
' GEMINDEKS',GEMINDEKS:4,
' UDTRYKTYPE ',FELTYPE(ORD(UDTRYKTYPE)));
WRITELN(LIST,' ':PRNIVEAU+3,'UDTRYK');
PRINTEL(UDTRYK)
END;
VALIDITET:BEGIN
CASE VALIDITYTYPE OF
HINTERVAL:WRITELN(LIST,'HINTERVAL MIN MAX',MIN:8,MAX:8);
DINTERVAL:WRITELN(LIST,'DINTERVAL MIN MAX',
MIN1*10000.0+MIN2:10:-2,
MAX1*10000.0+MAX2:10:-2);
RINTERVAL:WRITELN(LIST,'RINTERVAL MIN MAX',RMIN:10:-2,
RMAX:10:-2);
DATO:WRITELN(LIST,'DATO');
CPR:WRITELN(LIST,'CPR')
END
END;
END
END;
BEGIN
IF EL<>NIL THEN
WITH EL^ DO
BEGIN
PRNIVEAU:=PRNIVEAU+1;
WRITELN(LIST,PRNIVEAU:3,' ':PRNIVEAU,'Elementtype ',
ELTYPE(ORD(ELEMENTTYPE)));
WRITE(LIST,' ':PRNIVEAU+3);
CASE ELEMENTTYPE OF
FELT : BEGIN
WRITELN(LIST,'INDPOS',INDPOS.X:5,INDPOS.Y:5,
' EDITERING',EDITERING:2,
' POSTREF',POSTREF:3,
' INDEKS',INDEKS:4,
' LÆNGDE',LÆNGDE:3,
' FORAN0',FORAN0:3);
WRITE(LIST,' ':PRNIVEAU+3,'FELTTYPE ',
FELTYPE(ORD(FELTTYPE)));
IF FELTTYPE=REEL THEN WRITELN(LIST,' DEC',DEC:3)
ELSE WRITELN(LIST)
END;
KSLOP : BEGIN
CASE POLISH OF
EXPRESSION:BEGIN
WRITELN(LIST,'EXPRESSION');
PRINTEL(NEXTELEMENT);
PRINTEL(SECOND);
WRITELN(LIST,ORD(EXPOP))
END;
SIMPLEX: BEGIN
WRITELN(LIST,'SIMPLEX');
IF SIMOP1<>OROP THEN
WRITELN(LIST,ORD(SIMOP1));
PRINTEL(NEXTELEMENT);
IF SIMOP2<>OROP THEN
BEGIN
PRINTEL(SECOND);
WRITELN(LIST,ORD(SIMOP2))
END
END;
TERM: BEGIN
WRITELN(LIST,'TERM');
PRINTEL(NEXTELEMENT);
PRINTEL(SECOND);
WRITELN(LIST,ORD(TRMOP))
END;
FACTOR: BEGIN
WRITE(LIST,'FACTOR ');
CASE FACTTYPE OF
LPEXPRP:BEGIN
WRITELN(LIST,'LPEXPRP (');
PRINTEL(NEXTELEMENT);
WRITELN(LIST,')')
END;
NOTFACT:BEGIN
WRITELN(LIST,'NOTFACT NOT');
PRINTEL(NEXTELEMENT)
END;
CONSTVAR:BEGIN
WRITELN(LIST,'CONSTVAR');
WRITELN(LIST,' ':PRNIVEAU+3,
CVREF:5,
CVDEKS:5,' ':5,
FELTYPE(ORD(CVTYPE)))
END
OTHERWISE WRITELN('HOV ',ORD(FACTTYPE))
END
END
END
OTHERWISE PRINT1;
IF ELEMENTTYPE<>KSLOP THEN
BEGIN
WRITELN(LIST,' ':PRNIVEAU+3,'NEXTELEMENT');
PRNIVEAU:=PRNIVEAU-1;
IF NEXTELEMENT<>NIL THEN
PRINTEL(NEXTELEMENT)
ELSE WRITELN(LIST,' ':PRNIVEAU+4,'NIL');
PRNIVEAU:=PRNIVEAU+1
END;
PRNIVEAU:=PRNIVEAU-1
END
ELSE WRITELN(LIST,' ':PRNIVEAU+3,'NIL')
END;
(*$P*)
BEGIN (*OPLYS*)
PRNIVEAU:=0;
PRINTEL(LISTEHOVED)
END;
(*$X-*)
(*$P*)
(*$ILISTEIOP*)
PROCEDURE ADDPOS(VAR P1,P2,P3:POSITION);
BEGIN
P3.X:=P1.X+P2.X;
P3.Y:=P1.Y+P2.Y
END;
PROCEDURE UDSIDE;
VAR I:INTEGER;
BEGIN
LINE:='';CH:=' ';
FOR I:=1 TO SIDEBRED DO LINE:=CONCAT(LINE,CH);
FOR I:=1 TO LISTEHOVED^.LINESPP DO
BEGIN
SEEK(SIDE,I);
GET(SIDE);
WRITELN(LIST,SIDE^);
SIDE^:=LINE;
SEEK(SIDE,I);
PUT(SIDE)
END
END;
(*$P*)
PROCEDURE SÆTNØGL(VAR FILREF:INTEGER;VAR NØGL:ELEMENT);
BEGIN
WITH NØGL^ DO
BEGIN
CASE NØGLETYPE OF
HELTAL:POST(FILREF).A(PINDEKS):=POST(NØGLEREF).A(GINDEKS);
DOBBTAL:BEGIN
POST(FILREF).A(PINDEKS):=POST(NØGLEREF).A(GINDEKS);
POST(FILREF).A(PINDEKS+1):=POST(NØGLEREF).A(GINDEKS+1)
END;
REEL:POST(FILREF).AAA(PINDEKS):=POST(NØGLEREF).AAA(GINDEKS)
END;
SÆTNØGL(FILREF,NEXTELEMENT)
END
END;
(*$P*)
PROCEDURE UDFØR(VAR EL:ELEMENT;VAR PICPOS:POSITION);
VAR AKTPOS:POSITION;
RESULT:REAL;
FAILURE:BOOLEAN;
BEGIN
IF EL<>NIL THEN
WITH EL^ DO
BEGIN
WRITELN(ORD(ELEMENTTYPE):5,PICPOS.X:5,PICPOS.Y:5,MEMAVAIL:8);
CASE ELEMENTTYPE OF
PICTURE:BEGIN
ADDPOS(PICPOS,PICTPOS,AKTPOS);
UDFØR(FØRSTFELT,AKTPOS)
END;
BEREGN :IF GEMREF>=0 THEN
CASE UDTRYKTYPE OF
HELTAL :POST(GEMREF).A(GEMINDEKS):=TRUNC(VÆRDI(UDTRYK));
DOBBTAL:BEGIN
RESULT:=VÆRDI(UDTRYK);
IF ABS(RESULT)>327679999.0 THEN RESULT:=0.0;
POST(GEMREF).A(GEMINDEKS):=TRUNC(RESULT/10000.0);
POST(GEMREF).A(GEMINDEKS+1):=
TRUNC(RESULT-10000.0*POST(GEMREF).A(GEMINDEKS))
END;
REEL :POST(GEMREF).AAA(GEMINDEKS):=VÆRDI(UDTRYK)
END;
GENTAG: BEGIN
AKTPOS:=PICPOS;
CASE LØKKETYPE OF
REPETE:REPEAT
IF POSINCR.X=-32000 THEN UDSIDE;
UDFØR(FIRSTFELT,AKTPOS);
IF POSINCR.X>-32000 THEN
ADDPOS(AKTPOS,POSINCR,AKTPOS)
UNTIL VÆRDI(BETINGELSE)=1.0;
WAILE :WHILE VÆRDI(BETINGELSE)=1.0 DO
BEGIN
IF POSINCR.X=-32000 THEN UDSIDE;
UDFØR(FIRSTFELT,AKTPOS);
IF POSINCR.X>-32000 THEN
ADDPOS(AKTPOS,POSINCR,AKTPOS);
END
END
END;
INDKOMMANDO:BEGIN
IF FØRSTNØGL<>NIL THEN SÆTNØGL(GETFILREF,FØRSTNØGL);
CASE GETMODE MOD 10 OF
1,2:BEGIN (*GETREC, GETNEXT*)
GETREC(POST(GETFILREF).A);
IF (GETMODE MOD 10=2) AND (IER=-6) THEN
BEGIN
NEXTREC(POST(GETFILREF).A);
IF IER=-1 THEN IER:=0 ELSE
IF IER=0 THEN IER:=-20
END
END;
3:NEXTREC(POST(GETFILREF).A)
END;
POST(GETFILREF).A(-4):=IER;
CASE GETMODE DIV 10 OF
1:FAILURE:=IER<>-6;
2:FAILURE:=(IER<>-6) AND (IER<>0);
3:FAILURE:=IER<>-1;
4:FAILURE:=IER>0;
5:FAILURE:=(IER<>-1) AND (IER<>-2) AND (IER<>-9)
OTHERWISE FAILURE:=IER<>0;
IF FAILURE THEN ERROR(POST(GETFILREF).A)
END;
UDKOMMANDO:BEGIN
END;
FELT :BEGIN
IF EDITERING>0 THEN
LÆSFELT(EL)
ELSE
BEGIN
IF (POSTREF=0) AND (INDEKS<0) THEN
BEGIN
RESULT:=VÆRDI(NEXTELEMENT^.UDTRYK);
CASE FELTTYPE OF
REEL:POST(0).AAA(INDEKS):=RESULT;
HELTAL:IF ABS(RESULT)<=32000.0 THEN
POST(0).A(INDEKS):=TRUNC(RESULT)
ELSE POST(0).A(INDEKS):=0;
DOBBTAL:BEGIN
IF ABS(RESULT)>327679999.0 THEN RESULT:=0.0;
POST(0).A(INDEKS):=TRUNC(RESULT/10000.0);
POST(0).A(INDEKS+1):=TRUNC(RESULT-10000.0*
POST(0).A(INDEKS))
END
END;
END;
ADDPOS(PICPOS,INDPOS,AKTPOS);
SKRIVFELT(EL,AKTPOS)
END
END
END;
WRITELN(MEMAVAIL:8);
UDFØR(EL^.NEXTELEMENT,PICPOS)
END
END;
(*$P*)
PROCEDURE SKRIVLIST;
VAR J:INTEGER;
CH:STRING(1);
STARTPOS:POSITION;
BEGIN
(*SØRGER FOR SELVE UDSKRIVNINGEN*)
STARTPOS.X:=0;
STARTPOS.Y:=0;
UDFØR(LISTEHOVED^.NEXTELEMENT,STARTPOS);
UDSIDE
END;
(*$P*)
PROCEDURE VÆLGLISTE;
VAR LISTER:LISTFILE;
I,LISTENR:INTEGER;
BEGIN
(*VALG AF UDSKRIFT*)
FNAVN:='LISTDEFS:P2:0000:S';
REWRITE(LISTER,FNAVN);IOC;
REPEAT
CLEARSCREEN;
SEEK(LISTER,1);IOC;
LISTENR:=0;
REPEAT
GET(LISTER);IOC;
IF LISTER^.NAVN(1)<>'@' THEN
BEGIN
GOTOXY(LISTENR MOD 2*38+1,LISTENR DIV 2+1);
LISTENR:=LISTENR+1;
WRITELN(LISTENR:3,' ',LISTER^.NAVN)
END
UNTIL LISTER^.NAVN(1)='@';
REPEAT
GOTOXY(1,23);
WRITELN('Listenummer, 0 for færdig');
GOTOXY(27,23);READLN;READ(I)
UNTIL (IORESULT=0) AND (I>=0) AND (I<=LISTENR);
IF I>0 THEN
BEGIN
SEEK(LISTER,I);IOC;
GET(LISTER);IOC;
AKTULIST:=LISTER^
END
ELSE AKTULIST.NAVN(1):='@'
UNTIL (I=0) OR (AKTULIST.LISTENIVEAU<=USERNIVEAU)
END;
(*$P*)
PROCEDURE INDELEMENT;
VAR FFIL:ELEMENTFIL;
PROCEDURE INDNUL;
VAR FIL0:ZEROFIL;
BEGIN
FNAVN:='ZEROFILE:P2:0000:S';
REWRITE(FIL0,FNAVN);IOC;
SEEK(FIL0,AKTULIST.ZPOSTNR);IOC;
GET(FIL0);IOC;
POST(0):=FIL0^;
CLOSE(FIL0)
END;
FUNCTION NÆSTE:ELEMENT;
VAR I:INTEGER;
THIS:ELEMENT;
BEGIN
GET(FFIL);IOC;
CASE FFIL^.ELEMENTTYPE OF
LISTEDESC:BEGIN
NEW(THIS,LISTEDESC);
THIS^:=FFIL^;
(*
THIS^.ELEMENTTYPE:=LISTEDESC;
FOR I:=1 TO 8 DO THIS^.FILES(I):=FFIL^.FILES(I);
IF FFIL^.NEXTELEMENT<>NIL THEN
THIS^.NEXTELEMENT:=NÆSTE
ELSE
THIS^.NEXTELEMENT:=NIL
*)
END;
PICTURE: BEGIN
NEW(THIS,PICTURE);
THIS^:=FFIL^;
(*
THIS^.ELEMENTTYPE:=PICTURE;
THIS^.PICTPOS:=FFIL^.PICTPOS;
THIS^.NEXTELEMENT:=FFIL^.NEXTELEMENT;
*)
IF THIS^.FØRSTFELT<>NIL THEN
THIS^.FØRSTFELT:=NÆSTE
END;
INDKOMMANDO:BEGIN
NEW(THIS,INDKOMMANDO);
THIS^:=FFIL^;
IF THIS^.FØRSTNØGL<>NIL THEN THIS^.FØRSTNØGL:=NÆSTE;
END;
UDKOMMANDO:BEGIN
NEW(THIS,UDKOMMANDO);
THIS^:=FFIL^
END;
NØGLE:BEGIN
NEW(THIS,NØGLE);
THIS^:=FFIL^
END;
GENTAG:BEGIN
NEW(THIS,GENTAG);
THIS^:=FFIL^;
IF THIS^.FIRSTFELT<>NIL THEN THIS^.FIRSTFELT:=NÆSTE;
IF THIS^.BETINGELSE<>NIL THEN THIS^.BETINGELSE:=NÆSTE
END;
BEREGN:BEGIN
NEW(THIS,BEREGN);
THIS^:=FFIL^;
IF THIS^.UDTRYK<>NIL THEN THIS^.UDTRYK:=NÆSTE
END;
VALIDITET:BEGIN
CASE FFIL^.VALIDITYTYPE OF
HINTERVAL:NEW(THIS,VALIDITET,HINTERVAL);
DINTERVAL:NEW(THIS,VALIDITET,DINTERVAL);
RINTERVAL:NEW(THIS,VALIDITET,RINTERVAL);
DATO,CPR :NEW(THIS,VALIDITET,DATO)
END;
THIS^:=FFIL^
END;
FELT:BEGIN
CASE FFIL^.FELTTYPE OF
REEL:NEW(THIS,FELT,REEL);
HELTAL,DOBBTAL,TEKST:NEW(THIS,FELT,HELTAL)
END;
THIS^:=FFIL^
END;
KSLOP:BEGIN
CASE FFIL^.POLISH OF
EXPRESSION:NEW(THIS,KSLOP,EXPRESSION);
SIMPLEX :NEW(THIS,KSLOP,SIMPLEX);
TERM :NEW(THIS,KSLOP,TERM);
FACTOR :CASE FFIL^.FACTTYPE OF
CONSTVAR:NEW(THIS,KSLOP,FACTOR,CONSTVAR);
LPEXPRP,NOTFACT:NEW(THIS,KSLOP,FACTOR,LPEXPRP)
END
END;
THIS^:=FFIL^;
IF THIS^.SECOND<>NIL THEN THIS^.SECOND:=NÆSTE
END
END;
IF THIS^.NEXTELEMENT<>NIL THEN THIS^.NEXTELEMENT:=NÆSTE;
NÆSTE:=THIS
END;
BEGIN
INDNUL;
REWRITE(FFIL,AKTULIST.DESCLIST);IOC;
LISTEHOVED:=NÆSTE;
CLOSE(FFIL)
(*INDLÆS NEXTELEMENT, SÆT REFERENCE*)
END;
(*$P*)
PROCEDURE PATENTLUK;
BEGIN
INDELEMENT; (*ÅBNER ELEMENTBESKR., INDLÆSER LISTER, LUKKER FILEN*)
(*ÅBNING OG LUKNING AF DATAFILER*)
NROFFILES:=1;
WHILE (NROFFILES<=MAXZONES) AND (LISTEHOVED^.FILES(NROFFILES)>0) DO
BEGIN
POST(NROFFILES).A(-3):=LISTEHOVED^.FILES(NROFFILES);
MODE:=2;
IOPEN(POST(NROFFILES).A);
IF IER<>0 THEN OFEJL(POST(NROFFILES).A);
NROFFILES:=NROFFILES+1
END;
FNAVN:='SIDEFIL:P2:0040:K';
REWRITE(SIDE,FNAVN);IOC;
LINE:='';CH:=' ';
FOR I:=1 TO SIDEBRED DO LINE:=CONCAT(LINE,CH);
FOR I:=1 TO LISTEHOVED^.LINESPP DO
BEGIN
SEEK(SIDE,I);IOC;
SIDE^:=LINE;
PUT(SIDE);IOC
END;
INITTEXT;
(*$XT*) OPLYS;PAGE(LIST); (*$X-*)
IF LISTEHOVED^.FILES(NROFFILES)>0 THEN
BEGIN
WRITELN('FOR MANGE ISF-FILER, RETURN');READLN
END
ELSE
SKRIVLIST;
CLOSE(SIDE);
REPEAT
NROFFILES:=NROFFILES-1;
ICLOSE(POST(NROFFILES).A);
IF IER<>0 THEN BAD(6,IER)
UNTIL NROFFILES=1
END;
(*$P*)
BEGIN
REPEAT
VÆLGLISTE;
IF AKTULIST.NAVN(1)<>'@' THEN
BEGIN
MARK(QUQ);
PATENTLUK; (*OPNÅR LUKNING AF FILER VED PROCEDUREUDGANG*)
RELEASE(QUQ)
END
UNTIL AKTULIST.NAVN(1)='@'
END;
(*$P*)
BEGIN
I:=ORD(PARM^(1))-48;
USERNIVEAU:=MENIG;
WHILE I>0 DO
BEGIN
USERNIVEAU:=SUCC(USERNIVEAU);
I:=I-1
END;
(*$XT*) WRITELN(MEMAVAIL);READLN; (*$X-*)
(*$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);
INITLIST;
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.