#-h- cfc              493  asc  10-nov-80 13:51:13  [307,033]
 #----------------------------------------------------------
 ## cfc common block for 'fc' tool
 #  put on a file called 'cfc'
 
 common / cfc / load, verbos, list, errcnt, debug

 integer load	# YES/NO for link
 integer verbos	# YES/NO for verbose mutterings on terminal
 integer list	# YES/NO for listings of fortran compilations
 integer errcnt	# running count of errors in compilation -- load
		# not performed unless errcnt == 0
 integer debug	# YES/NO if -d switch seen; passed on to ld
#-h- flist            277  asc  10-nov-80 13:51:14  [307,033]
  #------------------------------------------------------
  # flist - common block
  # should be put on a file named 'flist'
 
  common /flist/  flevel, ffiles(FILENAMESIZE, FLMAX)
    
    integer flevel	#pointer to current file
    character ffiles	#list of files to process
#-h- fcf4p.r         5410  asc  10-nov-80 13:51:15  [307,033]
#-h- fcmain.q         164 asc 08-oct-80 09:36:47
#--------------------------------------------------------------------
##	fcmain -- main driver for the fortran compiler

# call initr4
# call fc
# call endr4
# end
#-h- fcs.q           2084 asc 08-oct-80 09:36:48
#-------------------------------------------------------------------------
##	fcs -- main subroutine for fortran compiler

	define(EXTSIZE,4)
	define(FLMAX,25)

# subroutine fc
 subroutine main

 character source(FILENAMESIZE), object(FILENAMESIZE), arg(FILENAMESIZE),
	   ext(EXTSIZE), listfl(FILENAMESIZE),
	   ldargs(ARGBUFSIZE), descr(PIDSIZE), spath(80)
 integer i, getarg, spawn, k, fortrn, loccom, index

 include flist
 include cfc
 
 string minusv "-v "
 string minusd "-d "
 string exto "obj"
 string extl "l"
 string ld "ld"

 flevel = 0
 load = YES
 verbos = NO		# initialize cfc and flist varibles
 list = NO
 debug = NO
 errcnt = 0

 for (i=1; getarg(i, arg, FILENAMESIZE) != EOF; i=i+1)
    {
    if (arg(1) == MINUS | arg(1) == PLUS | arg(1) == QMARK)
	call fccmd(arg)
    else
	call fstack(arg)
    }

 for (k=1; k<=flevel; k=k+1)
    {
    call getext(ffiles(1,k), ext)
    if (ffiles(1,k) != MINUS & ext(1) == LETF & ext(2) == EOS)
	{
	if (index(ffiles(1,k), SLASH) > 0)
	    call mklocl(ffiles(1,k), source)
	else
	    call scopy(ffiles(1,k), 1, source, 1)
	call genfil(source, exto, object)
	if (list == YES)
	    call genfil(source, extl, listfl)
	else
	    listfl(1) = EOS
	if (fortrn(source, object, listfl, verbos, debug) == ERR)
	    errcnt = errcnt + 1
	}
    }


 if (load == YES & errcnt == 0)
    {
    i = 1
    call stcopy(ld, 1, ldargs, i)
    call chcopy(BLANK, ldargs, i)
    if (verbos == YES)
	call stcopy(minusv, 1, ldargs, i)
    if (debug == YES)
	call stcopy(minusd, 1, ldargs, i)
    for (k=1; k<=flevel; k=k+1)
	{
	call getext(ffiles(1,k), ext)
	if (ffiles(1,k) != MINUS & ext(1) == LETF & ext(2) == EOS)
	    call genfil(ffiles(1,k), exto, arg)
	else
	    call scopy(ffiles(1,k), 1, arg, 1)
	call stcopy(arg, 1, ldargs, i)
	call chcopy(BLANK, ldargs, i)
	}
    ldargs(i-1) = EOS
    call impath(spath)
    if (loccom(ld, spath, arg) != BINARY)
	call error("Cannot locate ld image file.")
    if (verbos == YES)
	call remark(ldargs)
    if (spawn(arg, ldargs, descr, WAIT) == ERR)
	call remark('Error in linking process')
    }
 return
 end
