MODULE keypoint_file_processor;

  CONST
    c_time = 2,
    c_timedif = 16,
    c_data = 25,
    c_dataerr = 37,
    c_dataid = 38,
    c_exclam = 47,
    c_trap = 48,
    c_mtrflag = 49,
    c_taskord = 51,
    c_levelzero = 54,
    c_section = 55,
    c_classid = 58,
    c_msg = 61,
    single_quote_code = 39;

*copyc osd$keypoints
*copyc OSK$KEYPOINT_CLASS_CODES

  TYPE
    keypoint_class_set = set of char,
    p_task_status = ^task_status_type,
    task_status_type = packed record
      mtrmode: boolean,
      traprtn: array [boolean] of boolean,
      time: integer,
    recend,
    pmf_record_type = (pmfr_keypoint, pmfr_overflow),
    pmf_record = record
      rec_type: pmf_record_type,
      time: 0 .. 3ffffff(16),
      class: 0 .. 0f(16),
      kcode: 0 .. 0ffffffff(16),
    recend,
    range_of_osk$m = 0 .. (osk$m - 1),
    flags = string (1),
    p_keypoint_rec = ^keypoint_rec,
    keypoint_rec = record
      class: 0 .. 16,
      data_length: range_of_osk$m,
      flag: flags,
      match_length: range_of_osk$m,
      match_value: range_of_osk$m,
      data_formatting: char,
      p_next: p_keypoint_rec,
      data_id: string (8),
      msg: string (40),
      count: integer,
    recend,
    area_keypoints = packed array [ * ] of p_keypoint_rec,
    p_area_keypoints = ^area_keypoints,
    p_area_rec_type = ^area_rec,
    area_rec = record
      section_id: string (31),
      low_base,
      high_base: range_of_osk$m,
      keypoint_array: p_area_keypoints,
      p_next: p_area_rec_type,
    recend,
    base_rec = record
      id: string (31),
      value: integer,
    recend,
    descriptor_code_array = packed array [char] of 0 .. 16;

?? SET (CHKALL := OFF) ??
?? PUSH (LISTEXT := ON) ??
*copyc PXIOTYP
*callall  lgz
*callall biz
*callall fz
?? POP ??
?? EJECT ??
{--------------------------------------------------------------------}
{--------------------------------------------------------------------}

  VAR
    current_class_code: array [0 .. 15] of char := [REP 16 of '*'],
    bases: array [1 .. 4] of base_rec := [['OSK$SYSTEM_CLASS',
      osk$system_class], ['OSK$PRODUCT_SET_CLASS', osk$product_set_class], [
      'OSK$USER_CLASS', osk$user_class], ['OSK$PMF_CONTROL', osk$pmf_control]],
    descriptor_code: descriptor_code_array,
    task_status_array: array [0 .. 255] of task_status_type,
    taskindex: integer,
    set_of_classes: keypoint_class_set,
    size_array: array [0 .. 52] of integer,
    maxprocid: integer,
    ignore_undefined: boolean,
    task_status: p_task_status,
    keybuf: array [1 .. 100] of pmf_record,
    keyindex,
    maxkeyindex: integer,
    descriptor_file,
    keyfile: file,
    kp: pmf_record,
    outline: string (136),
    p_descriptor: p_area_rec_type,
    listfile: file,
    mark: file_mark,
    tokl,
    lnlimit,
    i,
    j,
    int: integer,
    simicolon_found: boolean,
    input_line: string (136),
    tok: string (33);

?? EJECT ??
{--------------------------------------------------------------------}

{--------------------------------------------------------------------}

  PROCEDURE error (st: string ( * ));

    write_outline (' * * * * error - ');
    write_outline (st);

  PROCEND error;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bcdtobin (str: string ( * );
        xlen: integer;
    VAR inperr: range_of_osk$m);

    VAR
      len: integer,
      base: range_of_osk$m,
      strbase: string (15),
      ch: char,
      i,
      k: integer;

    int := 0;
    len := xlen;
    IF len = 0 THEN
      RETURN;
    IFEND;

    IF str (len) = ')' THEN
      i := 1;
      WHILE str (i) <> '(' DO
        i := i + 1;
        IF i = len THEN
          error ('invalid base');
          write_outline (str);
          inperr := 1;
          RETURN;
        IFEND;
      WHILEND;
      strbase (1, len - i - 1) := str (i + 1, len - i - 1);
      bcdtobin (strbase, len - i - 1, base);
      len := i - 1;
    ELSE
      base := 10;
    IFEND;

    i := 1;
    WHILE i <= len DO
      ch := str (i);
      k := ORD (ch) - ORD ('0');
      IF (k > 9) OR (k < 0) THEN
        k := ORD (ch) - ORD ('A') + 10;
      IFEND;

      IF (k < 0) OR (k >= base) THEN
        inperr := 1;
        error ('non numeric in numeric field');
        write_outline (str);
        RETURN;
      IFEND;
      int := int * base + k;
      i := i + 1;
    WHILEND;


    inperr := int;
  PROCEND bcdtobin;

