%option "-low"
%include "nmouse.inc"
%include "io.inc"
%systempredicatespec load object(%record(*)%name a,b)

%systemrecord(scb fm)%map NEW SCB (%string(*)%name filename)
%record(scb fm)%name scb
%integername p
%integer n
  scb == record(heapget(sizeof(scb)-255+length(filename)))
  p == integer(addr(scb)); n = sizeof(scb)-256
  %cycle
    p = 0; p == p[1]; n = n-4
  %repeatuntil n=0
  scb_filename = filename
  %result == scb
%end

%systemroutine SCB operation (%registerrecord(scb fm)%name scb,
   %integer code,p1,p2,%name b)
  *move.l a4,-(sp)
  *move.l scb_soppc,a2
  *move.l scb_gla,a4
  *jsr (a2)
  *move.l (sp)+,a4
%end

!%constinteger -
!  sop close   = 0,
!  sop abort   = 1,
!  sop flush   = 2,
!  sop refresh = 3,
!  sop write   = 4,
!  sop read    = 5

%systemroutine FILE CLOSE (%record(scb fm)%name x)
! Close file normally (input or output)
  scb operation(x,sopclose,0,0,nil)
%end

%systemroutine FILE ABORT (%record(scb fm)%name x)
! Close file abnormally (input or output, but for input it
! does the same as FILE CLOSE).
  scb operation(x,sopabort,0,0,nil)
%end

