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

OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE conc,upcase,frontstrip,rest,checkextension;
EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;
EXTERNAL LONG REAL PROCEDURE scanreal;
EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog;
EXTERNAL BOOLEAN PROCEDURE menu;
EXTERNAL CLASS safeio;
safeio CLASS dbmtxt;
VIRTUAL: PROCEDURE dbadr;
BEGIN
  CHARACTER cdelim,nullc,split_char;
  TEXT delim,slash;
  BOOLEAN defined__f,array__in;
  INTEGER k__,rlength,next__pos;
  TEXT a__t,t_t,oldt_t;

  ! -------------------------------------------------------
  Classes for dynamic representation of arrays. They are created
  from the text a_t which should, when e g new int__arr(7) is
  executed contain all the elements (in this case seven integers
  separated with spaces) as required by the
  procedures NEXT*** ( ***=INT,REAL or TEXT) as specified below
  ________________________________________________________;

  CLASS int__arr(dim); INTEGER dim;
  BEGIN INTEGER ARRAY vekt(1:dim); oldt_t:-t_t; t_t:-a__t;
    FOR k__:=1 STEP 1 UNTIL dim DO vekt(k__):=nextint;
    t_t:-oldt_t;
  END of int__arr;

  CLASS real__arr(dim); INTEGER dim;
  BEGIN REAL ARRAY vekt(1:dim);oldt_t:-t_t; t_t:-a__t;
    FOR k__:=1 STEP 1 UNTIL dim DO vekt(k__):=nextreal;
    t_t:-oldt_t;
  END of real__arr;

  CLASS text__arr(dim); INTEGER dim;
  BEGIN TEXT ARRAY vekt(1:dim+1);oldt_t:-t_t; t_t:-a__t;
    FOR k__:=1 STEP 1 UNTIL dim DO vekt(k__):-nexttext;
    t_t:-oldt_t;
  END of text__arr;

  PROCEDURE stringrequest(prompt,default,variable,
  validity,errmessage,help);
  ! -----------------------------------------------------------
  Analoguous to the REQUEST procedure in SAFEIO, except that
  the input string may be several lines, is started with a
  special character (not contained in string) and terminated
  by the next occurence of that character.
  -------------------------------------------------------;
  NAME default,validity,errmessage,variable,prompt,help;
  TEXT prompt,default,variable,errmessage;   BOOLEAN validity;
  BOOLEAN help;
  BEGIN   CHARACTER c1,c2;   TEXT t;   BOOLEAN saveswitch;
    saveswitch:= displaydefault;
    start:
    request(prompt,default,textinput(variable,TRUE),NOTEXT,help);
    IF variable == NOTEXT THEN
    BEGIN
      IF validity THEN GO TO exit;
      error:
      outline(errmessage);   GO TO start
    END notext;
    c1:= variable.Getchar;
    IF variable.Length > 1 THEN
    c2:= variable.Sub(variable.Length,1).Getchar;
    displaydefault:= FALSE;
    WHILE c1 NE c2 DO
    BEGIN   t:- NOTEXT;
      WHILE t == NOTEXT DO
      request(NOTEXT,NOTEXT,textinput(t,TRUE),NOTEXT,help);
      variable:- conc(variable,t);
      c2:= t.Sub(t.Length,1).Getchar;
    END loop;
    IF NOT validity THEN GO TO error;
    exit:
    displaydefault:= saveswitch;
    IF variable.Length > 2 THEN
    variable:-variable.Sub(2,variable.Length-2);
  END of stringrequest;

  REF (Directfile) PROCEDURE opendf;
  ! -------------------------------------------------------
  Prompt the user to give name and imagesize for direct file
  Check if the first record of the file is nonempty, if so
  it is assumed to be an existent SIMDBM data base, and the
  varaible DEFINED__F is set true
  ___________________________________________________________;
  BEGIN TEXT t,u; REF (Directfile) d;
    request("Give name of data base file: ",
    "x.tmp",textinput(t,TRUE),"?",
    help("Name of an existent SIMDBM data base"));
    request("image size:","72",textinput(u,checkint(u) > 0),
    "Must be integer",
    help("Optimal choice: multiple of five - 2"));
    d:-NEW Directfile(conc(t,conc(Copy("/imagesize:"),u)));
    rlength:=u.Getint;
    d.Open(Blanks(rlength));
    opendf:-d;
    INSPECT d DO
    BEGIN ! check if it is an initialized DBMSIM file;
      Locate(1); IF \Endfile THEN
      BEGIN
	Inimage; IF Image.Strip \= "/*" THEN
	defined__f:=TRUE;
    END;END;
  END of opendf;

  INTEGER PROCEDURE loc(t,seekc,stopc); NAME t;
  ! -----------------------------------------------------
  Return as value POS for the character following the
  next occurence (after POS) of the character SEEKC in T.
  Return LOC=0 if SEEKC isn't found or if STOPC is found
  before SEEKC.
  ---------------------------------------------------------;
  TEXT t; CHARACTER seekc,stopc;
  BEGIN CHARACTER c;
    l1: IF t.More THEN c:=t.Getchar ELSE
    BEGIN loc:=0; GOTO fin; END; IF c = seekc THEN
    BEGIN loc := t.Pos; GOTO fin; END;
    IF c = stopc THEN BEGIN loc := 0; GOTO fin; END;
    GOTO l1;
    fin:
  END of loc;

  TEXT PROCEDURE locfield(t,n); TEXT t; INTEGER n;
  ! ----------------------------------------------------------
  Locate nth string in text t.  A string is either a number with
  spaces around it, or a text starting and ending with the same
  special character.
  The global variable NEXT__POS points after the located string
  on exit from LOCFIELD.
  ___________________________________________________________;
  BEGIN CHARACTER c,cc; INTEGER i; BOOLEAN error;

    BOOLEAN PROCEDURE digsign(c); CHARACTER c;
    digsign:=Digit(c) OR
    c = '.' OR c = '+' OR c = '-';

    CHARACTER PROCEDURE getch;
    IF t.More THEN getch:=t.Getchar ELSE
    BEGIN error:=TRUE; GOTO fin; END;

    c := ' ';
    next:
    WHILE c = ' ' DO c := getch;
    i := i + 1; IF i < n THEN
    BEGIN COMMENT bypass one more field;
      cc := nullc;
      IF digsign(c) THEN
      BEGIN WHILE c \= ' ' DO  c := getch; END ELSE
      BEGIN COMMENT bypass non-numeric string;
	WHILE cc \= c DO cc := getch; c := ' ';
      END;
      GOTO next;
    END;
    COMMENT pick up next string and return as value;
    i := t.Pos - 1;
    IF digsign(c) THEN BEGIN WHILE c \= ' ' DO
    c := getch; END ELSE
    BEGIN i := i+1; cc := nullc;
    WHILE cc \= c DO cc := getch; END;
    fin: IF NOT error THEN
    locfield :- Copy(t.Sub(i,t.Pos-i-1));
    next__pos:=t.Pos;
  END of locfield;

  CHARACTER PROCEDURE leftchar;
  BEGIN CHARACTER c;
    c:=' ';
    WHILE c = ' ' AND t_t.More DO c:=t_t.Getchar;
    t_t.Setpos(t_t.Pos-1);
    leftchar:=c;
  END of leftchar;

  !------------------------------------------------------
  The following six procedures are used to pick one
  element from a text, either
  A number
  A text surrounded with quotes
  An array surrounded with slashes.
  The variable array__in is used to capture the end
  of an array.
  -------------------------------------------------------;

  INTEGER PROCEDURE nextint;
  IF leftchar = '/' THEN array__in:=FALSE ELSE
  BEGIN
    t_t:-rest(t_t);
    IF checkint(t_t) > 0 THEN nextint:=t_t.Getint ELSE
    BEGIN
      outline("Nextint:  Illegal integer item in line:");
      outline(t_t);
    END;
  END of nextint;

  REAL PROCEDURE nextreal;
  IF leftchar = '/' THEN array__in:=FALSE ELSE
  BEGIN
    t_t:- rest(t_t);
    IF checkreal(t_t) > 0 THEN nextreal:=t_t.Getreal ELSE
    BEGIN
      outline("Nextreal:  Illegal real item in record:");
      outline(t_t);
    END;
  END of nextreal
  ;
  REF (int__arr) PROCEDURE nextiarr;
  BEGIN
    array__in:=TRUE; IF leftchar = '/' THEN
    BEGIN
      t_t.Setpos(t_t.Pos+1); k__:=0;
      a__t:-rest(t_t); nextint;    WHILE array__in DO
      BEGIN k__:=k__+1; nextint; END;
      t_t.Setpos(t_t.Pos+1);
      IF k__ > 0 THEN nextiarr:-NEW int__arr(k__);
    END;
  END of nextiarr;


  REF (real__arr) PROCEDURE nextrarr;
  BEGIN
    array__in:=TRUE; IF leftchar = '/' THEN
    BEGIN
      t_t.Setpos(t_t.Pos+1); k__:=0;
      a__t:-rest(t_t); nextreal;
      WHILE array__in DO
      BEGIN k__:=k__+1; nextreal; END;
      t_t.Setpos(t_t.Pos+1);
      IF k__ > 0 THEN nextrarr:-NEW real__arr(k__);
    END;
  END of nextrarr;

  REF (text__arr) PROCEDURE nexttarr;
  BEGIN
    array__in:=TRUE; IF leftchar = '/' THEN
    BEGIN
      t_t.Setpos(t_t.Pos+1); k__:=0;
      a__t:-rest(t_t); nexttext;        WHILE array__in DO
      BEGIN k__:=k__+1; nexttext; END;
      t_t.Setpos(t_t.Pos+1);
      IF k__ > 0 THEN nexttarr:-NEW text__arr(k__);
    END;
  END of nexttarr;

  TEXT PROCEDURE nexttext;
  IF leftchar = '/' THEN array__in:=FALSE ELSE
  BEGIN CHARACTER c; INTEGER n;

    WHILE t_t.More DO
    BEGIN
      c := t_t.Getchar; IF c = cdelim THEN
      BEGIN
	n := t_t.Pos; WHILE t_t.More DO
	BEGIN
	  c := t_t.Getchar; IF c = cdelim THEN
	  BEGIN nexttext:-Copy(t_t.Sub(n,t_t.Pos-n-1)); GOTO fin; END;
	END;
      END;
    END;
    outline("Nexttext:  missing text delimiter in record:");
    outline(t_t);
    nexttext:-Copy("???");
  fin:  END of nexttext;

  !------------------------------------------------------
  Procedures to store an item in a text,from pos
  and upwards, and adjusting pos of that text.
  Numbers are surrounded with spaces, texts with quotes
  and arrays with slashes. These procedures are reverses
  of the six above procedures.
  If there is not room after pos then the text
  will be expanded with blanks.
  (ROOMCHECK is used to check this)
  -------------------------------------------------------;

  PROCEDURE puti(i,t); NAME t; INTEGER i; TEXT t;
  putnumber(intput(i),t); !END of puti;

  PROCEDURE putr(r,t); NAME t; REAL r; TEXT t;
  putnumber(realput(r),t); ! END of putr;

  PROCEDURE putiarr(a,t); NAME t;
  REF (int__arr) a; TEXT t;
  BEGIN INTEGER n;
    n:=a.dim; putnumber(slash,t);
    FOR k__:=1 STEP 1 UNTIL n DO puti(a.vekt(k__),t);
    putnumber(slash,t);
  END of putiarr;

  PROCEDURE putrarr(a,t); NAME t;
  REF (real__arr) a; TEXT t;
  BEGIN INTEGER n;
    n:=a.dim; putnumber(slash,t);
    FOR k__:=1 STEP 1 UNTIL n DO putr(a.vekt(k__),t);
    putnumber(slash,t);
  END of putrarr;

  PROCEDURE puttarr(a,t); NAME t;
  REF (text__arr) a; TEXT t;
  BEGIN INTEGER n;
    n:=a.dim; putnumber(slash,t);
    FOR k__:=1 STEP 1 UNTIL n DO putt(a.vekt(k__),t);
    putnumber(slash,t);
  END of puttarr;

  PROCEDURE roomcheck(u,t); NAME t; TEXT u,t;
  BEGIN INTEGER n;
    IF t.Length-t.Pos < u.Length+3 THEN
    BEGIN ! replace t with a longer text;
      n:=t.Pos;
      t:-conc(t,Blanks(u.Length+4)); t.Setpos(n);
    END;
  END of roomcheck;

  PROCEDURE putnumber(u,t); NAME t; TEXT u,t;
  BEGIN ! output text without quotes;
    roomcheck(u,t);
    t.Sub(t.Pos,u.Length) := u; t.Setpos(t.Pos+1+u.Length);
  END of putnumber;

  PROCEDURE putt(u,t); NAME t; TEXT u,t;
  BEGIN
    IF u.Length = 0 THEN u:-Copy("notext");
    roomcheck(u,t);
    t.Sub(t.Pos,1) := delim; t.Sub(t.Pos+1,u.Length) := u;
    t.Sub(t.Pos+1+u.Length,1) := delim;
    t.Setpos(t.Pos+3+u.Length);
  END of putt;

  INTEGER PROCEDURE dbadr(t,bsize,base); TEXT t;
  INTEGER bsize,base;
  !---------------------------------------------------------
  Computing of a pseudo-adres within a database-area.
  ---------------------------------------------------------;
  BEGIN INTEGER n;
    t.Setpos(1); IF checkint(t) > 0 THEN n:=t.Getint ELSE
    WHILE t.More DO n := n + Rank(t.Getchar);
    dbadr := Mod(n,bsize) + base;
  END of dbadr;

  INTEGER PROCEDURE loctext(t,a); TEXT t; TEXT ARRAY a;
  !---------------------------------------------------------
  Locate text t in array a, if present return index
  for it otherwise return zero. a should be logically
  ended with an element=NOTEXT.
  ---------------------------------------------------------;
  BEGIN INTEGER n;
    FOR n:= n+1 WHILE a(n) =/= NOTEXT DO
    IF t=a(n) THEN BEGIN loctext:=n; GOTO fin; END;
  fin:  END of loctext;


  INTEGER PROCEDURE split(t,txarr);
  TEXT t; TEXT ARRAY txarr;
  !---------------------------------------------------------
  Text t contains characters separated into groups with a
  delimiter SPLIT_CHAR. SPLIT separates t into parts and
  delivers each part as one element in TXARR.
  Number of elements is returned as value.
  TXARR should be at least 1 longer than the number of
  elements.
  The element after the last is set=NOTEXT.
  To facilitate:
  Example:

  if SPLIT_CHAR =',' and
  t = "A,B,CCC,DD,FGH"
  then the call  n:=split(t,txarr)
  will give n=5 and
  txarr(1)="A"
  txarr(2)="B"
  .......
  txarr(6)=notext
  ---------------------------------------------------------;
  BEGIN CHARACTER c; INTEGER n,k;
    n:=1; k:=0; t.Setpos(1);
    WHILE t.More DO
    BEGIN
      c:=t.Getchar; IF c = split_char THEN
      BEGIN
	k:=k+1; txarr(k):-Copy(t.Sub(n,t.Pos-n-1)); n:=t.Pos;
      END;
    END;
    IF t.Length > 0 THEN
    BEGIN  k:=k+1; txarr(k):-Copy(t.Sub(n,t.Length-n+1)); END;
    txarr(k+1):-NOTEXT;
    split:=k;
  END of split;


END of class dbmtxt;