ftp.robelle3000.ai 2014/2014.06.ftp.robelle3000.ai.tar/ftp.robelle3000.ai/source/qaccess.spl

Text File | 1998-10-08 | 58KB | 2,101 lines

<< Qaccess/Qlib.  Routine to Read QEDIT file.  CM or NM >>
$set x5 = on               ! ON = SPL/V Off = SPLASH
$if x5=off or xsplash      ! SPL/V ignores the "OR XSPLASH"
$   set x5 = off           ! Not MPE/V, Yes SPLASH is here!
$if
$if x5=off     <<Splash>>
$control native
$if
$if x5=off and x6=on      <<Splash Debugging>>
$control debugpcal,stmt
$if x5=off and x6=off     <<No Splash debugging>>
$control nosubrnames
$if
$control subprogram,nolist,errors = 5,segment = qedit
<<
QeditAccess Intrinsic.

    programmer: Robert M. Green
                David J. Greer
                David Lo
                Robelle Consulting Ltd.
                Unit 201, 15399 - 102A Avenue
                Surrey, B.C.
                Canada   V3R 7K1
                [phone]

    Purpose:    Allows a user program to read and/or
                write QEDIT's special workfiles.

    Compiling and linking:  see Qaccess.qlibjob

    Changes:

 3.5  rmg Oct89  Convert to Native Mode.
 3.6  jim Sep90  Don't rewind file if no records read when
                 checking the language (fixes bug in Append function).
                 Release space when closing new files on MPE XL.
                 Added entry-point for current'version.
 3.8  dlo Jul90  Added function 17: read'line.
                 Can read variable length files again.
 3.9  dlo Feb92  Fixed bug in function 17 reading cobol keep files.
 4.0  dlo Apr92  Can handle message files (ref 4864)
 4.1  dlo Mar93  Added function 18: explain
 4.2  rmg May94  support jumbo files: new functions
 4.3
 4.2.01 djg Nov94  fixed bug in writing large files
                   renamed version entry from qeditaccess.. to qaccess..
 4.2.02  dlo Jun95  fixed bug in reading jumbo text files
         dlo Sep95  fixed qacc/cm problem in reading jumbo files
 4.4     dlo Jan97  check for filereclen>maxlinelen; define maxlinelen
 4.5     dlo Feb98  fixed jumbo file reading missing half of last block
>>
begin ! source

$if x5=on
define
     addrtype = integer#
    ,optiontype = option #
    ;
$if x5=off
define
     addrtype = double#
    ,optiontype = option nocc,quick,#
    ;
$if

define current'version = qaccess'4'5#;
equate rtn = 13;
define
   end'if   = end#  ,end'else = end#  ,end'while= end#
  ,end'case = end#  ,end'do   = end#  ,end'proc = end#
  ,end'subr = end#
  ,p = move pbuf:=#
  ,out = ,2;output'(*)#
  ,allocate = begin tos := #, end'alloc = ;adds 0);end#
  ,words'to = ;assemble(lra s-0;stor#
  ,bytes'to = ;assemble(inca;lsr 1;lra s-0;lsl 1;stor#
  ;

equate
   min'blocks = 4
  ;

intrinsic ascii, dascii, dbinary
         ,fcheck, fclose, ferrmsg, fopen, fread, fwrite
         ,printfileinfo, print, debug, quit, fpoint
         ,fgetinfo, father, activate, xcontrap
         ;

<< Format of block zero of qedit workfile:

   0  First Linenumber  (double)
   1
   2  Number of blocks
   3  Number of lines
   4  First empty block
   5  Flags
   6  Internal language code (0=spl)
>>
$page "qeditaccess procedure"
<<
    This is a stand-alone procedure built into the qcopy program.
    Users may install the procedure in an SL using the stream
    provided in qcopy.job or they can lift the source code and
    insert it in their own spl programs. See qcopy.doc for
    complete documentation.
>>
procedure qeditaccess (function, workspace, argument);
  integer array function;
  array workspace, argument;
  optionTYPE check 2;
begin
  entry qaccess; ! for pascal/robelle
  entry current'version; ! a define used to determine the version#
   <<WARNING:  This procedure uses the global definitions for
               "end'" constructs.  If this procedure is moved to
               another program, those defines must be moved as
               well.
   >>

!  jumbo file variables

equate    j'wl  = 512       !jumbo files
         ,regular'wl = 256 !old files
         ,u0'wi = 256      ! word index of qedit0 table in record 0
         ,u0'di = 128      ! double index of qedit0
         ,maxlinelen = 1000     ! regular jumbo files
!         ,maxlinelen = 8172     ! longlines workfile
         ;
define  block'start = (if filejumbo then 4 else 1)#
       ,block'size  = (if filejumbo then j'wl
                            else regular'wl)#
       ;