%systemroutine FILE FLUSH (%record(scb fm)%name x, %integer ch)
! Write contents of file buffer (X_P-X_BS bytes at X_BS) to file
! at position X_BS-X_FS in file.
! Maintain high water mark (set X_FL to X_P if X_P>X_FL).
! If X_P=X_L, advance the buffer through the file (normally by
! leaving X_BS and X_BL alone and subtracting X_BL-X_BS from
! X_FS and X_FL.  Return with X_L=X_BL.
! Normally return with X_P=X_BS, but if CH>=0, in the case of
! non-buffered devices (in which case X_BS=X_BL), write the one
! byte CH to the device, in the case of buffered devices, add CH
! to the buffer (and return with X_P=X_BS+1).
  scb operation(x,sopflush,ch,0,nil)
%end

%systemroutine FILE REFRESH (%record(scb fm)%name x)
! Fill the file buffer by reading X_BL-X_BS bytes (less if near
! end of file) from such a position in the file that byte X_P-X_FS
! of the file will be in the buffer.  This will usually involve
! updating X_FS and X_FL and X_P (but always return such that
! X_P-X_FS before is the same as X_P-X_FS after, i.e. X_P-X_FS
! denotes the current position in the file, we do not automatically
! return with X_P=X_BS, although this will normally be the case).
! Normally return with X_L=X_BL (unless near the end of file).
  scb operation(x,soprefresh,0,0,nil)
%end

%systemroutine FILE WRITE -
  (%record(scb fm)%name x,%integer position,amount,%name b)
! Ignoring the buffer pointers in the SCB, write AMOUNT bytes to
! the file at POSITION in the file, from user buffer B.
! Use current position indicated in SCB if POSITION<0.
  position = x_p-x_fs %if position<0
  scb operation(x,sopwrite,position,amount,b)
%end

%systemroutine FILE READ -
  (%record(scb fm)%name x,%integer position,amount,%name b)
! Ignoring the buffer pointers in the SCB, read AMOUNT bytes from
! place POSITION in the file, to user buffer B.
! Use current position indicated in SCB if POSITION<0.
  position = x_p-x_fs %if position<0
  scb operation(x,sopread,position,amount,b)
%end

%systemintegerfn FILE LENGTH (%record(scb fm)%name x)
! Valid both for input and output files.
  %result = x_fl-x_fs
%end

%predicate dynamically loaded (%string(255)s,%integername pc,gla)
%constinteger extbit=16_4000,external=16_2000,jmp=16_4ef9
%record(fe02 indir fm)indir
%record(fe02 object fm)object
  indir = 0
  object = 0
  object_flags = extbit+external
  object_name = s
  %falseunless load object(object,indir)
  %if indir_op1=jmp %start
    gla = 0; pc = indir_opd1
    %true
  %finish
  %if indir_op2=jmp %start
    gla = indir_opd1; pc = indir_opd2
    %true
  %finish
  %false
%end

%routine standardise filename(%string(*)%name s)
%integer pc,gla
  %if dynamically loaded("standardisefilename",pc,gla) %start
    *move.l s,a0
    *move.l pc,a1
    *move.l gla,a2
    *move.l a4,-(sp)
    *move.l a2,a4
    *jsr (a1)
    *move.l (sp)+,a4
  %finishelsesignal 3,3,,s
%end

%record(scbfm)%map FILE operation (%integer code,%string(*)%name file,%name x)
! Perform direct file system operation not involving SCBs.
%string(255)dev,full
%bytename d
%integer pc,gla,len

  %record(scbfm)%map call it(%integer a,%name b,c)
    *move.l a4,-(sp)
    *move.l gla,a4
    *move.l pc,a2
    *jsr (a2)
    *move.l (sp)+,a4
  %end

  full = file
  standardise filename(full)       {-> :x:y:z}
  dev = full
  d == length(dev)
  dev = "fop_".substring(dev,2,d)  {-> fop_x:y:z}
  len = 4
  %cycle
    d = len %if d[len+1]=':'
    len = len+1
  %repeatuntil len>=d              {-> fop_x}
  %result == call it(code,full,x) %if dynamically loaded(dev,pc,gla)
  dev = "Cannot access file ".file
  %signal 3,3,,dev
%end

%routine fop (%integer code,%string(*)%name file,%name x)
%record(scbfm)%name unused
  unused == file operation(code,file,x)
%end

!%constinteger -
!  fop logout  = 0,
!  fop login   = 1,
!  fop quote   = 2,
!  fop pass    = 3,
!  fop openi   = 4,
!  fop openo   = 5,
!  fop openm   = 6,
!  fop opena   = 7 {not used},
!  fop credir  = 8,
!  fop delete  = 9,
!  fop info    = 10,
!  fop rename  = 11,
!  fop copy    = 12,
!  fop permit  = 13,
!  fop stamp   = 14,
!  fop time    = 15,
!  fop special = 16,
!  fop oldfinfo= 17

%externalroutine FILE LOGOUT (%string(255)fs)
  fop(foplogout,fs,nil)
%end

%externalroutine FILE LOGIN (%string(255)fsu,p)
  fop(foplogin,fsu,p)
%end

%externalroutine FILE QUOTE PASSWORD (%string(255)fs,p)
  fop(fopquote,fs,p)
%end

%externalroutine FILE CHANGE PASSWORD (%string(255)fs,p)
  fop(foppass,fs,p)
%end
  
%externalrecord(scb fm)%map FILE OPEN INPUT (%string(255)f)
%record(scbfm)%name x
%integer i
  standardise filename(f)
  %result == file operation(fopopeni,f,nil)
%end

%externalrecord(scb fm)%map FILE OPEN OUTPUT (%string(255)f)
  %result == file operation(fopopeno,f,nil)
%end

%externalrecord(scb fm)%map FILE OPEN MODIFY (%string(255)f)
  %result == file operation(fopopenm,f,nil)
%end

%externalrecord(scb fm)%map FILE OPEN APPEND (%string(255)f)
%record(scbfm)%name x
%integer size,offset,pos
  x == file open modify(f)
  size = x_fl-x_fs              {size of file
  offset = rem(size,x_bl-x_bs)  {amount used in last block
  pos = size-offset             {start of last block
  x_fs = x_fs-pos; x_fl = x_fl-pos  {seek to last block
  x_p = x_fl; x_l = x_bl            {to past last byte
  file refresh(x) %unless x_p=x_bs  {read partial block
  x_p = x_fl; x_l = x_bl
  %result == x
%end

%externalroutine FILE CREATE DIRECTORY (%string(255)f)
  fop(fopcredir,f,nil)
%end

%externalroutine FILE DELETE (%string(255)f)
  fop(fopdelete,f,nil)
%end

%externalroutine FILE INFO (%string(255)f,%string(*)%name info)
  fop(fopinfo,f,info)
%end

%externalroutine FILE RENAME (%string(255)old,new)
  standardise filename(new)
  fop(foprename,old,new)
%end

%externalroutine FILE COPY (%string(255)old,new)
  standardise filename(new)
  fop(fopcopy,old,new)
%end

%externalroutine FILE PERMIT (%string(255)f,p)
  fop(foppermit,f,p)
%end

%externalroutine FILE CHANGE DATE (%string(255)f,d)
  fop(fopstamp,f,d)
%end

%externalroutine FILE GET DATE (%string(255)fs,%string(*)%name d)
! This one asks the file system what time it thinks it is.
  fop(foptime,fs,d)
%end

%recordformat fs fm(%integer send,recmax,rec,%bytename sendbuf,recbuf)

%externalroutine FILE SPECIAL (%string(255)fs,%record(fs fm)%name r)
! This one is intended to cover special cases, such as admin functions.
! It involves sending SEND bytes from SENDBUF and receiving back up to
! RECMAX bytes into RECBUF, noting in REC the actual number of bytes returned.
  fop(fopspecial,fs,r)
%end

%externalroutine FILE OLDFINFO (%string(255)f,%string(*)%name info)
  fop(fopoldfinfo,f,info)
%end

%externalstring(255)%fn DATETIME
%string(255)fs,dt
  fs = "."; dt = ""
  file get date(fs,dt)
  %result = dt
%end

%externalstring(255)%fn DATE
%string(255)dt = datetime
%bytename b == length(dt)
  b = b-1 %while b>0 %and b[b]#' '
  b = b-1 %while b>0 %and b[b]=' '
  %result = dt
%end

%externalstring(255)%fn TIME
%string(255)dt = datetime
%bytename b == length(dt)
%integer p = b
  p = p-1 %while p>0 %and b[p]#' '
  dt = substring(dt,p+1,b)
  %result = dt
%end

%routine stream check(%integer s)
  %signal 6,1,s,"Stream number out of range" %unless s&7=s
%end

%externalroutine OPENINPUT (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectinput(s)  {back-compat}
  scb == file open input(f)
  scb_next == poa_in(s)
  poa_in(s) == scb
  poa_curin == scb %if poa_instream=s
%end

%externalroutine OPENOUTPUT (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open output(f)
  scb_next == poa_out(s)
  poa_out(s) == scb
  poa_curout == scb %if poa_outstream=s
%end

%externalroutine OPENMODIFY (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open modify(f)
  scb_next == poa_out(s)
  poa_out(s) == scb
  poa_curout == scb %if poa_outstream=s
%end

%externalroutine OPENAPPEND (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open append(f)
  scb_next == poa_out(s)
  poa_out(s) == scb
  poa_curout == scb %if poa_outstream=s
%end

%systemintegerfn INPUT FILE POSITION
  %result = 0 %if poa_curin==nil
  %result = poa_curin_p-poa_curin_fs
%end

%systemintegerfn OUTPUT FILE POSITION
  %result = 0 %if poa_curout==nil
  %result = poa_curout_p-poa_curout_fs
%end

%systemintegerfn INPUT FILE LENGTH
  %result = 0 %if poa_curin==nil
  %result = poa_curin_fl-poa_curin_fs
%end

%systemintegerfn OUTPUT FILE LENGTH
  %result = 0 %if poa_curout==nil
  %result = poa_curout_fl-poa_curout_fs
%end

%systemroutine SET INPUT (%integer byte)
  %returnif poa_curin==nil
  poa_curin_p = poa_curin_fs+byte
  poa_curin_l = poa_curin_p %unless poa_curin_bs<=poa_curin_p<=poa_curin_l
%end

%systemroutine SET OUTPUT (%integer byte)
  %returnif poa_curout==nil
  %unless poa_curout_bs <= poa_curout_fs+byte <= poa_curout_bl %start
    file flush(poa_curout,-1)
    poa_curout_p = poa_curout_fs+byte
    poa_curout_l = poa_curout_p
    file refresh(poa_curout)
  %finish
  poa_curout_p = poa_curout_fs+byte
  poa_curout_l = poa_curout_bl
%end

%systemroutine RESET INPUT
  setinput(0)
%end

%systemroutine RESET OUTPUT
  setoutput(0)
%end

%systemintegerfn instream
  %result = poa_instream
%end

%systemintegerfn outstream
  %result = poa_outstream
%end

%systemroutine CLOSE INPUT
%record(scbfm)%name cb
  cb == poa_curin
  %returnif cb==nil
  poa_curin == cb_next; %returnif cb==poa_curin
  poa_in(instream) == poa_curin
  scb operation(cb,sopclose,0,0,nil)
%end

%systemroutine ABORT OUTPUT
%record(scbfm)%name cb
  cb == poa_curout
  %returnif cb==nil
  poa_curout == cb_next; %returnif cb==poa_curout
  poa_out(outstream) == poa_curout
  file flush(cb,-1)
  scb operation(cb,sopabort,0,0,nil)
%end

%systemroutine CLOSE OUTPUT
%record(scbfm)%name cb
  cb == poa_curout
  %returnif cb==nil
  poa_curout == cb_next; %returnif cb==poa_curout
  poa_out(outstream) == poa_curout
  file flush(cb,-1)
  scb operation(cb,sopclose,0,0,nil)
%end

%externalroutine PROMPT (%string(255)s)
  %returnif poa_curin==nil
  %returnif poa_curin_prompt==nil
  poa_curin_prompt = s
%end

%systemstring(255)%fn INFILENAME
  %result = ":N" %if poa_curin==nil
  %result = poa_curin_filename
%end

%systemstring(255)%fn OUTFILENAME
  %result = ":N" %if poa_curout==nil
  %result = poa_curout_filename
%end

%externalintegerfn filesize(%string(255)f)
%record(scb fm)%name cb == file open input(f)
%integer n = cb_fl-cb_fs
  file close(cb)
  %result = n
%end

%externalpredicate exists(%string(255)f)
  %on 3 %start
    %false
  %finish
  file close(file open input(f))
  %true
%end