?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE bintohex (VAR s: string ( * );
        xi: integer);

    VAR
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 16;
      IF k <= 9 THEN
        s (j) := CHR (k + ORD ('0'));
      ELSE
        s (j) := CHR (k - 10 + ORD ('A'));
      IFEND;
      i := i DIV 16;
      j := j - 1;
    UNTIL (j = 0);

  PROCEND bintohex;
?? SKIP := 3 ??

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bintodec (VAR s: string ( * );
        xi: integer);

    VAR
      neg: char,
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    IF i < 0 THEN
      i := 0 - i;
      neg := '-';
    ELSE
      neg := ' ';
    IFEND;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 10;
      IF k <= 9 THEN
        s (j) := CHR (k + ORD ('0'));
      ELSE
        s (j) := CHR (k - 10 + ORD ('A'));
      IFEND;
      i := i DIV 10;
      j := j - 1;
    UNTIL (j = 0) OR ((i = 0));
    IF j <> 0 THEN
      s (j) := neg;
    IFEND;

  PROCEND bintodec;
?? SKIP := 3 ??

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE bintoascii (VAR s: string ( * );
        xi: integer);

    VAR
      i,
      j,
      k: integer;

    j := STRLENGTH (s);
    i := xi;
    FOR k := 1 TO j DO
      s (k) := ' ';
    FOREND;

    REPEAT
      k := i MOD 256;
      i := i DIV 256;
      IF k = 0 THEN
        s (j) := ' ';
      ELSE
        s (j) := CHR (k);
      IFEND;
      j := j - 1;
    UNTIL (j = 0) OR (i = 0);

  PROCEND bintoascii;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE gettoken (VAR input_line: string ( * );
    VAR inx: integer;
    VAR buf: string ( * );
    VAR len: integer);




    VAR
      i: integer,
      comflag: boolean;

    len := STRLENGTH (buf);
    FOR i := 1 TO len DO
      buf (i) := ' ';
    FOREND;

    comflag := FALSE;
    len := 0;

  /scanloop/

    WHILE TRUE DO
      WHILE (inx <> STRLENGTH (input_line)) AND (input_line (inx) = ' ') DO
        inx := inx + 1;
      WHILEND;
      IF inx = STRLENGTH (input_line) THEN
        IF mark = data# THEN
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          inx := 1;
          CYCLE /scanloop/;
        ELSE
          RETURN;
        IFEND;
      IFEND;

      IF (input_line (inx) = ',') AND (comflag = FALSE) THEN
        comflag := TRUE;
        inx := inx + 1;

        CYCLE /scanloop/;
      IFEND;
      EXIT /scanloop/;
    WHILEND /scanloop/;


    WHILE (inx <> STRLENGTH (input_line)) AND ((input_line (inx) <> ' ') AND
          (input_line (inx) <> ',')) DO
      len := len + 1;

      IF (ORD (input_line (inx)) < ORD ('a')) OR (ORD (input_line (inx)) > ORD
            ('z')) THEN
        buf (len) := input_line (inx);
      ELSE
        buf (len) := CHR (ORD (input_line (inx)) - (ORD ('a') - ORD ('A')));
      IFEND;
      inx := inx + 1;
    WHILEND;


  PROCEND gettoken;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE read_descriptor (VAR p_descriptor: p_area_rec_type;
    VAR descriptor_file: file);

    VAR
      current_p_descriptor: p_area_rec_type;

    lg#open (descriptor_file, 'KEYDESC', old#, input#, first#);
    p_descriptor := NIL;
    REPEAT
      input_line := ' ';
      lg#get (descriptor_file, lnlimit, input_line);
      f#mark (descriptor_file, mark);
      j := 1;
      pass_space (j);
      IF input_line (j, * ) = '{$$$ START KEYPOINT CLASSES $$$}' THEN
        parse_defn_line (input_line, descriptor_file, descriptor_code);
      IFEND;
      IF input_line (j, * ) = '{$$$ START KEYPOINT IDENTIFIER BASES $$$}' THEN
        get_list_of_func_areas (input_line, descriptor_file, p_descriptor);
      IFEND;
      IF input_line (j, * ) = '{$$$ START KEYPOINT DESCRIPTIONS $$$}' THEN
        current_p_descriptor := p_descriptor;
        generate_keypoint_records (input_line, descriptor_file, p_descriptor,
              current_p_descriptor);
      IFEND;
    UNTIL (mark <> data#);
    lg#close (descriptor_file, first#);
  PROCEND read_descriptor;

?? EJECT ??
{----------------------------------------------------------------}
{----------------------------------------------------------------}

  PROCEDURE get_list_of_func_areas (VAR input_line: string ( * );
        descriptor_file: file;
    VAR p_area_rec: p_area_rec_type);

    VAR
      termination_found: boolean,
      i,
      j,
      k,
      lnlimit: integer,
      temp_p_area_rec: p_area_rec_type;

    PROCEDURE get_empty_area_rec (VAR p_area_rec: p_area_rec_type);
      ALLOCATE p_area_rec;
      IF p_area_rec = NIL THEN
        FOR i := 1 TO 20 DO
          write_outline ('need more memory');
        FOREND;
      ELSE
        p_area_rec^.section_id := '     ';
        p_area_rec^.low_base := 0;
        p_area_rec^.high_base := 0;
        p_area_rec^.keypoint_array := NIL;
        p_area_rec^.p_next := NIL;
      IFEND;
    PROCEND get_empty_area_rec;
    termination_found := FALSE;
    WHILE (NOT termination_found) AND (mark = data#) DO
      REPEAT
        j := 1;
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        k := 1;
        pass_space (k);
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT IDENTIFIER BASES $$$}';
        gettoken (input_line, j, tok, tokl);
      UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IF tok (3, 2) = 'K$' THEN
        get_empty_area_rec (temp_p_area_rec);
        parse_area_line (input_line, temp_p_area_rec);
        temp_p_area_rec^.p_next := p_area_rec;
        p_area_rec := temp_p_area_rec;
        input_line := ' ';
      IFEND;
    WHILEND;
  PROCEND get_list_of_func_areas;

?? EJECT ??
{----------------------------------------------------------------}
{----------------------------------------------------------------}

  PROCEDURE parse_defn_line (VAR input_line: string ( * );
        descriptor_file: file;
    VAR descriptor_code: descriptor_code_array);

    VAR
      termination_found: boolean,
      j,
      k,
      base: integer,
      offset: range_of_osk$m,
      code_count: integer;

    set_of_classes := $keypoint_class_set [];
    termination_found := FALSE;
    code_count := 1;
    WHILE (NOT termination_found) AND (mark = data#) DO
      REPEAT
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        j := 1;
        k := 1;
        gettoken (input_line, j, tok, tokl);
        pass_space (k);
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT CLASSES $$$}';
      UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IF tok (3, 2) = 'K$' THEN
        gettoken (input_line, j, tok, tokl);
        gettoken (input_line, j, tok, tokl);
        base := 16;
        FOR i := 1 TO UPPERBOUND (bases) DO
          IF tok = bases [i].id THEN
            base := bases [i].value;
          IFEND;
        FOREND;
        gettoken (input_line, j, tok, tokl);
        gettoken (input_line, j, tok, tokl);
        IF tokl > 1 THEN
          bcdtobin (tok, tokl - 1, offset);
        ELSE
          bcdtobin (tok, 1, offset);
        IFEND;
        gettoken (input_line, j, tok, tokl);
        IF base + offset < 16 THEN
          descriptor_code [tok (2)] := base + offset;
          set_of_classes := set_of_classes + $keypoint_class_set [tok (2)];
          current_class_code [base + offset] := tok (2);
        ELSE
          descriptor_code [tok (2)] := 16;
        IFEND;
        code_count := code_count + 1;
      IFEND;
    WHILEND;
  PROCEND parse_defn_line;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_area_line (VAR input_line: string ( * );
        p_area_rec: p_area_rec_type);

    VAR
      j: integer;

    j := 1;
    gettoken (input_line, j, tok, tokl);
    p_area_rec^.section_id := tok;
    simicolon_found := FALSE;
    WHILE (tok (1) <> '{') AND (j < 100) DO
      IF tok (tokl, 1) = ';' THEN
        simicolon_found := TRUE;
      IFEND;
      gettoken (input_line, j, tok, tokl);
    WHILEND;
    tok (1, 1) := '0';
    bcdtobin (tok, tokl, p_area_rec^.low_base);
    gettoken (input_line, j, tok, tokl);
    gettoken (input_line, j, tok, tokl);
    bcdtobin (tok, tokl - 1, p_area_rec^.high_base);
  PROCEND parse_area_line;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE generate_keypoint_records (VAR input_line: string ( * );
        descriptor_file: file;
        p_descriptor: p_area_rec_type;
    VAR current_p_descriptor: p_area_rec_type);

    VAR
      termination_found: boolean,
      offset: range_of_osk$m,
      k: integer,
      p_descriptor_record: p_keypoint_rec;

    current_p_descriptor := p_descriptor;
    termination_found := FALSE;
    tok := ' ';
    WHILE (NOT termination_found) AND (mark = data#) DO
      IF tok (3, 2) <> 'K$' THEN
        REPEAT
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          j := 1;
          gettoken (input_line, j, tok, tokl);
          k := 1;
          pass_space (k);
          termination_found := input_line (k, * ) =
            '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
        UNTIL (tok (3, 2) = 'K$') OR (mark <> data#) OR termination_found;
      IFEND;
      IF tok (3, 2) = 'K$' THEN
        parse_keypoint_line (input_line, p_descriptor, current_p_descriptor,
              offset);
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        k := 1;
        WHILE (input_line (k) = ' ') AND (k < 132) DO
          k := k + 1;
        WHILEND;
        termination_found := input_line (k, * ) =
          '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
        j := 1;
        IF k < 132 THEN
          gettoken (input_line, j, tok, tokl);
        ELSE
          tok := ' ';
        IFEND;
        WHILE (offset >= 0) AND (mark = data#) AND (j <= 132) AND (tok (1, 1) =
              '{') AND (tok (2, 1) IN set_of_classes) DO
          parse_descriptor_line (input_line, p_descriptor_record);
          IF (p_descriptor <> NIL) AND (current_p_descriptor <> NIL) THEN
            IF current_p_descriptor^.keypoint_array = NIL THEN
              ALLOCATE current_p_descriptor^.keypoint_array:
                    [current_p_descriptor^.low_base .. current_p_descriptor^.
                    high_base];
              IF current_p_descriptor^.keypoint_array = NIL THEN
                FOR i := 1 TO 20 DO
                  write_outline ('need more memory');
                FOREND;
              ELSE
                FOR i := current_p_descriptor^.low_base TO
                      current_p_descriptor^.high_base DO
                  current_p_descriptor^.keypoint_array^ [i] := NIL;
                FOREND;
              IFEND;
            IFEND;
            IF (current_p_descriptor^.keypoint_array <> NIL) AND
                  ((current_p_descriptor^.low_base + offset) <=
                  current_p_descriptor^.high_base) THEN
              p_descriptor_record^.p_next := current_p_descriptor^.
                    keypoint_array^ [offset + current_p_descriptor^.low_base];
              current_p_descriptor^.keypoint_array^ [offset +
                    current_p_descriptor^.low_base] := p_descriptor_record;
              bintodec (tok, offset + current_p_descriptor^.low_base);
              p_descriptor_record := current_p_descriptor^.keypoint_array^
                    [offset + current_p_descriptor^.low_base];
            IFEND;
          IFEND;
          input_line := ' ';
          lg#get (descriptor_file, lnlimit, input_line);
          f#mark (descriptor_file, mark);
          k := 1;
          WHILE (input_line (k) = ' ') AND (k < 132) DO
            k := k + 1;
          WHILEND;
          termination_found := input_line (k, * ) =
            '{$$$ END KEYPOINT DESCRIPTIONS $$$}';
          j := 1;
          IF k < 132 THEN
            gettoken (input_line, j, tok, tokl);
          ELSE
            tok := ' ';
          IFEND;
        WHILEND;
      IFEND;
    WHILEND;
  PROCEND generate_keypoint_records;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_keypoint_line (VAR input_line: string ( * );
        p_descriptor: p_area_rec_type;
    VAR current_p_descriptor: p_area_rec_type;
    VAR offset: range_of_osk$m);
    offset := 0;
    j := 1;
    REPEAT
      gettoken (input_line, j, tok, tokl);
    UNTIL (tok = '=') OR (j > 130);
    IF tok <> '=' THEN
      RETURN
    IFEND;
    gettoken (input_line, j, tok, tokl);
    IF (tok (tokl) = ',') OR (tok (tokl) = ';') THEN
      tok (tokl) := ' ';
      j := j - 1;
      tokl := tokl - 1;
    IFEND;
    IF (tok <> current_p_descriptor^.section_id) THEN
      search (p_descriptor, tok, current_p_descriptor);
      IF current_p_descriptor = NIL THEN
        current_p_descriptor := p_descriptor;
        RETURN;
      IFEND;
    IFEND;
    pass_space (j);
    IF input_line (j, 1) <> '+' THEN
      offset := 0;
    ELSE
      j := j + 1;
      gettoken (input_line, j, tok, tokl);
      IF (tok (tokl) = ',') OR (tok (tokl) = ';') THEN
        bcdtobin (tok, tokl - 1, offset);
      ELSE
        bcdtobin (tok, tokl, offset);
      IFEND;
    IFEND;
  PROCEND parse_keypoint_line;

?? EJECT ??
{-----------------------------------------------------------------}
{-----------------------------------------------------------------}

  PROCEDURE search (p_descriptor: p_area_rec_type;
        tok: string ( * );
    VAR current_p_descriptor: p_area_rec_type);
    current_p_descriptor := p_descriptor;
    WHILE (current_p_descriptor <> NIL) AND (current_p_descriptor^.section_id
          <> tok) DO
      current_p_descriptor := current_p_descriptor^.p_next;
    WHILEND;
  PROCEND search;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE parse_descriptor_line (VAR input_line: string ( * );
    VAR p_descriptor_record: p_keypoint_rec);

    VAR
      loc: integer;

    p_descriptor_record := NIL;
    loc := 1;
    WHILE (loc < 132) AND (input_line (loc) = ' ') DO
      loc := loc + 1;
    WHILEND;
    IF input_line (loc) <> '{' THEN
      RETURN
    IFEND;
    loc := loc + 1;
    IF input_line (loc) IN set_of_classes THEN
      gen_keypoint_descriptor_record (p_descriptor_record);
      p_descriptor_record^.class := descriptor_code [input_line (loc)];
      loc := loc + 1;
      pass_space (loc);
      IF (input_line (loc) = 'M') OR (input_line (loc) = 'N') OR (input_line
            (loc) = 'S') OR (input_line (loc) = 'T') THEN
        p_descriptor_record^.flag := input_line (loc);
        loc := loc + 1;
        pass_space (loc);
      IFEND;
      IF ORD (input_line (loc)) <> single_quote_code THEN
        gettoken (input_line, loc, tok, tokl);
        j := 1;
        WHILE (tok (j) <> '.') AND (j <= tokl) DO
          j := j + 1;
        WHILEND;
        bcdtobin (tok (1, j - 1), j - 1, p_descriptor_record^.match_length);
        bcdtobin (tok (j + 1, * ), tokl - j, p_descriptor_record^.match_value);
        loc := loc + 1;
        pass_space (loc);
      IFEND;
      i := 1;
      loc := loc + 1;
      WHILE (ORD (input_line (loc)) <> single_quote_code) AND (loc < 132) DO
        IF i < 41 THEN
          p_descriptor_record^.msg (i) := input_line (loc, 1);
          i := i + 1;
        IFEND;
        loc := loc + 1;
      WHILEND;
      loc := loc + 1;
      pass_space (loc);
      IF ORD (input_line (loc)) = single_quote_code THEN
        loc := loc + 1;
        i := 1;
        WHILE (ORD (input_line (loc)) <> single_quote_code) AND (loc < 132) DO
          IF i < 9 THEN
            p_descriptor_record^.data_id (i) := input_line (loc, 1);
            i := i + 1;
          IFEND;
          loc := loc + 1;
        WHILEND;
        loc := loc + 1;
        pass_space (loc);
        IF (input_line (loc) = 'A') OR (input_line (loc) = 'H') OR (input_line
              (loc) = 'I') THEN
          p_descriptor_record^.data_formatting := input_line (loc);
          loc := loc + 1;
          gettoken (input_line, loc, tok, tokl);
          IF tokl > 0 THEN
            IF tok (tokl) = '}' THEN
              bcdtobin (tok, tokl - 1, p_descriptor_record^.data_length);
            ELSE
              bcdtobin (tok, tokl, p_descriptor_record^.data_length);
            IFEND;
          IFEND;
        IFEND;
      IFEND;
    IFEND;
  PROCEND parse_descriptor_line;

?? EJECT ??
{___________
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE pass_space (VAR loc: integer);
    WHILE (input_line (loc) = ' ') AND (loc < 132) DO
      loc := loc + 1;
      IF (loc = 132) AND (mark = data#) THEN
        input_line := ' ';
        lg#get (descriptor_file, lnlimit, input_line);
        f#mark (descriptor_file, mark);
        loc := 1;
      IFEND;
    WHILEND;
  PROCEND pass_space;

?? EJECT ??
{------------------------------------------------------------------}
{------------------------------------------------------------------}

  PROCEDURE gen_keypoint_descriptor_record (VAR p_descriptor_record:
    p_keypoint_rec);
    ALLOCATE p_descriptor_record;
    IF p_descriptor_record = NIL THEN
      FOR i := 1 TO 20 DO
        write_outline ('need more memory');
      FOREND;
    ELSE
      p_descriptor_record^.class := 16;
      p_descriptor_record^.data_length := 0;
      p_descriptor_record^.flag := ' ';
      p_descriptor_record^.p_next := NIL;
      p_descriptor_record^.match_length := 0;
      p_descriptor_record^.match_value := 0;
      p_descriptor_record^.msg := ' ';
      p_descriptor_record^.data_formatting := 'I';
      p_descriptor_record^.data_id := ' ';
      p_descriptor_record^.count := 0;
    IFEND;
  PROCEND gen_keypoint_descriptor_record;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE init_task_status;

    VAR
      i: integer;

    FOR i := 0 TO UPPERBOUND (task_status_array { 1} ) DO
      task_status_array [i].mtrmode := TRUE;
      task_status_array [i].traprtn [FALSE] := FALSE;
      task_status_array [i].traprtn [TRUE] := FALSE;
      task_status_array [i].time := 0;
    FOREND;

  PROCEND init_task_status;
?? EJECT ??
{--------------------------------------------------------------------}
{--------------------------------------------------------------------}

  PROCEDURE write_outline (outline: string ( * ));

    VAR
      i: integer;

    i := STRLENGTH (outline);
    WHILE outline (i) = ' ' DO
      i := i - 1;
    WHILEND;
    IF i <> 0 THEN
      lg#put (listfile, outline (1, i));
    IFEND;

  PROCEND write_outline;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE print_keypoint_summary;

    VAR
      i: integer,
      area: p_area_rec_type,
      keypoint_rec: p_keypoint_rec,
      s8: string (8);

    lg#put (listfile, '1keypoint summary');
    outline := '  ';
    area := p_descriptor;
    WHILE area <> NIL DO
      IF area^.keypoint_array <> NIL THEN
        FOR i := area^.low_base TO area^.high_base DO
          keypoint_rec := area^.keypoint_array^ [i];
          WHILE keypoint_rec <> NIL DO
            IF keypoint_rec^.count <> 0 THEN
              bintodec (s8, keypoint_rec^.count);
              keypoint_rec^.count := 0;
              outline (10, 8) := s8;
              outline (20, 2) := area^.section_id (1, 2);
              outline (23) := current_class_code [keypoint_rec^.class];
              outline (25, 40) := keypoint_rec^.msg;
              write_outline (outline);
            IFEND;
            keypoint_rec := keypoint_rec^.p_next;
          WHILEND;
        FOREND;
      IFEND;
      area := area^.p_next;
    WHILEND;

  PROCEND print_keypoint_summary;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE get_keypoint (VAR kp: pmf_record;
        inc: boolean;
    VAR eofflag: boolean);

    IF keyindex > maxkeyindex THEN
      bi#get (keyfile, #LOC (keybuf), #SIZE (keybuf));
      f#words (keyfile, maxkeyindex);
      IF maxkeyindex = 0 THEN
        eofflag := TRUE;
        RETURN;
      IFEND;
      maxkeyindex := maxkeyindex DIV #SIZE (keybuf [1]);
      keyindex := 1;
    IFEND;
    kp := keybuf [keyindex];
    eofflag := FALSE;
    IF inc THEN
      keyindex := keyindex + 1;
    IFEND;

  PROCEND get_keypoint;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE keypoint_not_found (VAR kp: pmf_record);

    VAR
      s8: string (8);

    bintohex (s8, kp.class);

    outline (c_section, 2) := s8 (7, 2);
    bintohex (s8, kp.kcode);
    outline (c_data, 4) := '    ';
    outline (c_data + 4, 8) := s8;
    outline (c_dataid, 8) := '        ';
    bintodec (s8, (kp.kcode MOD osk$m));
    outline (c_msg, * ) := s8;

  PROCEND keypoint_not_found;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE keypoint_found (VAR kp: pmf_record;
    VAR descp: p_keypoint_rec;
    VAR area: p_area_rec_type);

    VAR
      data_value: integer,
      kp2: pmf_record,
      indent_180: [STATIC] array [0 .. 15] of integer := [0, 0, 2, 2, 4, 0, 0,
        0, 0, 0, 0, 0, 0, 0, 0, 0],
      indent: integer,
      eofflag: boolean,
      s14: string (14);

    outline (c_section, 2) := area^.section_id;
    data_value := kp.kcode DIV osk$m;
    IF descp^.data_length > 20 THEN
      get_keypoint (kp2, FALSE, eofflag);
      IF NOT eofflag AND (current_class_code [kp2.class] = ' ') THEN
        get_keypoint (kp2, TRUE, eofflag);
        data_value := data_value * 100000000(16) + kp2.kcode;
      ELSE
        outline (c_dataerr) := '*';
      IFEND;
    IFEND;
    CASE descp^.data_formatting OF
    = 'I' =
      bintodec (s14, data_value);
    = 'H' =
      bintohex (s14, data_value);
    = 'A' =
      bintoascii (s14, data_value);
    ELSE
      s14 := '              ';
    CASEND;

  /lp3/
    FOR i := 1 TO 14 - descp^.data_length * 2 DO
      IF s14 (i) <> '0' THEN
        EXIT /lp3/;
      IFEND;
      s14 (i) := ' ';
    FOREND /lp3/;
    outline (c_data, 12) := s14 (3, 12);
    outline (c_dataid, 8) := descp^.data_id;
    outline (c_msg, 16) := '                ';
    IF (descp^.flag = 'T') OR (descp^.flag = 'M') THEN
      indent := 0;
    ELSE
      indent := indent_180 [kp.class];
    IFEND;
    outline (c_msg + indent, 40) := descp^.msg;

  PROCEND keypoint_found;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE process_keypoint (VAR kp: pmf_record);

    CONST
      q = 1000000(16); {1/4th the range of kp.time}

    VAR
      s16: string (16),
      bias1: [STATIC] integer := 0,
      bias2: [STATIC] integer := 0,
      rel_time: integer,
      last_rel_time: [STATIC] integer := 0,
      area: p_area_rec_type,
      descp: p_keypoint_rec;

    outline := ' ';
    outline (c_dataerr) := ' ';
    outline (c_exclam) := '!';
    outline (c_levelzero) := ' ';
    area := p_descriptor;
    descp := NIL;

  /lp5/
    WHILE area <> NIL DO
      IF ((area^.low_base <= (kp.kcode MOD osk$m)) AND (area^.high_base >= (kp.
            kcode MOD osk$m))) AND (area^.keypoint_array <> NIL) THEN
        descp := area^.keypoint_array^ [(kp.kcode MOD osk$m)];
        WHILE (descp <> NIL) AND ((descp^.class <> kp.class) OR (descp^.
              match_value <> ((kp.kcode DIV osk$m) MOD size_array [descp^.
              match_length]))) DO
          descp := descp^.p_next;
        WHILEND;
        IF descp <> NIL THEN
          EXIT /lp5/;
        IFEND;
      IFEND;
      area := area^.p_next;
    WHILEND /lp5/;
    IF (descp = NIL) AND (ignore_undefined) THEN
      RETURN;
    IFEND;

    IF descp <> NIL THEN
      descp^.count := descp^.count + 1;

      IF (descp^.class = osk$entry) AND (descp^.flag = 'T') THEN
        task_status^.traprtn [task_status^.mtrmode] := TRUE;
      IFEND;
      IF (descp^.class = osk$entry) AND (descp^.flag = 'M') THEN
        task_status^.mtrmode := FALSE; {entry to job means exit mtr}
      IFEND;
    IFEND;

    rel_time := kp.time + bias1;
    IF kp.time < q THEN
      rel_time := rel_time + bias2;
    ELSEIF kp.time < (2 * q) THEN
      rel_time := rel_time + bias2;
      bias1 := bias1 + bias2;
      bias2 := 0;
    ELSEIF kp.time < (3 * q) THEN
      bias1 := bias1 + bias2;
      bias2 := 0;
    ELSE
      bias2 := 4 * q;
    IFEND;
    bintodec (s16, rel_time);
    outline (c_time, 13) := s16 (4, 13);
    bintohex (s16, taskindex);
    outline (c_taskord, 2) := s16 (15, 2);
    bintodec (s16, rel_time - last_rel_time);
    outline (c_timedif, 8) := s16 (9, 8);
    last_rel_time := rel_time;
    IF task_status^.mtrmode THEN
      outline (c_mtrflag) := 'M';
    ELSE
      outline (c_mtrflag) := 'J';
    IFEND;
    IF descp <> NIL THEN
      outline (c_classid) := current_class_code [descp^.class];
    ELSE
      outline (c_classid) := 'UNDEFINED';
    IFEND;
    IF task_status^.traprtn [task_status^.mtrmode] THEN
      outline (c_trap) := '*';
    ELSE
      outline (c_trap) := ' ';
    IFEND;

    IF descp = NIL THEN
      keypoint_not_found (kp);
    ELSE
      keypoint_found (kp, descp, area);
    IFEND;
    IF (current_class_code [kp.class] <> ' ') AND ((descp <> NIL) OR (NOT
          ignore_undefined)) THEN
      write_outline (outline);
    IFEND;

    IF descp <> NIL THEN
      IF (descp^.class = osk$exit) AND (descp^.flag = 'T') THEN
        task_status^.traprtn [task_status^.mtrmode] := FALSE;
      IFEND;
      IF (descp^.class = osk$exit) AND (descp^.flag = 'M') THEN
        task_status^.mtrmode := TRUE; {exit job means enter mtr}
      IFEND;
      IF (descp^.flag = 'S') THEN
        taskindex := kp.kcode DIV osk$m;
        task_status := ^task_status_array [taskindex];
      IFEND;
    IFEND;

    IF kp.rec_type = pmfr_overflow THEN
      lg#put (listfile,
        ' * * * * * * * *   LOST KEYPOINT(S) * * * * * * * * *');
    IFEND;


  PROCEND process_keypoint;
?? EJECT ??
{--------------------------------------------------------------------}

  PROCEDURE analyze_file;

    VAR
      eofflag: boolean;

    taskindex := 1;
    task_status := ^task_status_array [1];
    keyindex := 1;
    maxkeyindex := 0;
    outline := '  ';
    init_task_status;

    bi#open (keyfile, 'SESSMKF', old#, input#, first#);

    get_keypoint (kp, TRUE, eofflag);
    size_array [0] := 1;
    FOR i := 1 TO 52 DO
      size_array [i] := 2 * size_array [i - 1];
    FOREND;

  /lp6/
    WHILE NOT eofflag DO
      process_keypoint (kp);
      get_keypoint (kp, TRUE, eofflag);
    WHILEND /lp6/;

    bi#close (keyfile, first#);

    print_keypoint_summary;

  PROCEND analyze_file;
?? EJECT ??
{--------------------------------------------------------------------}

  PROGRAM [XDCL] main;

    lg#open (listfile, 'KEYFILE', old#, output#, first#);
    read_descriptor (p_descriptor, descriptor_file);

{process commands.}

    maxprocid := 256;
    ignore_undefined := FALSE;
    lg#put (listfile, '1 ');
    analyze_file;


    lg#close (listfile, first#);


  PROCEND main;

MODEND new_keypoint_interpreter;