!$if x5=on <<spl-cm>>
!
!logical pointer   jbuf;        ! allocate dynamically
!double  pointer   d'jbuf = jbuf;
!byte    pointer   jbuf'  = jbuf;
!logical   jbuf'allocated := false
!         ;
!$if x5=off <<splash>>
logical array     jbuf(0:j'wl); !lots of space in native mode   ;
double  array     d'jbuf (*)= jbuf;
byte    array     jbuf'(*)  = jbuf;
logical   jbuf'allocated := true;
!$if

define    u0'lang      = jbuf(u0'wi + 4)#
         ,u0'num'lines = d'jbuf(u0'di+57)#
         ,u0'data'len  = jbuf(u0'wi + 17)#
         ;
  << language code used by Qeditaccess >>
  equate
     no'lang   = 0
    ,spl'lang  = 1
    ,ftn'lang  = 2
    ,cob'lang  = 3
    ,rpg'lang  = 4
    ,job'lang  = 5
    ,text'lang = 6 << 256 bytes>>
    ,pasc'lang = 7 <<new, treat like spl>>
    ,cobx'lang = 8 <<cobolx, instead of cobol>>
    ,data'lang = 9
    ;

  equate  max'lang   = 9
         ,max'func   = 32
         ;
  logical anysize'flag := false;
  << Convert Qedit's internal'lang to Qaccess's filelang
     rpg fix:  second last digit was 5.
  >>
  array langtable(0:max'lang)=pb:=1,2,3,4,8,5,4,6,7,9;

  << convert Qaccess's filelang to Qedit's internal'lang
  >>
  integer array int'lang(1:max'lang)=pb:=0,1,2,6,5,7,8,4,9;

  integer dummy;
  integer internal'language; <<from filebuf(6), 0=spl, 1=ftn, etc. >>

  << rpg fix:  keylefttable and keylentable changed to be indexed by
     internal'language instead of external filelang.
  >>
  array keylefttable(0:max'lang) = pb :=
    false, false, true, true, true, false, false, false, false, false;

  array keylentable (0:max'lang) = pb :=
    8,     8,     6,    5,    6,    0,     0,     0,     8,   0;

  logical foptions  <<bits 8:2=1 means variable length file>>
                    <<bits 2:3=6 means message file>>
         ,is'variable'len
         ,is'message'file
         ;
  integer fcode;
  integer integer'parm, wl'workspace:=270; <<old size>>

equate    type'keep        = 0         ! reading:
         ,type'qedit       = 1
         ,type'mpe         = 2
         ,type'new'qedit   = 3         ! writing:
         ,type'rep'mpe     = 4
         ,type'app'mpe     = 5
         ,type'rep'qedit   = 6
         ,type'app'qedit   = 7

         ,type'writing     = 3

         ;
  << define structure of the Workspace >>
  array <<equivalences>>
   filestatus       (*) = workspace
  ,filenumber       (*) = workspace(1)
  ,filetype         (*) = workspace(2)
  ,filelang         (*) = workspace(3)
  ,filereclen       (*) = workspace(4)
  ;
  double array
   filesize         (*) = workspace(5)  !  open func results
  ,filecurkey       (*) = filesize    ! read/write func, line# result
  ;
  array
   fileblock'r      (*) = workspace(7) ! see fileblock'j
  ,fileindex        (*) = workspace(8)
  ,filecurlen       (*) = workspace(9) <<read>>
  ,filenewblocks    (*) = workspace(9) <<write>>
  ,fileleft         (*) = workspace(10)
  ,filekeylen       (*) = workspace(11)

  ,filereadflags    (*) = workspace(12) ! Read flags, see below
  ,fileprevblock    (*) = workspace(12) ! Write

  ,filenewlines     (*) = workspace(13) <<write>>
  ,physbuf          (*) = workspace(14)
  ;
logical pointer
   filebuf          := @physbuf  !adjust for jumbo files
   ;
double pointer
   d'filebuf        = filebuf
   ;
byte array
   physbuf'         (*) = workspace(14)
   ;

define         ! read mode flags (not WRITE!)
   fileserial           = filereadflags.(15:1)#
  ,filejumbo            = filereadflags.(14:1)#
  ,filefirstread        = filereadflags.(13:1)#
  ,fileanysize          = filereadflags.(12:1)# !func 30 or 31
  ,fileeof              = filereadflags.(11:1)#
  ,fileblock'j          = filereadflags.(0:8)#
  ;

! local variables extracted from workspace (regular or jumbo fmt):
double fileblock;  ! fileblock'r & fileblock'j
   logical array fileblock0 (*) = fileblock
                ,fileblock1 (*) = fileblock0(1)
                ;
<<
Word   Contents  Meaning
offset
------------------------------------------------------------
1      status    mpe error number of last operation
                 or 0 if ok. end of file is indicated
                 by a -1

2      filenum   mpe filenumber returned by fopen
                 can be used to call printfileinfo

3      type      0 = /keep file,      1 = a qedit file,
                 2 = other MPE,       3 = new Qedit write,
                 4 = overwrite MPE,   5 = append MPE,
                 6 = overwrite Qedit, 7 = append Qedit

{{ rpg fix:  lang codes 5 and 6 were missing }}
4      lang      0=unknown, 1=spl, 2=fortran, 3=cobol,
                 4=rpg, 5=job, 6=text, 7=pascal, 8=cobolx, 9=data

5      length    the normal record length in bytes

6/7    size      the number of records in the file
   or  currec    line number of last line read/written

8      block     current disc block, qedit only (low 16-bits)

9      index     current index into block, qedit only

10     readlen   length in bytes of last read

11     left      0 = linenum at right end of record
                 1 = linenum at left end of record

12     keylen   length of the linenumber key in bytes

13/14           reserved for internal use

15-270          buffer space for qedit file
>>

<< variables required by qedit read subrs >>
integer x = x;

!byte pointer tos's1'ptr = s-1;
!byte pointer tos's2'ptr = s-2;
!byte pointer tos's3'ptr = s-3;
!byte pointer tos's4'ptr = s-4;
!byte pointer tos's5'ptr = s-5;
!byte pointer tos's6'ptr = s-6;

double  pointer dp;
integer pointer ip;
integer indent'hwds,
        indent'bytes,
        line'ovhd:=3,
        data'hwds,
        usable'data,
        worddatalen,
        total;
logical readmode;

byte array argument'(*) = argument;

<<variables added for FIND function>>
  double  array d'arg   (*) = argument;
  logical rec'found;
  double  closest'linenum;
  integer pointer fileblock'table; <<84 words>>
  double  pointer firstlinenum;    <<6 words>>
  double  pointer linetable; <<83 times 2>>
  integer arg;

  logical user'opened;

<< declarations added for qout functions >>

  << redefine function parm as a descriptor >>
  double array d'function(*)=function;
  << for open-new>>
    define lang = function(1)# <<1=spl, not 0>>
          ,text'length = function(2)# <<if lang=6>>
          ,size'in'blocks = function(3)#
          ,numext = function(4)#
          ,initext = function(5)#
          ,outfilename = argument#
          ;
  << for write line>>
    define
        reclen = function(1)#
       ,lino   = d'function(1)#
       ,record = argument#
       ;
  byte array b'record (*) = record;
  double array qzero'line (*) = physbuf;

  << header >>
  double line'h;
  logical descriptor;
  array header(*)=line'h; <<3 words>>

   define check'err=if <> then begin
                     fcheck(filenumber,filestatus);
                     if filestatus = 0 then filestatus := -1;
                     return;
                  end#;

intrinsic fcheck, fopen, fread, freaddir, fcontrol, fclose, fwrite
         ,fgetinfo, debug, freadlabel, fwritedir, fwritelabel
         ;

integer procedure thiscpu; option external;

$page "findclosestblock"
subroutine findclosestblock(target,index);
  value target, index;
  double target; integer index;
begin
  << finds the block closest to target linenum >>
! print(physbuf,move physbuf:="findclosestblock",0);debug;
    @firstlinenum := @physbuf;
  @fileblock'table := @firstlinenum(3); ! instead of +6
  @linetable := @firstlinenum(44); !instead of +88;

  fileblock := 1d;
  fileindex := block'start;
  freaddir(filenumber,firstlinenum,regular'wl,0d);
  if <> then return;
  closest'linenum := if filejumbo then 0d
                     else firstlinenum;
  index := 0;
  while (index:=index+1) <= 83    do
  begin
     if fileblock'table(index)<>0 and
        linetable(index) <= target and
        linetable(index) > closest'linenum then
     begin
       fileblock := double(fileblock'table(index));
       closest'linenum := linetable(index);
    end'if;
  end'while;

  freaddir(filenumber,physbuf,
           regular'wl,fileblock);

! fileindex := 1; <<start of block >>
end'subr;

$page "utility used by all levels - geterr"
subroutine geterr(errornum);
   value   errornum;
   integer errornum;
begin
  fcheck(filenumber,filestatus);
  if filestatus = 0 then
    filestatus := errornum;
<<fileblock := 0;    version 2.7:
  no longer force eof on read error! >>
end'subr;

$page "utility used by all levels - lengthfromlabel"
integer subroutine lengthfromlabel;
begin
  freadlabel(filenumber,physbuf,128,0);
  if <> or physbuf'<>"QEDIT0" or
     not(1<=integer(physbuf(17))<=256) then
    lengthfromlabel := 256
  else
    lengthfromlabel := physbuf(17); <<u0'data'len>>
end'subr; <<lengthfromlabel>>

$page "qaccess - get'qjumbo'attributes"
subroutine get'qjumbo'attributes(num'flag);
  value num'flag; logical num'flag;
begin

!  print(physbuf,move physbuf:="subr: get'qjumbo",0); debug;

$if x5=on <<spl>>
   if not jbuf'allocated then
   begin
      if not user'opened then
      begin
         fclose(filenumber,0,0); ! code will reopen it
         filenumber := 0;
      end'if;
      go to allocate'jbuf;    ! kludge - cannot allocate buffer in subr
   end'if;
$if

   freaddir(filenumber,jbuf,j'wl,0d);
   if <> then geterr(-5)
   else
   if jbuf<>"QE" or jbuf(1)<>"DI" or jbuf(2)<>"T2" then
      geterr(-6)
   else
   begin       ! this is a jumbo file
      internal'language := u0'lang;
      filetype          := type'qedit;
      filejumbo         := true;
      if not (0<=integer(internal'language)<=max'lang) then
        geterr(-4)
      else
      begin
        filelang   := langtable(internal'language);
        filesize   := u0'num'lines;         ! same as filecurkey field
        filereclen := if filelang=text'lang or filelang=data'lang then
                         u0'data'len
                      else
                      if filelang = cob'lang then
                         72
                      else
                         80;
        fileanysize := anysize'flag;
        if filereclen > 256 and not fileanysize then ! use jumbo open
           geterr(-7);
! print(physbuf,move physbuf:="debug: this is jumbo file",0); debug;
        fileleft   := keylefttable(internal'language);
        filekeylen := keylentable(internal'language);
        if num'flag and filekeylen=0 then ! user needs seq numbers
        begin <<append sequence numbers anyway!serial dump>>
           filekeylen := 8;
           filereclen := filereclen + 8;
        end'if; <<add seq numbers>>
        if filereclen > maxlinelen then
          filereclen := maxlinelen;
      end'else;
   end'else;
end'subr; <<get'qjumbo'attributes>>

$page "qaccess - get'qedit'attributes"
subroutine get'qedit'attributes(num'flag);
  value num'flag; logical num'flag;
begin
  freaddir(filenumber,physbuf,regular'wl,0d);
  if <> then geterr(-5)
  else
  begin
    internal'language := physbuf(6);
    filetype := type'qedit;
    if not (0<=integer(internal'language)<=max'lang) then
      geterr(-4)
    else
    begin
      filelang   := langtable(internal'language);
      filesize   := double(physbuf(3)); <<!!same as filecurkey>>
      filereclen := if filelang=text'lang then
                       lengthfromlabel
                    else
                    if filelang = cob'lang then
                       72
                    else
                       80;
      fileleft   := keylefttable(internal'language);
      filekeylen := keylentable(internal'language);
      if num'flag and filekeylen=0 then
      begin <<append sequence numbers anyway!serial dump>>
        filekeylen := 8;
        filereclen := filereclen + 8;
      end'if; <<add seq numbers>>
      if filereclen > maxlinelen then
        filereclen := maxlinelen;
    end'else;
  end'else;
end'subr; <<get'qedit'attributes>>

$page "qaccess - get'keep'attributes"
<<  This next routine attempts to determine the language type
    for an regular /keep file.  In general, we assume that code=1052
    is a COBOL file, 80-byte files with line numbers are SPL, any
    other 80-byte file records is Job, and everything else is Text.
>>
subroutine get'keep'attributes(filecode,len);
   value   filecode, len;
   integer filecode, len;
begin
$if x5=on  <<spl>>
   if not jbuf'allocated then
      go to allocate'jbuf;
$if

   fileanysize :=anysize'flag;
   if filereclen>256 and not fileanysize then
      filereclen:=256; <<3.4>>
   if filereclen > maxlinelen then
      filereclen := maxlinelen;

   << this bit of code does not work for var-len files, which
      might also have sequence numbers at the end of each line.>>

   if filecode = 1052 then         ! COBOL
      if filereclen >= 80 then
      begin
         filelang := cobx'lang;
         filereclen := 80;
      end'if
      else
      begin
         filereclen := 72;
         filelang := cob'lang
      end'else

   else if filereclen <> 80 then
      if filereclen > 256 then filelang := data'lang
      else filelang := text'lang      ! what about numbered TEXT?

   else if is'message'file then
      filelang := text'lang

   else
   begin
      fread(filenumber,jbuf,-filereclen);
      if <> then
         filelang := job'lang
      else
      begin
         if jbuf'(72) = numeric and jbuf'(73) = numeric and
            jbuf'(74) = numeric and jbuf'(75) = numeric and
            jbuf'(76) = numeric and jbuf'(77) = numeric and
            jbuf'(78) = numeric and jbuf'(79) = numeric then
            filelang := spl'lang
         else
            filelang := job'lang;
         fcontrol(filenumber,5,len);  !only rewind if record read
         if <> then geterr(-1);
      end'else
   end'else;

   fileleft := keylefttable( int'lang( filelang ));
   filekeylen := keylentable( int'lang( filelang ));
<<
   Can't do filecurkey:=0 here, since caller expects filesize to
   still contain a valid value
>>
   if readmode then
      filefirstread := true;

! fileleft := false;
! filekeylen := 0;
! if filelang = cob'lang or filelang = cobx'lang then
! begin
!    fileleft   := true;
!    filekeylen := 6;
! end'if
! else
! if filelang = spl'lang then
!    filekeylen := 8;
end'subr;     <<get'keep'attributes>>

$page "2nd level - get'var'attributes"
subroutine get'var'attributes(filecode,len);
   value   filecode, len;
   integer filecode, len;
begin
$if x5=on  <<spl>>
   if not jbuf'allocated then
      go to allocate'jbuf;
$if

!  print(jbuf,move jbuf:="subr get'var'attr",0); debug;
   fileanysize :=anysize'flag;
   if filereclen>256 and not fileanysize then
      filereclen:=256;      << this could be 512, but qacc'argument
                               is only 256 bytes big >>
   if filecode=1052 and filereclen >  80 then
      filereclen := 80;

   if is'message'file then
      filelang := text'lang
   else
   begin

   len := fread(filenumber,jbuf, -filereclen);
!           -(if filereclen>512 then 512
!             else filereclen));
   if <> then
      filelang := job'lang
   else
   begin
      if filecode = 1052 then         ! COBOL
         filelang := cobx'lang

      else if len<8 or len>80 then
         if len>256 then filelang := data'lang
         else filelang := text'lang

      << should check next n lines for ascending line numbers
      >>
      else if jbuf'(len-8)=numeric and jbuf'(len-7)=numeric and
              jbuf'(len-6)=numeric and jbuf'(len-5)=numeric and
              jbuf'(len-4)=numeric and jbuf'(len-3)=numeric and
              jbuf'(len-2)=numeric and jbuf'(len-1)=numeric then
         filelang := spl'lang

      else
         filelang := text'lang;

      fcontrol(filenumber,5,len);  !only rewind if record read
      if <> then geterr(-1);
   end;

   end; <<if is'message'file>>

   fileleft := keylefttable( int'lang( filelang ));
   filekeylen := keylentable( int'lang( filelang ));
<<
   Can't do filecurkey:=0 here, since caller expects filesize to
   still contain a valid value
>>
   if readmode then
      filefirstread := true;
end'subr;     <<get'var'attributes>>


!subroutine format'key(starting);
! byte array starting;
!begin
! tos := dp; << the linenumber in binary >>
! tos := 10000; << decimal divisor >>
! assemble(ldiv); << 32 bits / 16 bits, leave quot/remainder>>
! x := 3;
! do begin
!   @tos's3'ptr:=@tos's3'ptr-1;
!   tos := 10;
!   assemble(div);
!   tos := tos + "0";
!   tos's4'ptr := tos;
! end
! until dxbz;
! << final remainder is on stack >>
! @tos's3'ptr := @tos's3'ptr - 1;
! tos's3'ptr := tos + "0";
! x := filekeylen - 4; <<cobol=2,others=4>>
! while dxbz do begin
!   @tos's2'ptr := @tos's2'ptr - 1;
!   tos := 10;
!   assemble(div);
!   tos := tos + "0";
!   tos's3'ptr := tos;
! end'while;
! @tos's2'ptr := @tos's2'ptr - 1;
! tos's2'ptr := tos + "0";
!end'subr; <<format'key>>

$page "2nd level - formatkey"
subroutine formatkey (line,where,count);
   value line, count, where;
   integer count;
   double line;
   byte pointer where;
begin
   while (count:=count-1) >= 0 do
   begin
      @where := @where(-1);
      where := "0" + byte(integer(line mod 10d));
      line := line / 10d;
   end'while;
end'subr;  <<formatkey>>

$page "2nd level - ascii'to'dbl"
logical subroutine ascii'to'dbl (line, num, count);
   value line, count;
   integer count;
   double num;
   byte pointer line;
begin
   ascii'to'dbl:=true;
   num := 0d;
   while (count:=count-1) >= 0 do
   begin
      if line=numeric then
      begin
         num := num*10d + double(byte(line) - "0");
         @line := @line(+1);
      end
      else
      begin
         ascii'to'dbl:=false;
         count:=0;
      end;
   end'while;
end'subr;  <<ascii'to'dbl>>


$page "2nd level - blank..."
subroutine blanks ( up'to );
  value up'to; integer up'to;
begin
  if (up'to:=up'to-total) > 0 then
  begin
    argument(total) := "  ";
    if (up'to:=up'to-1) > 0 then
      move argument(total+1) := argument(total),
           (up'to);
  end'if;
end'subr; <<blanks>>

subroutine byte'blanks (up'to);
  value up'to; integer up'to;
begin
  if (up'to:=up'to-total)>0 then
  begin
    argument'(total):=" ";
    if (up'to:=up'to-1)>0 then
       move argument'(total+1):=argument'(total),
          (up'to);
  end'if;
end'subr; <<byte'blanks>>

subroutine b'blank(buf,count);
   value count;
   integer count;
   byte array buf;
begin
   if count > 0 then
   begin
      buf:=" ";
      if (count:=count-1)>0 then
         move buf(1):=buf,(count);
   end'if;
end'subr; <<b'blank>>
<<
  for jumbo files we can only keep 1/2 block in the workspace, so
  we have to re-read the full block when we cross block boundary.
  keeping track of forward pointer is tricky.  when fileindex >= 256,
  we replace fileblock with filenextblock value!
>>

subroutine getotherhalfblock;
begin

!  print(argument,move argument:="subr getotherhalfblock",0); debug;
$if x5=on  <<spl>>
   if not jbuf'allocated then
      go to allocate'jbuf;
$if

   freaddir(filenumber,jbuf,j'wl,fileblock);
   if <> then geterr(-3)
   else
   begin
      @filebuf :=@jbuf;
      move physbuf := jbuf(regular'wl),(regular'wl);
      if not fileserial then
         fileblock := d'filebuf(1); ! the forward pointer
   end'else;
end'subr; <<getotherhalfblock>>
$page "compute'next'block"

double subroutine compute'next'block;
begin
   compute'next'block :=
             if fileserial then fileblock + 1d
             else
             if filejumbo then
                if fileindex >= regular'wl then fileblock !next ptr
                else d'filebuf(1)
             else ! regular file
                double(filebuf); <<forward pointer >>
end'subr; <<compute'next'block>>
$page "getnextrecord"

subroutine getnextrecord (target,num'flag,compare'op);
  value target,num'flag,compare'op;
  logical num'flag;
  integer compare'op; <<0=next, 1:>=target, 2:last 3:<=back>>
  double target; <<only used if function=6>>
begin
  worddatalen:=filereclen/2;
  filecurlen := 0;
  rec'found := false;
  while filestatus=0 and not rec'found do
  begin
!    if fileblock = 0d then ! eof
    if fileeof<>0 then
      filestatus := -1
    else
    begin
      if filejumbo then
      begin
!        print(argument,move argument:="jumbo getnextrec",0);debug;
         if fileindex >= 256 then
            @filebuf := @physbuf(-regular'wl) !second half of block
         else
         if fileindex>=252 then
            getotherhalfblock;
      end'if;
      @dp := @filebuf(fileindex);
      @ip := @dp(1);  ! 4 bytes for line#, then lengths
      if filejumbo then
      begin
         data'hwds := ip(0);
         indent'hwds := ip(1);
         line'ovhd := 4;
         if fileindex + 4  < regular'wl and
            fileindex + 4 + logical(data'hwds) >= regular'wl then
         begin
            getotherhalfblock;
            @dp := @filebuf(fileindex);
            @ip := @dp(1);  ! 4 bytes for line#, then lengths
         end'if;
      end'if
      else
      begin
         data'hwds := ip.(0:8);
         indent'hwds := ip.(8:8);
      end'else;
      if compare'op=0 or compare'op=1 and dp>=target then
      begin <<we want this line>>
        rec'found := true;
         << leave this in for old rpg files>>
        if filekeylen = 5 then
        begin <<rpg, obsolete>>
          if indent'hwds + data'hwds > 38 then
             indent'hwds := 0;
          indent'bytes := indent'hwds * 2 + (total := 5);
          if num'flag then
             formatkey(dp,argument'(filekeylen),filekeylen)
          else
             move argument':="     ";
          byte'blanks(indent'bytes);
$if x5=on
          ! splash insists that * = byte address
          tos := @filebuf(fileindex+logical(line'ovhd)) & lsl(1);   !  s
$if x5=off
          tos := @filebuf(fileindex+logical(line'ovhd));
$if
          move argument'(indent'bytes):=
               * , (data'hwds*2); !byte count
          total := total + indent'bytes;
          byte'blanks(80);
          total := (total+1)/2; <<convert to words>>
        end'if
        else
        begin
          if fileleft and num'flag then
          begin <<cobol type and want seq numbers!>>
             formatkey(dp,argument'(6),6);
             indent'hwds := indent'hwds +
                            (total := 3);
          end'if
          else
             total:= 0;
          if indent'hwds > worddatalen then
             indent'hwds:=worddatalen ;
          usable'data :=
             if indent'hwds+data'hwds>worddatalen then
               worddatalen-indent'hwds
            else
               data'hwds;
          blanks(indent'hwds);
          move argument(indent'hwds) :=
               filebuf(fileindex+logical(line'ovhd)) ,
               (usable'data);
          total := usable'data + indent'hwds;
          blanks(worddatalen);<<rest of line>>
          if not fileleft and filekeylen <> 0 and num'flag then <<3.0>>
             formatkey(dp,argument'(filereclen),8);
        end'else;
        filecurlen := if num'flag then filereclen
                      else total * 2;
      end'if;

      ! increment to next line
      fileindex:= fileindex + logical(data'hwds + line'ovhd);
      filecurkey := dp; <<return line number>>
      @dp := @filebuf(fileindex);

      ! see if we need to read another block
      if fileindex > logical(block'size - line'ovhd) or
         dp > 99999999d or
         dp <= 0d then ! we need another block

   !  if filebuf=0 <<no more blocks>> and
      if compare'op=2 <<last blk >> and
         compute'next'block=0d <<no more blocks>> then
      begin
          filestatus := -2; <<fileblock is one we want>>
          return;
      end'if
      else
      begin
        do
        begin
          fileblock :=  compute'next'block;
          fileindex := block'start;
          @filebuf := @physbuf;
!          if fileblock <> 0d then
          if fileblock=0d then
             fileeof:=1
          else
          begin
            freaddir(filenumber,filebuf,regular'wl,fileblock);
            if > then  <<end-of-file>>
            begin
               if not fileserial then
               begin
                  move filebuf:="Unexpected EOF in QEDIT file.";
                  print(filebuf,-29,0);
               end;
               fileblock := 0d; <<stop loop>>
               fileeof := 1;
            end
            else
            if < then
            begin <<read error!>>
               printfileinfo(filenumber);
               geterr(-1);
               if fileserial then
                  move filebuf:=8(0)     <<make it empty,read again>>
               else
               begin
                  fileblock := 0d; <<stop loop>>
                  fileeof := 1;
               end;
            end'if
            else
            if filejumbo and fileserial then
            begin
               if d'filebuf <> 0d then !not a data block
                  move filebuf:=8(0); !empty block, read again
            end'if;
          end'if;
          @dp := @filebuf(block'start);
          end'do
        until fileblock=0d or
              dp <= 99999999d and
              dp > 0d;
      end'if;
    end'else;
  end'while;
end'subr; <<getnextrecord>>

subroutine linenum'error;
begin
   << don't reset filelang, since it is needed to calculate increment
   >>
   filekeylen := 0;
   if filelang=cob'lang or filelang=cobx'lang then
      filecurkey := filecurkey + 100d
   else
      filecurkey := filecurkey + 1000d;
end'subr; <<linenum'error>>

$page "read'keep'line"
subroutine read'keep'line( len, new'linenum );
   value   len, new'linenum;
   integer len;
   double  new'linenum;
begin
!  print(jbuf,move jbuf:="read'keep'line",0); debug

$if x5=on  <<spl>>
   if not jbuf'allocated then
      go to allocate'jbuf;
$if

   len := fread(filenumber, jbuf, -filereclen);
   if < then
      geterr(-1)
   else if > then
      filestatus := -1
   else
   begin
      indent'hwds := 0;
      if (filefirstread) then
      begin
         filefirstread := false;
         filecurkey    := 0d;
      end;

      if filekeylen>0 then    << has line number >>
      begin
         if len<integer(filekeylen) then
            linenum'error
         else if fileleft then     << line number at left >>
         begin
            if ascii'to'dbl( jbuf',new'linenum,filekeylen ) and
               new'linenum>filecurkey then
            begin
               filecurkey := new'linenum;
               indent'hwds := filekeylen;
            end
            else
               linenum'error;
         end

         else                 << line number at right >>
         begin
            if ascii'to'dbl(jbuf'(len-integer(filekeylen))
                           ,new'linenum
                           ,filekeylen
                           ) and
            new'linenum>filecurkey then
               filecurkey := new'linenum
            else
               linenum'error;
         end;
      end

      else                    << no line number in line >>
      begin
         if filelang=cob'lang or filelang=cobx'lang then
            filecurkey := filecurkey + 100d
         else
            filecurkey := filecurkey + 1000d;
      end;

      if len<integer(filekeylen)then
         usable'data := 0  << assertion failure! >>
      else
         usable'data := len - integer(filekeylen);

      move argument':=jbuf'(indent'hwds),(usable'data);
      b'blank(argument'(usable'data)
             ,integer(filereclen)-usable'data
             );

      while (usable'data>0) and (argument'(usable'data-1)=" ") do
         usable'data := usable'data-1;
      filecurlen := usable'data;
   end'if
end'subr; <<read'keep'line>>


$page "1st level - openold"
logical subroutine openold(write'access);
  value write'access;
  logical write'access;
begin
  user'opened := false;
  workspace := 0;
  move workspace(1):=workspace,(wl'workspace-1);
  fileblock  := 0d;
  filenumber := fopen(argument <<filename>>
  <<foptions>>       ,3 <<perm or temp>>
  <<aoptions:nobuf>> ,if write'access then [1/1,2/0,6/4]
                      else [1/1,2/0,6/0]); <<read>>
  if <> then geterr(-1)
  else openold := true;
end'subr; <<open'old>>

subroutine already'open;
begin
! print(physbuf,move physbuf:="subr already'open",0); debug;
  user'opened := true;
  workspace := 0;
  move workspace(1):=workspace,(wl'workspace-1);
  fileblock  := 0d;
  filenumber := argument;
end'subr; <<already'open>>

subroutine getfirstblock;
begin
!$if x5=on <<spl>>
!  WE DON"T need jbuf because we only want first 256-wds anyway.
!  if filejumbo and not jbuf'allocated then
!     go to allocate'jbuf;
!$if

  fileblock := 1d;
  fileindex := block'start;
  fileeof   := 0;

!  if filejumbo then
!  begin
!     freaddir(filenumber
!             ,jbuf    ! dynamic allocation
!             ,j'wl
!             ,1d);
!     if <> then geterr(-3)
!     else
!    if filejumbo then
!       move physbuf := jbuf,(regular'wl); !truncate
! end'if
! else
  begin
     freaddir(filenumber
             ,physbuf
             ,regular'wl
             ,1d);
     if <> then geterr(-3)
  end'else;
end'subr; <<getfirstblock>>

subroutine write'userlabel0;
begin

  << reset userlabel 0 to default >>
  move physbuf := (
    "QEDIT0",  <<id for userlabel>>
    2 <<version>>, 0 <<spl>>, 1 <<namelen>>, 6(0),72<<right>>,
    [1/1,2/1] <<ascii,old>>, 3(0),72<<len>>,8<<key>>,5(0),
    100("  "), <<last'textname, free space>>
    4(0));    << (124,125,126,127 unused>>

  << adjust language >>
    physbuf(4) := int'lang(lang);
  << adjust rightmargin and datalen >>
    physbuf(12) := if lang=6 then text'length
                   else if lang=3 then 66
                   else 80-keylentable(physbuf(4));
    physbuf(17):=physbuf(12);
  <<adjust keylen, left flag, unn flag>>
    if fileleft then
    begin
      physbuf(18):=6;
      physbuf(16):=1; <<left flag>>
    end
    else
    if 4<=lang<=6 then <<unn>>
      physbuf(16).(0:1) := 1;

  fwritelabel(filenumber,physbuf,128,0);
  if <> then geterr(-5);

end'subr; <<write'userlabel0>>

subroutine erase'existing'qedit;
begin
  if 1<=lang<=max'lang and
     (lang<>6 or (1<=text'length<=256)) then
begin
  filecurkey := 0d; <<erase filesize>>
  fcontrol(filenumber,5,physbuf); <<rewind>>
  if <> then geterr(-5);
  fcontrol(filenumber,6,physbuf); << write eof, erases>>
  if <> then geterr(-5);
  fileblock := 1d;
  fileindex := 1;
  fileleft      :=  if lang=3 or lang=8 then true else false;
  filenewlines  := 0;
  fileprevblock := 0;
  filenewblocks := 0;
  write'userlabel0; <<erase existing label>>
  << reset block zero >>
  physbuf:=0; move physbuf(1):=physbuf,(255);
  physbuf(5) := %100000;
  physbuf(6):=int'lang(lang); <<the internal number>>
  fwritedir(filenumber,physbuf,256,0d);
  if <> then geterr(-5);
  filelang := lang; <<external code>>
  filetype := type'rep'qedit;
  physbuf:=0;move physbuf(1):=physbuf,(255);
end
else filestatus := -1;
end; <<erase'existing'qedit>>

subroutine append'to'qedit'file (eof);
  value eof;
  double eof;
begin
  if filesize=0d then
    erase'existing'qedit
  else
  begin
    filecurkey := 0d;  <<reset filesize>>
    filetype   := type'app'qedit;
    filestatus := 0;
    findclosestblock(100000000d,0);
    getnextrecord(100000000d,false,2); <<find last block>>
    if filestatus<>-2 or filecurkey=0d then
    begin
      filestatus := -1;
      fclose(filenumber,0,0);
    end
    else
    begin << found last block >>
      filestatus    := 0; <<okay>>
      fileprevblock := integer(fileblock);
      filenewlines  := 0;
      filenewblocks := 0;
      << set up append line number >>
      filecurkey := (filecurkey/1000d+1d) * 1000d; <<round up>>
      << find eof >>
      fgetinfo(filenumber,,,,,,,,,,eof);
      if <> then geterr(-5);
      fileblock := eof;
      fileindex :=  1;
      << fix block to point to eof, next available, fileblock>>
      filebuf := integer(fileblock); !  filebuf still contains last bloc
      fwritedir(filenumber,filebuf,256,double(fileprevblock));
      if <> then geterr(-5);
      << zero out the buffer for new lines >>
      filebuf:=0; move filebuf(1):=filebuf,(255);
    end'else;
  end;
end; <<append'to'qedit'file>>

subroutine determine'type(num'flag,access'code);
  value num'flag,access'code;
  logical num'flag;
  integer access'code; <<0=read,1=overwrite,2=append>>
begin
!  print(physbuf,move physbuf:="determine'type subr",0); debug;
   fgetinfo(filenumber,,foptions,,filereclen,,,,
            fcode,,filesize);  <<filesize:=eof>>
   if <> then
      geterr(-1)
   else
   begin
      if fcode = 111 then
      begin << qedit file, regular or jumbo? >>
         filetype := type'qedit;
         if filereclen = j'wl then
         begin
            if access'code <> 0 then geterr(-8)
            else get'qjumbo'attributes(num'flag);
         end'if
         else
            get'qedit'attributes(num'flag);
         if filestatus = 0 then
         begin
            if access'code=0 then <<read>>
            begin
               if filesize = 0d then ! boundary case for empty file
               begin
                  fileblock := 0d;
                  fileeof := 1;
               end
               else
                  getfirstblock;
            end
            else
            if access'code=1 then <<overwrite>>
               erase'existing'qedit
            else
            if access'code=2 then <<append>>
               append'to'qedit'file(0d)
            else filestatus := -1;
         end'if
    end'if
    else << not a qedit file >>
    begin
      if not user'opened then
      begin
        <<keep file, close and reopen buffered>>
        fclose(filenumber,0,0);
        filenumber := fopen(argument,3,  <<old or oldtemp>>
                           if access'code=0 then 0 else
                           if access'code=1 then 1 else
                           3 <<append>>);
        if <> then geterr(-1);
      end'if;
      if filenumber<>0 then
      begin
        fgetinfo(filenumber,,foptions,,filereclen,,,,
               ,,filesize); <<17 jul 86,rmg fix bug>>
        << make filereclen positive number of bytes >>
        if integer(filereclen) > 0 then
        begin
          filetype := type'mpe;
          filereclen := filereclen * 2
        end'if
        else
        begin
          filetype := type'keep;
          filereclen := -integer(filereclen);
        end'else;
        if access'code=1 then filetype := type'rep'mpe else
        if access'code=2 then filetype := type'app'mpe;

        is'variable'len := foptions.(8:2)=1;
        is'message'file := foptions.(2:3)=6;
        if is'message'file then
        begin
!          integer'parm:=0;
           ! Disable extended wait.  We don't want it disabled,
           ! since the default is wait on first i/o, no wait on rest.
           ! This allows the qaccess process to start before the
           ! writer has started.
!          fcontrol( filenumber, 45, integer'parm );
        end;

        if is'variable'len then  << variable length file >>
           get'var'attributes(fcode,0)
        else if filereclen > 256 and not anysize'flag then
          filestatus := -2
        else
          get'keep'attributes(fcode,0);
      end'if;
    end'else;
  end'else;
  if filestatus <> 0 and not user'opened then
  begin
    fclose(filenumber,0,0);
    filenumber:=0;
  end'if;
end'subr; <<determine'type>>

$page "open'new'qedit'file ..."
subroutine open'new'qedit'file (fsz);
  value fsz;
  integer fsz;
begin
   workspace :=0;
   move workspace(1):=workspace,(wl'workspace-1);
   fileblock := 0d;
   fileleft := if lang=3 or lang=8 then true else false;
   fsz:=if size'in'blocks < min'blocks then min'blocks
        else size'in'blocks;
   filenumber:=
      fopen(outfilename
      ,0   <<new, binary>>    << foptions         lv >>
      ,[1/1,2/2,6/4]<<nobuf,excl,inout : aoptions lv >>
      ,256                    << recsize          iv >>
      ,                       << device           ba >>
      ,                       << formmsg          ba >>
      ,2                      << userlabels       iv >>
      ,                       << blockfactor      iv >>
      ,                       << numbuffers       iv >>
      ,double(fsz)            << filesize         dv >>
      ,numext                 << numextents       iv >>
      ,initext                << initialloc       iv >>
      ,111                    << filecode         iv >>
      );
   check'err;
   filecurkey     := 0d;
   filenewlines   := 0;
   fileblock      := 1d;
   fileindex      := 1;
   fileprevblock  := 0;  !write only
   filenewblocks  := 0;
   << rest of filebuf is set to zero above>>
   move filebuf := (0,0,0,0,0,%100000,0,0); << in use flag>>
   filebuf(6) := int'lang(lang); <<the internal number, parameter>>
   filelang := lang;
   fwritedir(filenumber,
             filebuf,
             256,
             0d);
   check'err;
   if lang=6 then <<text>>
     write'userlabel0;
   filebuf:=0;   <<data'hwds block>>
   move filebuf(1):=filebuf,(255);
   filetype := type'new'qedit;
end; <<open'new'qedit'file>>

subroutine reset'fwd'ptr;
begin
  if fileprevblock>0 then
  begin
    freaddir(filenumber,filebuf,256,double(fileprevblock));
    if = then
    begin
      filebuf := 0;
      fwritedir(filenumber,filebuf,256,double(fileprevblock));
    end;
  end'if;
end;  <<reset'fwd'ptr>>

subroutine close'write'file (domain);
  value domain;
  integer domain;
<< could be new qedit file (filetype=3) or old MPE file (4,5)
   or old QEDIT file (6,7). all with write access >>
begin
  if filetype=type'rep'mpe or filetype=type'app'mpe then
  begin
    fclose(filenumber,0,0); <<existing file>>
    return;
  end;
  << now deal with qedit files, post last block >>
  if filetype=type'app'qedit and filenewlines=0 then
  begin
    << nothing appended !! special case >>
    reset'fwd'ptr; << to 0>>
  end
  else
  begin
    filebuf:=0; <<fwd ptr>>
    fwritedir(filenumber,
              filebuf,
              256,
              fileblock);
    check'err;
    filenewblocks := filenewblocks + 1; <<last one>>
  end;

  << read block zero, update >>
  freaddir(filenumber
          ,filebuf
          ,256
          ,0d);
  check'err;

   filebuf(2) := filebuf(2) + filenewblocks;
   filebuf(3) := filebuf(3) + filenewlines;
   << filebuf(4) := 0;   ..first empty block, leave as is for old>>
   filebuf(5) := 0;   <<flags reset>>
   << filebuf(6) contains internal'language code >>
   fwritedir(filenumber,
             filebuf,
             256,
             0d);
   check'err;

   fclose (filenumber,domain,0);
   check'err;
end; <<close'write'file>>

subroutine update'first'line(linenum);
  value linenum;
  double linenum;
begin
  freaddir(filenumber
          ,filebuf
          ,256
          ,0d
          );
  if = then
  begin
    qzero'line:=linenum;
    fwritedir(filenumber
             ,filebuf
             ,256
             ,0d);
    filebuf:=0;
    move filebuf(1):=filebuf,(255);
  end;
end; <<update'first'line>>

subroutine write'qedit'line(length);
  value length;
  integer length;
begin
  << check length >>
  length:=if reclen>256 then 256 else reclen;
  while length>0 and b'record(length-1)=" "
     do length := length - 1;

  << increment count of lines >>
  filenewlines:=filenewlines+1;

  << compute indentation >>
  indent'hwds := 0;
  while indent'hwds < length and
        b'record(indent'hwds)=" " do
    indent'hwds := indent'hwds + 1;
  indent'hwds := indent'hwds & lsr(1); <<divide by 2, words>>
  data'hwds := (length+1) & lsr(1) - indent'hwds;
  if logical(length) then
    b'record(length) := " ";
  descriptor.(8:8) := indent'hwds;
  descriptor.(0:8) := data'hwds;
  line'h:=if filetype<>type'app'qedit and lino>filecurkey then lino
        else << auto increment >>
          filecurkey+(if fileleft then 100d else 1000d);
  if fileleft and line'h > 999999d or
     not fileleft and line'h > 99999999d then
  begin
    filestatus := -1;
    return;
  end;
  if filecurkey = 0d then
    update'first'line(line'h);
  filecurkey := line'h;
  if fileindex + 3 + logical(data'hwds) > 256 then
  begin
    << block is full, get a new one >>
    filebuf := integer(fileblock) + 1;
    fwritedir(filenumber,
              filebuf,
              256,
              fileblock);
    if > then
      reset'fwd'ptr
    else
      check'err;
    if filebuf=0 then ! forward pointer
    begin
      fclose(filenumber,1,0);
      filestatus := -1;
      return;
    end;
    fileprevblock := integer(fileblock); !write only
    filenewblocks := filenewblocks + 1;
    fileblock     := fileblock+1d;
    fileindex     := 1;

    filebuf:=0;
    move filebuf(1) := filebuf,(255);
  end;
  << move to buf >>
  move filebuf(fileindex):=header,(3),2;
  move * := record(indent'hwds),(data'hwds);
  fileindex := fileindex + 3 + logical(data'hwds);
end; <<write'qedit'line>>

$page "qacc'explain"
subroutine qacc'explain( stat );
   value   stat;
   integer stat;
begin
  stat := filestatus;
  b'blank( argument', 72 );
  if stat>0 then
    ferrmsg( stat, argument, filecurlen )
  else if stat=0 then
    filecurlen :=
    move argument':="Qaccess: No error"
  else if stat=-1 then
    filecurlen :=
    move argument':="Qaccess: End of File"
  else if stat=-2 then
    filecurlen :=
    move argument':="Qaccess: File record length >256, Max is 256"
  else if stat=-3 then
    filecurlen :=
    move argument':="Qaccess: Unable to read 1st block, Fcheck=0"
  else if stat=-4 then
    filecurlen :=
    move argument':="Qaccess: Invalid function. Valid range is 1..31"
  else if stat=-5 then
    filecurlen :=
    move argument':="Qaccess: File system error, Fcheck=0"
  else if stat=-6 then
    filecurlen :=
    move argument':="Qaccess: Invalid format for Jumbo Qedit file."
  else if stat=-7 then
    filecurlen :=
    move argument':="Qaccess: use Jumbo Open (func 30) if rec>256"
  else if stat=-8 then
    filecurlen :=
    move argument':="Qaccess: Write/Append to jumbo not impl yet."
  else
    filecurlen :=
    move argument':="Qaccess: Unknown stat";
end; <<qacc'explain>>
$page "qaccess/get-put workspace"
<<
    we need to redefine workspace for jumbo files, so
    have subr to copy fields into local variables and put
    them back
>>

subroutine get'workspace;
begin

   wl'workspace := 270; ! old size
   fileblock1 := fileblock'r;
   fileblock0 := 0;
!   if function <> 12 then ! not write line
   if function <> 10   and  ! Not close-old
      function <> 11   and  ! Not close-new
      function <> 12   then ! Not write-line
      fileblock0 := fileblock'j; !jumbo extension

end'subr; <<get'workspace>>

subroutine put'workspace;
begin

   fileblock'r    := fileblock1;
   if function <> 12 then !not write line
      fileblock'j    := fileblock0;

end'subr; <<put'workspace>>
$page "qeditaccess/mainline"

qaccess: ! entry point for pascal
current'version: ! dummy entry'point to make version accessible

$if x5=on <<spl>>
!go around;

allocate'jbuf:
   ! kludge:  for jumbo files we need 512 word buffer, but might
   !          cause stack overflow in some tools.  not needed for
   !          regular qedit files.  cannot allocate dynamic buffer
   !          in subr or it screws up return address. must GO TO
   !          main line of procedure and restart!
   if not jbuf'allocated then
      allocate j'wl words'to jbuf end'alloc;
   jbuf'allocated := true;
!  print(jbuf,move jbuf:="debug:alloc jbuf",0); debug;
around:
$if

if not (1<=function<=max'func) then
  filestatus := -4
else
begin

if function<>18 then
   filestatus := 0;

get'workspace;

case function - 1 of
begin
  <<1: open>>

  begin
    readmode := true;
    if openold(false) then
      determine'type(false,0);
  end;

  <<2: read>>

  begin
    if filenumber=0 or filetype>=type'writing then
      filestatus := 72
    else
      if filetype = type'qedit then
        getnextrecord (0d,true,0)
      else
      begin
        filecurkey := 0d;
        filecurlen := fread(filenumber, argument, -filereclen);
        if < then
          geterr(-1) <<12may80>>
        else if > then
          filestatus := -1; <<eof>>
      end'else;
  end;

  <<3: close>>

  begin
    if filenumber = 0 or filetype>=type'writing then <<only for read>>
      filestatus := 72
    else
    begin
      fclose(filenumber,0,0);
      if <> then geterr(-1)
      else filenumber := 0;
    end'else;
  end;

  <<4: rewind>>

  begin
    if filenumber = 0 or filetype>=type'writing then
      filestatus := 72
    else
      if filetype = type'keep then
      begin
        fcontrol(filenumber,5,dummy);
        if <> then geterr(-1);
      end'if
      else
      begin  << qedit >>
        filecurlen := 0;
        getfirstblock;
      end'else;
  end;

  <<5: serial'flag>>

  begin
    readmode := true;
    if openold(false) then
    begin
      determine'type(true,0);
      if filestatus=0 then
         fileserial := true;
    end'if;
  end;

  <<6: find>>

  begin
    if filenumber<>0 then
      if filetype=type'keep then geterr(-1)
      else
      begin
!       print(physbuf,move physbuf:="6:find",0);debug;
        findclosestblock(d'arg,0);
        getnextrecord(d'arg,true,1);
      end'else;
  end;

  <<7: already'open>>

  begin
!   print(physbuf,move physbuf:="main func already'open",0); debug;
    readmode := true;
    already'open;
    determine'type(false,0);
  end;

  <<8: read'unn>>

  begin
    if filenumber=0 or filetype>=type'writing then
      filestatus := 72
    else
      if filetype = type'qedit then
        getnextrecord (0d,false,0)
      else
      begin
        filecurkey := 0d;
        filecurlen := fread(filenumber,
          argument,-filereclen);
        if < then
          geterr(-1) <<12may80>>
        else if > then
          filestatus := -1; <<eof>>
      end'else
  end;

  <<9: open'new>>

  begin <<function parm has descriptors>>
    if 1<=lang<=8 then
      open'new'qedit'file(0)
    else
      filestatus:=72;
  end;

  <<10: write'close-save as old file>>

  begin
    if filetype>=type'writing then
    begin
      if thiscpu >= 16 then   <<release disc space on XL>>
        close'write'file(%21)
      else
        close'write'file(1)
    end'if
    else
      filestatus := 72;
  end;

  <<11: save new temp>>

  begin
    if filetype=type'new'qedit then
      close'write'file(2)
    else
      filestatus := 72;
  end;

  <<12: write'line>>

  begin
    if filetype>=type'writing then
    begin
      if filetype=type'rep'mpe or filetype=type'app'mpe then
      begin <<lino is ignored!>>
        fwrite(filenumber,argument, -reclen, 0);
        if <> then filestatus := -1;
      end
      else
      if filetype=type'new'qedit or
         filetype=type'rep'qedit or
         filetype=type'app'qedit then
        write'qedit'line(0)
      else
        filestatus := 72
    end
    else
      filestatus := 72;
  end;

  <<13: overwrite>>

  begin
    readmode := false;
    if openold(true) then
      determine'type(false,1);
  end;

  <<14: overwrite-already-open>>

  begin
    readmode := false;
    already'open;
    determine'type(false,1);
  end;

  <<15: append>>

  begin
    readmode := false;
    if openold(true) then
      determine'type(false,2)
  end;

  <<16: append-already-open>>

  begin
    readmode := false;
    already'open;
    determine'type(false,2);
  end;

  <<17: read-line>>

  begin
    if filenumber=0 or filetype>=type'writing then
      filestatus := 72
    else
      if filetype = type'qedit then
      begin
        getnextrecord (0d,false,0);
        while (filecurlen>0) and (argument'(filecurlen-1)=" ") do
           filecurlen := filecurlen - 1;
      end
      else
      begin
        read'keep'line(0,0d);
      end'else;
  end;

  <<18: explain>>

  begin
    qacc'explain(0);
  end;

  <<19:>> filestatus := -4;
  <<20:>> filestatus := -4;
  <<21:>> filestatus := -4;
  <<22:>> filestatus := -4;
  <<23:>> filestatus := -4;
  <<24:>> filestatus := -4;
  <<25:>> filestatus := -4;
  <<26:>> filestatus := -4;
  <<27:>> filestatus := -4;
  <<28:>> filestatus := -4;
  <<29:>> filestatus := -4;

  <<30: open>>

  begin
    readmode     := true;
    anysize'flag := true;
    if openold(false) then
      determine'type(false,0);
  end;

  <<31: already'open, any record size >>

  begin
!   print(physbuf,move physbuf:="main func already'open",0); debug;
    readmode       := true;
    anysize'flag   := true;
    already'open;
    determine'type (false,0);
  end;


  <<32: jumbo serial'flag>>

  begin
    readmode := true;
    anysize'flag := true;
    if openold(false) then
    begin
      determine'type(true,0);
      if filestatus=0 then
         fileserial := true;
    end'if;
  end;

end'case;

end'if;

put'workspace;

end'proc;    <<qeditaccess>>
$page "qout routines to write qedit workfiles"
<<

          q o u t   r o u t i n e s

purpose: qout contains routines to allow an application
         program to create and fill qedit workfiles of any size
         and type.  these workfiles can then be /open'ed
         and edited in qedit.

contents: qouto    open a new qedit workfile.
          qoutw    write a line to a qedit workfile.
          qoutc    close a qedit workfile.

installation:

history:

        written by staff of campbell and cook
                            10th floor, 459 collins street
                            melbourne, victoria 3000
                            austrialia

history:
        revised and documented further, 13 feb79 by robelle.
        added text files  13 aug79 by robelle.
        added pasc files  28 jan83 by robelle.

use:

        you must provide a workspace array for each file
        to be written concurrently (as in qeditaccess of
        qcopy).  these routines can be called from spl,
        fortran, or cobol.
>>

$page "qoutc"
<< close the new qedit file and save it PERMANENT.
   post the last block
   update record zero
>>
procedure qoutc(workspace);
   array workspace;
   OPTIONTYPE CHECK 2;
<< cobol call:

   call "QOUTC" using workspace. (see qouto)

>>
begin
  integer function := 10;

  qeditaccess(function,workspace,function);

end; << of qoutc >>
$page "qoutw"
procedure qoutw (workspace,record,reclen,lino);
   double lino;
   integer reclen;
   array record ;
   array workspace;
   optiontype check 2;
   << parameters:
       workspace : as for qouto.
       record    : integer or logical array containing the line
                   to be written. does not contain the line number!
       reclen    : byte length of line, exclusive of trailing blanks.
                   lines too long are truncated.
       lino      : line number to be used. if lino <= current line then
                   current line + increment will be used.
                   if lineno > maximum linenumber allowed, qoutw
                   will return with error -1
       >>

<< cobol call:

   call "QOUTW" using workspace  (see qouto)
                      record     ( pic x(80) )
                      reclen     ( pic s9(4) comp)
                      lineo.     ( pic s9(8) comp)
>>
begin
  integer array function(0:10);
  double array d'function (*) = function;

  function := 12; <<write>>
  function(1):= reclen;
  d'function(1) := lino;

  qeditaccess(function,workspace,record);

end;
$page "qouto"
procedure qouto(workspace
               ,outfilename,size'in'blocks,numext,initext,lang);
   array workspace;
   array outfilename;
   integer size'in'blocks,numext,initext,lang;
   optiontype check 2;
   << parameters :
      workspace : logical array of 270 words; word 0 is set to 0 if no
                  error occurs,-1 if eof is met,
                    otherwise = file system error number.
                  word 1 is set to mpe file number.
                  workspace should not be modified by the caller
                  between the call to qouto and the call to qoutc.
      outfilename : integer or logical array containing filename.
                    definition as for fopen.
      size'in'blocks :    integer containing number of blocks required.
                    allow roughly (number of lines)/8+1.
                    it is not possible to use more than (lines-1)/5+2.
      numext   :    number of extents. as for fopen(1-32)
      initext  :      "    "    "     INITIALLY ALLOCATED. AS FOR FOPEN.
                    (0 to numext.)
      lang     :    "LANGUAGE" parameter for file.
                    0 -> spl
                    1 -> ftn
                    2 -> cob
                    3 -> old rpg
                    4 -> cobx
                    5 -> job
                    6 -> new rpg
                    7 -> text (256 byte records)
                    8 -> pascal

>>

<< cobol call:

   call "QOUTO" using workspace (see below)
                      outfilename (pic x(30))
                      size'in'blocks    (s9(4) comp)
                      numext      (s9(4) comp)
                      initext     (s9(4) comp)
                      lang.       (s9(4) comp)

  declaration of workspace:

    01  workspace.
        05  qout-status   pic s9(4) comp.
        05  filler        pic s9(4) comp 0ccurs 269 times.

>>
begin
   integer array function(0:10);

  integer array qout'lang(0:8)=pb := <<qeditaccess codes>>
    1 <<spl=0>>
   ,2 <<ftn=1>>
   ,3 <<cob=2>>
   ,4 <<rpg-old=3>>
   ,8 <<cobolx=4>>
   ,5 <<job=5>>
   ,4 <<rpg-new=6>>
   ,6 <<text=7>>
   ,7 <<pas=8>>
   ;


  if 0<=lang<=8 then
  begin
    function := 9; <<open'new>>
    function(1) := qout'lang(lang); <<convert int=>ext>>
    function(2) := 256; <<text length for text files>>
    function(3) := size'in'blocks;
    function(4) := numext;
    function(5) := initext;
    qeditaccess(function,workspace,outfilename);
  end
  else workspace := 72;

end; << of qouto >>
$control list
end.  <<qaccess/qlib>>