DataMuseum.dk

top - metrics - download

    Length: 10208 (0x27e0)
    Notes: Mikados TextFile, Mikados_K
    Names: »FILETEST«

└─⟦89d8689a3⟧ Bits:30003591 MIKADOS Pascal compiler (01.02.1982 E)
    └─⟦this⟧ »FILETEST« 

Text

PROGRAM FILETEST;
 
       (***************************************************)
       (*                                                 *)
       (*   CREATION AND UPDATING OF A PERSON FILE        *)
       (*                                                 *)
       (* DEMONSTRATION OF DIRECT FILES AND THE USE OF    *)
       (* THE EDIT PROCEDURE IN MIKADOS PASCAL            *)
       (***************************************************)
 
 
TYPE STATUS = ( MARRIED, WIDOW, DIVORCED, BACHELOR );
     ALFA = STRING(30);
     TXT = STRING(18);
     DATE = RECORD DAY: 1..31;
                   MONTH: 1..12;
                   YEAR: INTEGER
            END;
     PERSON = RECORD
                NAME: RECORD
                        FIRSTNAME, LASTNAME: ALFA
                      END;
                SEX: (MAN, WOMAN, UNKNOWN);
                BIRTHDAY: DATE;
                CASE MARRIEDSTATUS: STATUS OF
                  MARRIED,
                  WIDOW:    (MARRIAGEDATE: DATE);
                  DIVORCED: (DIVDATE: DATE;
                             NUMBEROFDIVORCES: INTEGER);
                  BACHELOR: (INDEPENDENT: BOOLEAN)
              END (*PERSON*);
 
VAR  REGISTER: FILE OF PERSON;
     MSTATUS, CODE: ALFA;
     FINISHED, OK: BOOLEAN;
     OPCODE, ANSWER : CHAR;
     RECORDNUMBER: INTEGER;
     IOVAL: INTEGER;
 
 
       (***************************************************)
       (* GENERALLY USEFUL PROCEDURE THAT ILLUSTRATES HOW *)
       (* THE EDIT PROCEDURE MAY BE USED TO EDIT INTEGERS *)
       (* IF OPCODE<>'A' A NEW INTEGER IS ENTERED         *)
       (* IF OPCODE ='A' THE PRESENT CONTENTS OF THE      *)
       (*      INTEGER ARE PRESENTED ON THE TERMINAL AND  *)
       (*      EDITED BY THE USER                         *)
       (***************************************************)
 
PROCEDURE ENTERINTEGER( INVITATION: TXT;
                        VAR NUMBER: INTEGER );
  VAR SIZE,INDEX: INTEGER;
      INTSTRING: STRING(6);
      SIGN, CH: CHAR;
      DIGITS, FINISHED: BOOLEAN;
