#PROGRAM       /GPFDALLOC(15AM,22AM,DBM,EBM)
#PAGE

#INCLUDE       IOHEAD(/DEFS)
#INCLUDE       STACK(/DEFS)

#PERMANENT     GFMALLOC    [ #XPCK to stupid to include by entrypoint

#PROGRAM

#              Allocate file table entry

#              unit = fdalloc (fd, shift, type, unit, read, write, len)

#              fd:    fd to allocate, or -1
#              shift: zero if GRAP, -ve AMOR
#              type:  Device type, *TR, *TP, *FR, *FW, *FH, *CI
#              unit:  EXEC unit number
#              read:  read PERI mode
#              write: read PERI mode
#              len:    buffer len in chars

#              Return value in X6
#              FDESC returned in X3 if X6 +ve

#              Stack frame

#SET           STFRAME=SXFRAME

#              First the args

#DEFINE        STFD=SXPAR1           [ preferred FD, or -1
#SET           STFRAME=STFRAME+1

#DEFINE        STSHIFT=SXPAR2        [ Current shift
#SET           STFRAME=STFRAME+1

#DEFINE        STTYPE=SXPAR3         [ Device type, eg *TP = 1
#SET           STFRAME=STFRAME+1

#DEFINE        STUNIT=SXPAR4         [ Unit number, eg 2 for *TP2
#SET           STFRAME=STFRAME+1

#DEFINE        STREAD=SXPAR5         [ read Peri mode
#SET           STFRAME=STFRAME+1

#DEFINE        STWRITE=SXPAR6        [ write Peri mode
#SET           STFRAME=STFRAME+1

#DEFINE        STCHARS=SXPAR7        [ buffer length wanted
#SET           STFRAME=STFRAME+1

#              Now the local variables:

#DEFINE        STDESC=STFRAME        [ saved file descriptor pointer
#SET           STFRAME=STFRAME+1

      BEGIN 2  3,1,STFRAME

#              Work out if we  have enough space in the FTABLE.

      LDX   1  PFTABLE
      BNZ   1  PFOK

#              Drat, the table hasn't even been allocated yet.

      LDN   3  SZFTABLE+1            [ get initial size of table
      CALL  1  GXZALLOC              [ zeroing allocator

      BZE   6  NOMEM

      STO   6  PFTABLE
      STO   6  1

      LDN   0  SZFTABLE
      STO   0  0(1)                  [ Save allocated size of table

PFOK  LDX   0  0(1)                  [ Get size of table

      LDXC  3  STFD(2)               [ do we have a preferred FD?
      BCS      FIND                  [ jump if not

      BXGE  3  0,BADF                [ jif outside table

      ADX   1  3
      LDX   3  1(1)                  [ get FD'th entry
      BZE   3  FOUND                 [ jif avail

      BRN      BADF                  [ sorry, in use

FIND  ADN   1  4                     [ skip 1st 4 entries
      SBNC  0  4
      BCS      BADF                  [ shouldn't happen
      
NXT   LDX   3  1(1)                  [ get next table entry
      BZE   3  FOUND                 [ jump if free
      ADN   1  1                     [ point at next table entry
      BCT   0  NXT

#              Can't find a table entry.  Could increase table size
#              or just give up

BADF  NGN   6  EBADF
      BRN      BYE

NOMEM NGN   6  ENOMEM
      BRN      BYE

FOUND STO   1  STDESC(2)             [ save FD pointer

      LDN   3  SZFDESC               [ size of file descriptor

      LDX   4  STCHARS(2)            [ get wanted buffer length
      ADN   4  3
      SRL   4  2                     [ calculate length in words
      ADX   3  4                     [ work out size of descriptor

      CALL  1  GXMALLOC              [ Allocate descriptor
      BZE   6  NOMEM                 [ should be BNG one day

      LDX   1  STDESC(2)
      STO   6  1(1)                  [ save descriptor

      STO   6  3                     [ move descriptor to index reg

      SBX   1  PFTABLE               [ convert table pointer to unit#
      STO   1  6                     [ and move to return

#              Initialise descriptor

      STOZ     FDFLAGS(3)            [ no flags set

#              Calculate PERI commands

      LDX   1  STTYPE(2)
      STO   1  FDTYPE(3)
      LDCT  0  256(1)                [ move type+256 to top 9 bits
      LDN   4  DEVCI                 [ is it a *CI?
      BXE   4  1,*+2                 [ if not we ...
      ADX   0  '#30000'              [   turn on EOF detection

      LDXC  4  STWRITE(2)            [ can we write this FD?
      BCS      RO                    [ jump if read only
      ADX   4  0                     [ compose write PERI
      STO   4  FDWRITE(3)            [ and save
      STO   4  FDPERI(3)             [ save as initial PERI
      LDN   4  FLAGWRITE             [ set write flag
      ORS   4  FDFLAGS(3)
      BRN      *+2 

RO    STOZ     FDWRITE(3)            [ No write access

READ  LDXC  4  STREAD(2)             [ can we read this FD?
      BCS      WO                    [ jump if write only
      ADX   4  0                     [ compose read peri
      STO   4  FDREAD(3)             [ and save
      STO   4  FDPERI(3)             [ save as initial peri
      LDN   4  #7777-FLAGWRITE       [ clear write flag
      ANDS  4  FDFLAGS(3)
      BRN      *+2                   [ and contiue 

WO    STOZ     FDREAD(3)             [ no read access

INIT  LDX   0  STUNIT(2) 
      STO   0  FDUNIT(3)
      LDX   0  STCHARS(2)
      STO   0  FDBUFLEN(3)
      LDX   0  STSHIFT(2)
      STO   0  FDSHIFT(3)
      LDN   7  SMODALPHA             [ shift mod
      SBN   0  #74                   [ start ALPHA?
      BZE   0  SM
      LDN   7  SMODBETA         
      SBN   0  #75-#74               [ or BETA?
      BZE   0  SM
      LDN   7  SMODNONE
SM    STO   7  FDSHIFTMOD(3)`
      STOZ     FDREDTAPE(3)          [ red tape only for *FW
      STOZ     FDCHARS(3)            [ buffer initialy empty
      LDN   1  FDBUF(3)
      STO   1  FDNEXT(3)             [ next char start of buf
      STO   1  FDADDR(3)             [ I/O to buffer
      NGN   1  1                     [ set block mode pointer
      STO   1  FDRECORD(3)           [ to illegal value

BYE   END   2  1,0         

#END
#FINISH