Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

OPTIONS(/e/l);
EXTERNAL CHARACTER PROCEDURE fetchar, getch;
EXTERNAL INTEGER PROCEDURE trmop, gettab, checkreal, checkint;
EXTERNAL PROCEDURE depchar, echo, abort, outchr, forceout, outstring;
EXTERNAL TEXT PROCEDURE frontstrip, upcase, storbokstav, tmpin, scanto;
EXTERNAL BOOLEAN PROCEDURE tmpout, meny;
EXTERNAL CLASS vista, termty;
vista CLASS form;
NOT HIDDEN PROTECTED myinimage, show_page, ask_page, field,
intfield, realfield, choicefield, alphafield, first_field,
stopasking;
NOT HIDDEN height, echon, echoff, terminaltype,
resume_display, cancel_display, start_blink, stop_blink,
cause_real_time_delay, get_char_from_screen,
synchronize, restore_the_whole_screen,
home_the_cursor, set_char_on_screen,
outchar, blank_line, outimage, outtext, make_blank,
outfix, outreal, outint,
restore_one_char,
insingle, inimage, inint, inreal,
inword, inyes, move_the_cursor_to, blank_the_screen,
stopblink, startblink,
horizontalpos, verticalpos,
up, down, left, right, altmode,
carriagereturn, linefeed, home, fill,
null, tab, formfeed, verttab,
controlchar, screen, echoenabled;
BEGIN
  REF (field) last_field, first_field, main_field,
  temp_field;
  BOOLEAN error_is_blinking, got_movechar, stopask,
  last_is_controlchar;
  INTEGER errmesslength, i, line, order, cover_length;
  CHARACTER c, movechar; TEXT temp_answer;

  PROCEDURE stopasking; stopask:= TRUE;


  PROCEDURE myinimage(length, stopchar);
  INTEGER length; CHARACTER stopchar;
  BEGIN
    BOOLEAN nostopchar; INTEGER count, firstpos;
    firstpos:= horizontalpos;
    sysin.image:= NOTEXT;
    sysin.image.setpos(1);
    WHILE TRUE DO
    BEGIN
      IF count > length THEN GOTO out;
      c:= insingle(TRUE);
      IF NOT nostopchar THEN
      nostopchar:= stopchar NE c ELSE IF c = stopchar THEN
      GOTO out;
      IF NOT controlchar AND c NE fill THEN
      BEGIN
        sysin.image.putchar(c); count:= count+1;
        last_is_controlchar:= FALSE;
        IF c = '?' AND count = 1 THEN GOTO outfast;
      END ELSE
      BEGIN
                 IF c =
      carriagereturn THEN
      BEGIN insingle(TRUE);
        GOTO outfast;
      END;
      last_is_controlchar:= TRUE;
      BEGIN
        IF c NE fill THEN GOTO out;
        last_is_controlchar:= FALSE;
        IF horizontalpos < firstpos THEN
        move_the_cursor_to(firstpos,verticalpos);
        IF sysin.pos > 1 THEN
        BEGIN
          IF echoenabled THEN
          BEGIN
            IF count <= 0 THEN outchar(' ');
          END ELSE
          BEGIN
            sysin.setpos(sysin.pos-1);
            sysin.image.putchar(' ');
            sysin.setpos(sysin.pos-1);
          END;
          END;
        END;
      END;
    END;
    out: IF c NE tab THEN
    sysin.image.putchar(c);
    outfast: sysin.image.setpos(1);
  END;

  PROCEDURE show_page;
  BEGIN
    FOR temp_field:- first_field,
    temp_field.next WHILE temp_field =/= NONE DO
    INSPECT temp_field DO
    BEGIN
      putheader; answer:- NOTEXT;
    END;
  END;

  PROCEDURE ask_page;
  BEGIN
    loop: IF stopask THEN stopask:= FALSE ELSE
    FOR temp_field:- first_field,
    temp_field.next WHILE temp_field =/= NONE DO
    IF temp_field.answer = NOTEXT THEN
    BEGIN
      resume(temp_field);
      GOTO loop;
    END;
    sysout.breakoutimage;
  END;

  CLASS field(h,v,header,length,stopchar, helptext);
  VALUE header, helptext;
  INTEGER h, v, length; CHARACTER stopchar;
  TEXT header, helptext;
  VIRTUAL: PROCEDURE help;
  BEGIN
    TEXT answer; INTEGER orderinline;
    REF(field) next;

    PROCEDURE help;
    BEGIN
      IF helptext == NOTEXT THEN helptext:-
      copy("There is no HELP available here");
      blank_line(18);
      move_the_cursor_to(0,18); outtext(helptext); breakoutimage;
      error_is_blinking:= TRUE;
    END;

    PROCEDURE error(errmess); VALUE errmess; TEXT errmess;
    BEGIN
      move_the_cursor_to(0,18); start_blink;
      outtext("->"); stop_blink;
      outtext(errmess);
      error_is_blinking:= TRUE;
      errmesslength:= errmess.length;
      GOTO get_answer;
    END;

    PROCEDURE putheader;
    IF header =/= NOTEXT THEN
    BEGIN
      move_the_cursor_to(h,v); outtext(header);
    END;

    PROCEDURE screen_answer(answer);
    TEXT answer;
    COMMENT will put answer onto screen,
    covering cover_length chars;
    BEGIN
      move_the_cursor_to(h+header.length+1,v);
      outtext(answer);
      make_blank(length-answer.length);
    END;

    PROCEDURE change_answer(new_answer);
    VALUE new_answer; TEXT new_answer;
    BEGIN
      i:= answer.length;
      answer:- new_answer;
      screen_answer(answer);
    END;

    IF last_field =/= NONE THEN last_field.next:- THIS
    field;
    last_field:- THIS field;
    IF first_field == NONE THEN first_field:- THIS field;
    IF line NE v THEN
    BEGIN
      line:= v; order:= orderinline:= 1;
    END ELSE
    BEGIN orderinline:= order:= order+1;
    END;
    detach;
    get_answer:
    move_the_cursor_to(h+header.length+1,v);
    IF echoenabled THEN inimage ELSE
    myinimage(length,stopchar);
    temp_answer:- copy(frontstrip(sysin.image.strip));
    IF temp_answer = "?" THEN
    BEGIN help; GOTO get_answer;
    END;
    IF sysin.image.sub(1,1) = " " AND temp_answer =/= NOTEXT
    THEN screen_answer(temp_answer);
    movechar:= IF temp_answer == NOTEXT THEN ' ' ELSE
    temp_answer.sub(temp_answer.length,1).getchar;
    got_movechar:= IF last_is_controlchar THEN
    movechar = left OR movechar = right
    OR movechar = up OR movechar = down
    OR movechar = home ELSE FALSE;
    IF error_is_blinking THEN
    BEGIN
      blank_line(18); error_is_blinking:= FALSE;
      IF answer.length > temp_answer.length THEN
      BEGIN
        move_the_cursor_to(h+header.length+1
        +temp_answer.length-
        (IF got_movechar THEN 1 ELSE 0),v);
        cover_length:= answer.length-temp_answer.length
        +(IF got_movechar THEN 1 ELSE 0);
        FOR i:= 1 STEP 1 UNTIL cover_length DO outchar(' ');
      END;
      answer:- NOTEXT;
    END;
    IF answer.length > temp_answer.length AND
    NOT (NOT echoenabled AND got_movechar
    AND temp_answer.length = 1) THEN
    BEGIN
      move_the_cursor_to(h+header.length+1+temp_answer.
      length, v);
      cover_length:= answer.length;
      FOR i:= temp_answer.length+1 STEP 1 UNTIL
      cover_length DO outchar(' ');
    END;
    IF (IF temp_answer == NOTEXT THEN FALSE
    ELSE temp_answer.sub(1,1) = "^") THEN
    BEGIN
      TEXT searched; REF(field) test_field;
      screen_answer(answer);
      searched:- temp_answer.sub(2,temp_answer.length-1);
      test_field:- first_field;
      WHILE test_field =/= NONE DO
      BEGIN
        IF test_field.header.length >= searched.length
        THEN
        BEGIN
          IF test_field.header.sub(1,
          searched.length) = searched THEN
          BEGIN
            IF test_field =/= THIS field THEN
            BEGIN
              IF main_field == NONE THEN main_field:-
              THIS field;
              resume(test_field);
            END;
            GOTO get_answer;
          END;
        END;
        test_field:- test_field.next;
      END;
      error("No such header.");
    END;
    IF NOT echoenabled THEN
    BEGIN
      IF got_movechar THEN
      BEGIN
        INTEGER goalline, goalorder;
        BOOLEAN modified_goal;
        REF (field) test_field, back_field;
        IF movechar = home THEN
        BEGIN goalline:= 0; goalorder:= 1;
        END ELSE IF movechar = left THEN
        BEGIN goalline:= v; goalorder:= orderinline-1;
          IF goalorder < 1 THEN goalorder:= 1;
        END ELSE IF movechar = right THEN
        BEGIN goalline:= v; goalorder:= orderinline+1;
        END ELSE IF movechar = up THEN
        BEGIN goalline:= v-1; goalorder:= orderinline;
        END ELSE IF movechar = down THEN
        BEGIN goalline:= v+1; goalorder:= orderinline;
        END;
        test_field:- first_field;
        WHILE test_field =/= NONE DO
        BEGIN
          tryagain: IF test_field.v = goalline AND
          test_field.orderinline =
          goalorder THEN GOTO found;
          IF test_field.v > goalline THEN
          BEGIN
            IF back_field =/= NONE THEN
            BEGIN
              IF movechar = up AND NOT modified_goal THEN
              BEGIN
                modified_goal:= TRUE;
                goalline:= back_field.v;
                test_field:-first_field;
                GOTO tryagain;
              END ELSE IF movechar = down THEN
              BEGIN
                IF test_field.v-back_field.v>1 THEN
                goalline:=
                goalline+test_field.v-back_field.v-1;
                GOTO tryagain;
              END;
            END;
            GOTO backfound;
          END;
          back_field:- test_field;
          test_field:- test_field.next;
        END;
        IF movechar = down AND NOT modified_goal THEN
        BEGIN
          modified_goal:= TRUE;
          goalline:= goalline-1;
          test_field:- first_field;
          GOTO tryagain;
        END;
        backfound: IF back_field =/= NONE
        THEN test_field:- back_field;
        found: IF test_field =/= THIS field THEN
        BEGIN
          IF main_field == NONE THEN main_field:-
          THIS field;
          resume(test_field);
        END;
        GOTO get_answer;
      END;
    END;
    answer:- temp_answer;
    INNER; IF main_field == NONE THEN detach ELSE
    BEGIN temp_field:- main_field; main_field:- NONE;
      IF temp_field =/= THIS field AND
      temp_field.answer == NOTEXT THEN
      resume(temp_field) ELSE detach;
    END;
    GOTO get_answer;
  END of field;

  field CLASS intfield(min,max,rangerror);
  VALUE rangerror; INTEGER min, max; TEXT rangerror;
  BEGIN
    INTEGER intvalue;
    answer.setpos(1);
    IF checkint(answer) >= 1 AND NOT answer.more THEN
    BEGIN
      answer.setpos(1); intvalue:= answer.getint;
      IF intvalue < min OR intvalue > max THEN
      error(rangerror);
    END ELSE error("Integer input was expected.");
  END;

  field CLASS realfield(min,max,rangerror);
  VALUE rangerror; REAL min, max; TEXT rangerror;
  BEGIN
    REAL realvalue;
    answer.setpos(1);
    IF checkreal(answer) >= 1 AND NOT answer.more THEN
    BEGIN
      answer.setpos(1); realvalue:= answer.getreal;
      IF realvalue < min OR realvalue > max THEN
      error(rangerror);
    END ELSE error("Integer input was expected.");
  END;

  field CLASS choicefield(nonemessage);
  VALUE nonemessage; TEXT nonemessage;
  BEGIN
    CLASS choice(choicetext);
    VALUE choicetext; TEXT choicetext;
    BEGIN
      REF (choice) nextchoice;
      upcase(choicetext);
      IF lastchoice =/= NONE THEN
      lastchoice.nextchoice:- THIS choice ELSE
      firstchoice:- THIS choice;
      lastchoice:- THIS choice;
    END;
    REF (choice) firstchoice, lastchoice, tempchoice;
    REF (choice) foundchoice;
    foundchoice:- NONE;
    upcase(answer);
    IF answer =/= NOTEXT THEN
    BEGIN
      tempchoice:- firstchoice;
      WHILE tempchoice =/= NONE DO
      BEGIN
        INSPECT tempchoice DO
        IF answer.length <= choicetext.length THEN
        BEGIN
          IF choicetext.sub(1,answer.length) = answer THEN
          BEGIN
            IF answer.length EQ choicetext.length THEN
            GOTO good;
            IF foundchoice =/= NONE THEN
            BEGIN
              error("Ambiguous entry, give more characters.");
              GOTO good;
            END;
            foundchoice:- tempchoice;
          END;
        END;
        tempchoice:- tempchoice.nextchoice;
      END;
    END;
    IF foundchoice == NONE THEN error(nonemessage)
    ELSE change_answer(foundchoice.choicetext);
    good:
  END of choicefield;

  field CLASS alphafield;
  BEGIN
    answer.setpos(1);
    WHILE answer.more DO
    BEGIN
      c:= answer.getchar;
      IF NOT letter(c) AND c NE ' ' THEN
      error("Only letters accepted in answer.");
    END;
  END of alphafield;
  line:= -1;
END of form;