BEGIN
  INDEX := 18;
  WHILE INVITATION(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITE( INVITATION:INDEX, ' ' );
  INTSTRING := '      ';
  IF OPCODE='A' THEN
    BEGIN
    INDEX:=0;
    IF NUMBER<0 THEN
      BEGIN
      NUMBER:=-NUMBER;
      INDEX:=1;
      INTSTRING(1):='-'
      END;
    SIZE:=10000;
    WHILE NUMBER<SIZE DO
      SIZE := SIZE DIV 10;
    REPEAT
      BEGIN
      INDEX:=INDEX+1;
      INTSTRING(INDEX):= CHR( NUMBER DIV SIZE + ORD('0'));
      NUMBER := NUMBER MOD SIZE;
      SIZE := SIZE DIV 10;
      END;
    UNTIL SIZE=0;
    END;
  EDIT( INTSTRING:6 );
  INDEX := 1;
  FINISHED := FALSE;
  DIGITS := FALSE;
  SIGN := ' ';
  NUMBER := 0;
  REPEAT
    BEGIN
    CH := INTSTRING(INDEX);
    IF CH IN (.'+','-'.) THEN
      IF DIGITS OR (SIGN<>' ') THEN FINISHED:=TRUE
      ELSE SIGN:= CH
    ELSE
      IF CH IN (.'0'..'9'.) THEN
        BEGIN
        NUMBER := NUMBER*10 + ORD(CH) - ORD('0');
        DIGITS := TRUE
        END
      ELSE FINISHED:=TRUE;
    INDEX := INDEX + 1;
    END;
  UNTIL FINISHED OR (INDEX>6);
  IF SIGN='-' THEN NUMBER:=-NUMBER;
END  (*ENTERINTEGER*);
 
PROCEDURE ENTERSTRING( INVITATION: TXT;
                       VAR EDITSTRING: ALFA;
                       LENGTH: INTEGER );
  VAR INDEX: INTEGER;
BEGIN
  INDEX:=18;
  WHILE INVITATION(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITE( INVITATION:INDEX, ' ' );
  IF OPCODE='C' THEN
    BEGIN
    FILLCHAR( EDITSTRING(1), LENGTH, ' ' );
    (*$R-*)  EDITSTRING(0) := CHR(LENGTH);  (*$R+*)
    END;
  EDIT( EDITSTRING:LENGTH )
END (*ENTERSTRING*);
 
PROCEDURE ENTERDATE( INVITATION: TXT;
                     VAR EDITDATE: DATE );
  VAR INDEX: INTEGER;
BEGIN
  INDEX:= 18;
  WHILE INVITATION(INDEX)=' ' DO INDEX:=INDEX-1;
  WRITELN( INVITATION:INDEX );
  WITH EDITDATE DO
    BEGIN
    ENTERINTEGER( 'DAY               ', DAY );
    ENTERINTEGER( 'MONTH             ', MONTH );
    ENTERINTEGER( 'YEAR              ', YEAR );
    END;
END  (*ENTERDATE*);
 
PROCEDURE ENTERCOMMAND;
BEGIN
  REPEAT
    BEGIN
    WRITE( 'OPERATION (C-CREATE, A-ALTER, E-END) ' );
    WHILE EOLN DO READLN;
    READ( OPCODE );
    END;
  UNTIL OPCODE IN (.'C','A','E'.);
END;
 
PROCEDURE ENTERSTATUS;
BEGIN
  IF OPCODE='A' THEN
    CASE REGISTER^.MARRIEDSTATUS OF
      MARRIED:  MSTATUS := 'MARRIED ';
      WIDOW:    MSTATUS := 'WIDOW   ';
      DIVORCED: MSTATUS := 'DIVORCED';
      BACHELOR: MSTATUS := 'BACHELOR';
    END
  ELSE MSTATUS := '    ';
  REPEAT
    BEGIN
    WRITE( 'ENTER MARRIED STATUS (M/W/D/B) ' );
    EDIT( MSTATUS );
    END;
  UNTIL MSTATUS(1) IN (.'M','W','D','B'.);
END;
 
 
BEGIN
REWRITE( REGISTER, 'PERSDATA:P2:10' );
FINISHED := FALSE;
REPEAT
  BEGIN
  CLEARSCREEN;
  OK := TRUE;
  ENTERCOMMAND;
  IF OPCODE<>'E' THEN
    BEGIN
    WRITELN;
    WRITE( 'ENTER RECORD NUMBER ' );
    READ( RECORDNUMBER );
    SEEK( REGISTER, RECORDNUMBER );
    IF IORESULT<>0 THEN
      BEGIN
      IOVAL:=IORESULT;
      WRITE( 'ERROR ', IOVAL, ' WHEN LOOKING IN FILE' );
      WRITE(' - STRIKE RETURN:');
      READLN;
      OK := FALSE
      END;
    IF OK AND (OPCODE='A') THEN
      BEGIN
      GET( REGISTER );
      IF IORESULT<>0 THEN
        BEGIN
        WRITELN( 'ERROR ', IORESULT, ' WHEN READING RECORD');
        OK := FALSE
        END
      ELSE SEEK( REGISTER, RECORDNUMBER );
      END;
    IF OK THEN
      BEGIN
      WITH REGISTER^,NAME DO
        BEGIN
        ENTERSTRING('FIRST NAME        ', FIRSTNAME, 30 );
        ENTERSTRING('LAST NAME         ', LASTNAME, 30 );
        CODE := ' ';
        REPEAT
          BEGIN
          IF OPCODE='A' THEN
            CASE SEX OF
              MAN:     CODE := 'M';
              WOMAN:   CODE := 'W';
              UNKNOWN: CODE := 'U';
            END;
          ENTERSTRING('SEX (M/W/U)       ', CODE, 1 );
          END;
        UNTIL CODE(1) IN (.'M','W','U'.);
        CASE CODE(1) OF
          'M': SEX := MAN;
          'W': SEX := WOMAN;
          'U': SEX := UNKNOWN;
        END;
        ENTERDATE( 'BIRTHDAY:         ', BIRTHDAY );
        ENTERSTATUS;
        CASE MSTATUS(1) OF
          'M','W': BEGIN
                 IF MSTATUS(1)='M' THEN MARRIEDSTATUS:=MARRIED
                                ELSE MARRIEDSTATUS:=WIDOW;
                 WRITE( 'DATE OF ');
                 ENTERDATE('MARRIAGE:         ',MARRIAGEDATE);
               END;
          'D': BEGIN
                 MARRIEDSTATUS:=DIVORCED;
                 ENTERDATE('DATE OF DIVORCE:  ', DIVDATE );
                 ENTERINTEGER('# OF DIVORCES     ',NUMBEROFDIVORCES);
               END;
          'B': BEGIN
                 MARRIEDSTATUS:=BACHELOR;
                 REPEAT
                   BEGIN
                   WRITE('INDEPENDET (Y/N) ');
                   WHILE EOLN DO READLN;
                   READ( ANSWER )
                   END;
                 UNTIL ANSWER IN (.'Y','N'.);
                 INDEPENDENT := ANSWER = 'Y';
               END;
        END (* CASE MSTATUS *)
        END (*WITH REGISTER^*);
      PUT( REGISTER );
      END  (*IF OK*);
    END (*OPKODE<>'E'*);
  END (*REPEAT*) ;
UNTIL OPCODE='E';
WRITELN('FILETEST TERMINATED');
END (*FILETEST*).