#-h- fccmd.q          740 asc 08-oct-80 09:36:50
#-------------------------------------------------------------------
##	fccmd -- handles switches in fc command line

 subroutine fccmd(arg)

 character arg(FILENAMESIZE)

 include cfc

 if (arg(1) == MINUS & (arg(2) == LETC | arg(2) == BIGC))
    load = NO
 else if (arg(1) == QMARK & arg(2) == EOS)
    call fcerr
 else if (arg(1) == MINUS & (arg(2) == LETV | arg(2) == BIGV))
    verbos = YES
 else if (arg(1) == MINUS & (arg(2) == LETO | arg(2) == BIGO))
    list = YES
 else if (arg(1) == MINUS & (arg(2) == LETD | arg(2) == BIGD))
    debug = YES
 else if (arg(1) == MINUS & (arg(2) == LETP | arg(2) == BIGP |
	  arg(2) == LETL | arg(2) == BIGL))
    call fstack(arg)
 else
    call remark('Ignoring invalid argument.')

 return
 end
#-h- genfil.q         380 asc 08-oct-80 09:36:52
#--------------------------------------------------------------------
##	genfil -- generates file name with extension ext from in

 subroutine genfil(in, ext, out)

 integer i, j
 character in(FILENAMESIZE), ext(EXTSIZE), out(FILENAMESIZE)

 for (i=1; in(i) != PERIOD & in(i) != EOS; i=i+1)
    out(i) = in(i)
 call chcopy(PERIOD, out, i)
 call scopy(ext, 1, out, i)
 return
 end
#-h- fstack.q         395 asc 08-oct-80 09:36:53
   #------------------------------------------------------------
   ## fstack - generate stack of input files
 
   subroutine fstack (iarg)
 
   integer i
   character iarg(FILENAMESIZE)
 
   include flist
 
   if (flevel < FLMAX)
     {
     flevel = flevel + 1
     for (i=1; i<=FILENAMESIZE; i=i+1)
         ffiles(i,flevel) = iarg(i)
    call fold(ffiles(1, flevel))
     }
   return
   end
#-h- getext.q         350 asc 08-oct-80 09:36:53
 subroutine getext(file, ext)

 character file(FILENAMESIZE), ext(EXTSIZE)
 integer i, j

 for (i=1; file(i) != PERIOD & file(i) != EOS; i=i+1) ;
 if (file(i) == PERIOD)
    i = i + 1
 for (j=1; file(i) != EOS & file(i) != SEMICOL & file(i) != PERIOD; j=j+1)
    {
    ext(j) = file(i)
    i = i + 1
    }
 ext(j) = EOS
 call fold(ext)

 return
 end
#-h- fortrn.q         784  asc  10-nov-80 13:50:49  [307,033]
 integer function fortrn(source, object, list, verbos, debug)

 character source(ARB), object(ARB), list(ARB), arg(80), pid(PIDSIZE)
 integer spawn, i, verbos, debug

 string srcsw "/notr/nock/co:19."	# F4P
# string srcsw "/nosn/nova/nolo"	# FOR

 i = 1
 call stcopy("f4p ", 1, arg, i)
 call remove(object)		# delete most recent version of object file
 call stcopy(object, 1, arg, i)
 if (list(1) != EOS)
    {
    call chcopy(COMMA, arg, i)
    call remove(list)		# delete most recent version of list file
    call stcopy(list, 1, arg, i)
    call stcopy("/-sp", 1, arg, i)
    }
 call chcopy(EQUALS, arg, i)
 call stcopy(source, 1, arg, i)
 call scopy(srcsw, 1, arg, i)
 call fold(arg)
 if (verbos == YES)
    call remark(arg)
 fortrn = spawn("local", arg, pid, WAIT)

 return
 end
#-h- fcerr.q          108 asc 08-oct-80 09:36:55
 subroutine fcerr

 call error("usage:  fc [-c] [-v] [-o] [-d] [-l[libr]] [-pproc] file ...")

 return
 end