ownstring(255) rcsid="$What: <@(#) ftncomp.i,v 63.0> $"
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
ownstring(90) copyright = " Copyright (c) 1987, 1989 Edinburgh Portable Compilers Ltd. All Rights Reserved."
externalroutine Set SIgs
end
!* $Log: ftncomp.i,v $
!* ftncomp65.3
!* 26/07/93 - Switch off code scheduling when -g
!* ftncomp65.2
!* 19/07/93 - Removed EInitialise call from this module - it's back in
!* ftndata again. (rt)
!* ftncomp65.1
!* 15/07/93 - Added -gisbuff=
!* ftncomp65rt
!* 13/07/93 - Added gY option and made gg enable rather than
!* disable global scheduling. (rt)
!* ftncomp65g
!* 06/07/93 - add support for O4, O5 and rt private options
!* - add calls to Esetoptions,EsetGISoptions
!* and Einitialise (Note: deleted call in ftndata)
!* ftncomp64g
!* 01/06/93 - consolidated version for 88110 and Mips
!* 31/05/93 - recognise private options Zn and Xn for Fortran opt control
!* ftncomp63.1
!* 15/04/93 - -SC option for ADI Shared Commons
!* includes coff.inc if object format is ISCOFF
!* 12Apr93 - added cgpeepmon and directed Malloc via getspace(pds)
!*
!* Revision 63.0 1992/12/23 15:25:00 simon
!* ftncomp63
!* 23/11/92 - case sensitivity option {-CS}
!* intrinsics left as lower case namelist IO - libI
!* passed -CS option
!*
!* ftncomp62.2
!* 23/11/92 - Case sensitivity option {-CS}
!* recognises -CS in command line
!* sets bits in com_options2 and cgoptions
!* ftncomp62.1
!* 04/07/92 - Make no scheduling the default, only schedule
!* when optimiser switched on or -P cgshced
!* - for RS6000 -O3 no longer sets hsflt and as
!* reciprocation is done by the rs6000 code generator
!* the -O3 option is obsolete.
!*
!* Revision 62.0 1992/07/10 11:49:31 simon
!* ftncomp62
!* 10/07/92 - Common source:
!* Merge Intel change:
!* Only hardwire -us by clearing nus bit in
!* options2 if OMRON,not just when non OCScompliant
!* - 88K ELF change:
!* Increment vptr after processing pic options!
!* - RS6000 change:
!* 17/06/92 Add cgparamsind to cgoptions for scheduler
!*
!*
!* Revision 61.0 92/01/07 11:44:06 simon
! ftncomp61.2
!* 08/04/92 - Add -q[no]chkof to always do overflow checks
!* of floating point calculations
!* 18/03/92 - Set options2 to nus for RS6000 to be compatible
!* with ibm's xlf compiler
!* also scheduling always on unless -x set
!* 04/03/92 - Add -q[no]rndsngl,-q[no]hssngl for RS6000
!* ftncomp61.1
!* 24/01/91 - Change for IMP, whereby -O (optimise) implies
!* NOTRACE - this improves code scheduling.
!*
!* - Also includes Pete's changes for his Imp compiler:
!* !06/12/91 - for IMP
!* Decouple MAXDICT and MAXWORK. Maxdict only
!* affects names,
!* Allow -N2048 etc to specify exact workfilesize,
!* Reset BIGWORK to 512K (old Maxwork) and maxwork
!* to 1023K,
!* Allow -m to mean MAXWORK+MAXDICT,
!* -m sets the workfile size to 1023K rather
!* than 513K.
!* ftncomp61
!* Merge in changes from sparc and omron:
!*
!* SPARC: ftncomp60.2
!* 11/12/91 - for Emachine 4, tell the code generator if -pl
!* (for line profiling) has been specified.
!*
!* for SPARC, switches off code scheduling (requested
!* via -P cgsched) if compiling with diagnostics or
!* sdb/dbx.
!* ftncomp60.1
!* 28/11/91 - Added the options -pic+ and -PIC+ to select
!* small-model and large-model position independent
!* code - currently no action is taken for Emachine 3
!*
!* 14/11/91 - Added the private option CGSCHED to select
!* code scheduling (on SPARC scheduling is
!* normally only performed when optimising).
!*
!* - Added the private option CGSCHEDMON to switch on
!* Emachine4 code scheduler tracing, in bprocs2
!* onwards. This option also selects code scheduling.
!*
!* OMRON: ftncomp60.1
!* 22/11/91 - set -us flag unconditionally for OMRON
!*
!* Revision 60.0 91/10/21 11:25:52 simon
!* ftncomp60
!* 19/10/91 - common source
!* - define and set superscalar
!* - define and set G2traceMOO
!*
!*
! ftncomp59.2
! 03/10/91 - Allow -132 if Env=Gould which gives users
! two ways of having long lines (-132 and -ff)
! ftncomp59.1
! 11/09/91 - Merge in Gould Changes:
! - call putincname from select include
! - add 77+ option
! - add closein
! ftncomp59
! 28/07/91 - common source (==ftncomp58.1)
! ftncomp58.2a
! 7/08/91 - for m88k, rationalise use of Target = M88000 and
! Host = M88000 for the Sun3/Sun4 M88110 compiler.
!
! 6/08/91 - for IMP, put references to lineprofiler, profiler,
! timeprofiler, autoflag, and recipopt behind
! Compiler=Fortran conditional compilation.
! ftncomp58.1
! 30/04/91 - for 88k call disabletraps to disable 88k fpu traps
! ftncomp58
! 28/03/91 - added the private option NOUNROLL which inhibits
! loop unrolling (will only work in ftnloop27 onwards)
!
! 25/03/91 - uses getstat.c and the host independent form of
! the file information table - compatible with
! fstatfmt10.inc onwards
!
! - add function Nusoption which returns 1 if -nus
! has been used (88k only)
!
! - add call to Esourcefile to pass the source file to
! dgen (Host=DRS only)
!
! - implement -Y option to declare unshared common
! blocks (Allowparallel only)
!
! - add procedure Abort (to provide a uniformity
! when reporting an error)
! ftncomp57
! 22/01/91 - expanded the searchpaths for an INCLUDE file to
! include (a) the current working directory after
! searching -I directories
! (b) /usr/include after the current
! working directory
! (required by Release 2.6.2)
!
! 16/01/91 - add recipopt, misalignedreals, and Opt2max to
! the -P OPTIONS output
!
! 08/01/91 - make instruction scheduling the default for 88k
! - moved Copyright text in Printvers into vers.X.inc
! ftncomp56
! 08/01/91 - set recipopt if -O3
! ftncomp55.1
! 5/12/90 - allow the -o option to nominate an alternative
! name for the object file - compatible with a
! driver which only passes the -o option through
! for a command line which specifies -c
!
! 16/09/90 - checks for (and skips) 'X' after any -G option
! ftncomp54
! 12/09/90 - allow for a .for file extension
!
! 11/09/90 - for Emachine>=4, set cgoptions as appropriate if
! profiling (-p or -pg) has been specified
!
! - expects the driver to pass -pg as -p and hence
! interprets -pg as -p -g (ie. profile and sdb/dbx)
! ftncomp53
! 05/09/90 - Add -P ctriads option to get triads with ecodes
!
! 31/08/90 - uses the new include file vers.inc which defines ftncomp52
! the compiler's Release and Reldate
!
! 16/08/90 - support -us (underscore) for m88k - compatible ftncomp51
! with a driver which passes -us as -us+ and -u
! as -u
!
! - the warning message associated with inconsistent
! use of options is now constructed dynamically to
! avoid drawing a user's attention to options which
! he did not specify and which although recognised
! may not be documented for his system. (Note -p
! nor -pg invoke this warning, only -pl and -pt)
!
! - moved additional DRS/SEQUENT specifics behind
! conditional compilation
!
! - the externalstring SRCEFILENAME has been
! increased in size from 64 to 255 (this string
! is read by ftnmess)
!
! - on Emachine4 Targets, compatible with ftnprofdum1.i
!
! 15/08/90 - merge with ftncomp49.2.i ftncomp50.1
! 15/06/90 - merge in Sequent/386 mfcompile47t.i ftncomp50
!
! 6/06/90 - renamed for systems which only recognise up ftncomp49.1
! to 16 character filenames
!
! - support -V for parameter checking (but not if
! targetting on Gould)
!
! - removed support for -args
!
! - -U no longer selects parameter checking (except
! for Gould)
!
! - no longer EXIT(1) after performing a syntax
! check - otherwise the driver will report
! 'compiler error'
!
! - relocated the check for inconsistent options
! specified with -O (the original location was
! after the call to Msetoptions and was therefore
! done too late)
!
! - for m88k Fortran: initialise Options2 to nus
! mfcompile49
!19/05/90 - support -args
!
!30/04/90 - incorporates access control from Rob mfcompile48.15
!
! - also no longer breaks if the compiler is
! passed no source file
!
!17/04/90 - for Emachine>=4, added -x to unconditionally mfcompile48.14
! switch off instruction scheduling
!
! - for Fortran, added private option MISALIGN
! which is used by the Fortran compiler on
! Risc machines to assume that longreal arguments
! are not 8-byte aligned
!
! - for Fortran, correct handling of the private
! option SCAN
!
! 6/04/90 - for Fortran, added externalinteger autoflag mfcompile48.13
!
! 1/04/90 - for Emachine>=4 and Fortran, tell Msetoptions
! if the -g option has been specified
!
!14/03/90 - initialise Comreg (especially 26) before mfcompile48.12
! calling Msetoptions
!
! - increase the size of Comreg from 50 to 60
! because Elfput may set Comreg(59)
!
! 5/03/90 - for both: enable instruction scheduling if mfcompile48.11
! any -O flag present
!
! 1/03/90 - for IMP: make CHECK a recognised long option mfcompile48.10
! mark unrecognised long options in
! the listing
!26/02/90 - for IMP: make ARRAY the default mfcompile48.9
! recognise -P MAP (the IMP compiler
! will report and generate line
! numbers with respect to the
! current source or include file
! and not the listing file
! make parm OPT imply NOARRAY
! set x'00800000' in options passed to
! Msetoptions if compiling with parm
! CHECK - the code generator will
! initialise floating point traps
! if compiling a main program
!
!02/02/90 - for Fortran, set minimum diags preparation mfcompile48.8
! when calling Msetoptions if one or both of
! Unassigned or Array Bound checking has been
! requested, even if -d has not been specified
!
!28/01/90 - common m88k and sparc version mfcompile48.7
!
!24/01/90 - if host is m88k then declare and initialise mfcompile48.6
! the diagnostics-stopper in main()
!
!18/01/90 - for Fortran modify criterion for setting the mfcompile48.6
! externalinteger Comopt3 from Usechipfns=Weitek
! to Fregopt=1 {available}. If Fregopt=1 or host=drs
! then the interpretation of the -O option is as
! described under mfcompile47b
!
! - for Fortran, add a declaration for externalinteger
! Parallelise
!
! - for Fortran, set x'00400000' in options passed
! to Msetoptions if the compiler is optimising
!
!05/01/90 - modify the options passed to Msetoptions (if mfcompile48.5
! Emachine>= 4) as follows:
!
! IMP: OPT => parm NOLINE
! NOTRACE => no preparation for diags
!
! FORTRAN: default => no preparation for diags
! and no dynamic line numbers
! -d => prepare for diags and
! dynamic line numbers
!
!03/01/90 - for IMP, implement -P ARRAY and interpret -C mfcompile48.4
! as -P ARRAY.
!
!28/11/89 - temporarily added NOARRAY to the default mfcompile48.3
! parameters for IMP because there currently
! is a problem with CBOUNDCHECK (in cprocs24).
!
!27/11/89 - added more compatibility with IMP using mf18i mfcompile48.2
! from castle as a model - in particular:
!
! MAXWORK and MAXDICT are the defaults: added
! the private option MINWORK if the original
! default is required.
!
! the option -m sets the workfile size to 513K
! rather than 256K.
!
! do a select output (Stdout) before calling
! Pgenerateobject (or Mgenerateobject) so
! that any tracing goes into the listing file
! and re-select Stderr on return.
!
! for IMP hijack the -w option to inhibit
! the verbose mode of the compiler.
! mfcompile48.1
!19/11/89 - uses the constinteger COMPILER in ftnht rather
! than the local constinteger LANGUAGE.
!
! - all references to comreg bar comreg(26) are
! now under COMPILER=IMP conditional compilation.
!
! - placed -s and -V under ALLOWVECTOR= YES.
!
! - added private option FILEMON (and FMON).
!
! - does not attempt to align the buffer acquired
! from malloc on some boundary.
!
! - updated for Emachine>= 4: in particular all
! PUT interfaces are assumed to start with P
! rather than M, and also:
!
! added private option CGMON to switch on fragment
! and instruction allocation/deallocation
!
! added call to Msetoptions
!
! - also merged in code from sicompile3.4 (mfcompile
! for IMP on SPARC) which in turn was based on
! micompile2 (mfcompile for IMP on SUN). These
! changes are under the constinteger COMPILER=IMP
! and the following differences may be perceived
! if this version is used in conjunction with an
! IMP compiler:
!
! for private option CODE set bit x'00004000' in
! comreg(27) - this passes the option to the
! impcompiler
!
! added private option NOCHECK
!
! -L is ignored (use -G instead)
!
! The following changes may be preceived if earlier
! versions of mfcompile were used by the IMP
! compiler:
!
! used Consource from micompile2
!
! initialise com27 to x'010A0022' rather than
! to x'01080000'
!
! signals are set by default (via setsigs)
!
! no longer outputs the compilation options
! specified and is relatively quiet about the
! source filename. The object filename is not
! output either
!
! added private options BIGWORK and MAXWORK
!
! does not attempt to align the work file
! acquired from malloc on some boundary
!
! does not include dummy routine for either
! pow_ri or poweroften
!
! mfcompile48
!06/09/89 - version 48 taken for common EPC source
! - reldate string placed in ftnht to avoid having
! to change mfcompile source each time
{07/08/89 - modified searchpath used by SELECT INCLUDE mfcompile47g}
{ which was incorporated into mfcompile47d. }
{ }
{ requires DR40 or later for the -Idir option. }
{ }
{ instead of using $PATH if -I (by itself) was }
{ specified, the new searchpath is: }
{ 1/. the host directory of the file which }
{ is being compiled (note that this is }
{ how INCLUDE files have always been }
{ searched for in EPC Fortran). }
{ 2/. each directory specified by a -Idir }
{ option (note that -I (by itself) is }
{ ignored) }
{ 3/. normally C would, as a last resort, look }
{ in /usr/include - but this is considered }
{ NOT suitable for Fortran as it may pick }
{ up a C include file by mistake. }
{ }
{ - passes the full name of the INCLUDE file (which }
{ was used in the successful open) to MSETFILES. }
{ MSETFILES (in cdput8) however will currently }
{ perform a no-op on this call. }
{ - removed a second (and therefore redundant) call }
{ on Malloc to align workareas if Fortran. }
{29/06/89 - add optcontrols mfcompile47f}
{19/04/89 - -Idir option implemented mfcompile47d}
{ uses dr36 }
{14/12/88 - use new include files mfcompile47c}
{ 7/08/88 - supports the new interpretation of the -O mfcompile47b}
{ option for the 386 which is as follows: }
{ }
{ -O normal optimisation }
{ -O1 normal optimisation + fregvars }
{ -O2 normal optimisation + in-lining }
{ -O12 normal optimisation }
{ or + fregvars }
{ -O3 + in-lining }
{ }
{ this new interpretation is currently controlled }
{ by HOST=DRS. }
{ - note this procedure requires dr22.c onwards. }
{ 2/08/88 - includes: ftn_ioconsts mfcompile47a}
{ ftn_ioparams }
{ ftn_statfmt }
{ }
{ use of these includes files removes the requirement }
{ to examine the form of the file information table }
{ when moving to another target. }
{ - add externalinteger COMOPT3 to select fregvar }
{ allocation in ftncode if using -O1: also add }
{ private option NOFREG to switch allocation off. }
{ 7/06/88 - remove private option NOUND. mfcompile47}
{ - inhibit -ff setting UseFarData. }
{ - merged UNISYS changes up to mfcompile42d }
{ }
{ these include: }
{ - tidied up output of the listing file when Stdout }
{ is different from Stderr: -the listing file gets }
{ the source file name as well: -Stderr gets a copy }
{ of any compilation errors. }
{ - also outputs the version text before the source }
{ file name. }
{ - re-sited position at which version text and }
{ source file name is output to Stderr. }
{ - introduce externalinteger Unasscheck to pass }
{ to PUT. }
{ }
{ - also merged SUN3 changes up to mfcompile42.1 }
{ these include: }
{ }
{ - uses the constinteger ENV in FTN_HT. }
{ - change "include" argument to Msetfiles as SUN3 }
{ impcompiler does not support a string value as }
{ a string name parameter. }
{ - the SUN3 compiler does not support Pcodeon or }
{ Lineprofile. }
{ }
{ NOTE: - if hosting on other than Gould, Unix5 DRS, or }
{ Sun3, then the format of the file information }
{ table should be checked. }
{25/05/88 - spell analyzed the American way mfcompile46}
{ - -i2 equivalent to -I2 }
{ - when checking line length check for tab }
{15/05/88 - Include files to be in source dir (from 43.1) mfcompile45}
{18/04/88 - replace private option fuse by nofuse mfcompile44}
{16/04/88 - make source file name visible mfcompile43}
{25/03/88 - provide alternative file info format for DRS mfcompile42}
{ - -nbs to set bslashnatural }
{17/03/88 - support -P Ov (optimise vectors) mfcompile41}
{11/03/88 - set Opt2max for max inline subroutine size mfcompile40}
{ - support -P newbr }
{06/03/88 - support -72 and add param to Sourceline mfcompile39}
{29/02/88 - generalised for 386 etc. }
{ - -f adequate for freeformat if not Gould }
{ - assume 132 char buffer }
{ - replace fuse,fusex by fuseall,fuse,fuselist }
{24/02/88 - Checknus will always be called from gput for cmn mfcompile38}
{23/02/88 - support -nus[file] and -P div; add Ckecknus mfcompile37}
{19/02/88 - Replace fuseloops by fuse and fusex }
{14/01/88 - version 1.1 mfcompile36}
{23/12/87 - Support -P fuseloops mfcompile35}
{ - -P code now gives private listing
{17/12/87 - -O now equivalent to -O1 mfcompile34}
{11/12/87 - Copyright to screen mfcompile32}
{09/12/87 - Support -sr and -se mfcompile31}
{18/11/87 - Support -P minvect mfcompile30}
{09/11/87 - -q means no output mfcompile29}
{ mfcompile28}
{05/11/87 - change depcheck to nodepcheck }
{ mfcompile27}
{15/10/87 - support for -ff,-bs,-be,-bm,-bu , X after G,any digit string}
{22/08/87 - add support for -nv to inhibit vectors}
{ Compilation Control routine for PNX }
{ Begun 14/oct/83 - Alan }
{ Revised 30/dec/83 }
{ rel 1.2 12/dec/84 accept -N(dltb) compile2}
{ rel 1.3 17/dec/84 accept -N(dltba) compile3}
{ rel 1.6 20/feb/84 fix include non-existant file compile4 }
{ -i => -A; -r => -v }
{ rel1.1(G) delete objectfile if compilation fails }
{ rel1.1(K) -A => -q }
{ rel1.2(A) forbid diagnostic options with optimising ones - compile7 }
{ rel1.2(B) Add routine DeleteObjectFile - compile8 15/Oct/85}
{ rel1.2(C) Check local filename length < 14 chars. compile9.i 9/dec/85}
{ alter for 680020 Fortran by using fort77 and P -> M }
{ rel0.1 Check -P text for UNSET before calling SetSigs. This is a }
{ consequence of ditching FORTENTRY in favour of /lib/crt0.o}
{ Control is received by routine COMPILE aliased to "main" }
{ (Driver7)}
{ rel0.2 -L becomes -G (use Driver8 for compatibility) }
{ by default no signal traps are set; use of '-P set' will}
{ set the traps (MFCOMPILE6) }
{ 28/7/86 Unite Fortran and Imp control routines - Alan }
{ 2/9/86 Amended compiler flags for Gould. - Alan }
{ 14/09/86 modified header and set Options2 for Inclusion/Exclusion - Geoff}
{ 30/9/86 Modified version text and stdout for -S - alan }
{ 14/Oct/86 Vsn 17 Set options2 on -f flag - alan }
{ 31/Oct/86 Vsn 17 Take + as -W terminator - alan }
{ 4/Nov/86 Vsn 17a DO not open object if -y option set - alan }
{ 5/Nov/86 Fix check for opt and diag together. }
{ Remove check on file length. - alan }
{ 17/4/87 Vsn 18 Put in release identifier }
{ 23/4/87 Vsn 19 Put in name table size -Nx }
{ 29/5/87 vsn 20 Support -P depanal - graham }
{ 02/7/87 vsn 22 Support -P depcheck - geoff }
{ 22/7/87 vsn 23 recode resolution of long names - geoff }
{ ignore -g to avoid loader failure - geoff }
{ 11/08/87 vsn 24 support -P prof }
{ 05/10/87 vsn 26 accept -Ws,lines }
include "ftnht.inc"
include "vers.inc"
include "protection.inc"
constinteger YES = 1
constinteger NO = 0
if Object Format = ISCOFF start
include "coff.inc"
finishelsestart
constinteger ADI Shared Commons = NO
finish
if Compiler= Fortran thenstart
externalinteger optcontrols {enable suppression of opt features}
{ 1 no fregs in inner loops }
{ 2 limit loop init (sred) }
{ 4 movement of TEMPs }
{16 no loop unrolling }
externalinteger quiet { suppresses passive compiler output }
externalinteger Comopt3 { set if non-interference }
externalinteger recipopt { set if compile-time reciprocate ia allowed}
externalinteger Autoflag
externalinteger hardoptions
externalinteger misalignedreals=0
externalinteger Opt2max=0
externalinteger ctriads
if Host= DRS and Env= Sequent thenstart
externalinteger ATSfort=0
finish
if Allowparallel# 0 thenstart
externalinteger Paralleloptions=0
externalstring(31) array Unshcom(1:127)
externalinteger Nunshcom = 0
finish
externalinteger Parallelise=0
externalinteger Profiler=0
externalinteger Lineprofiler=0
externalinteger Timeprofiler=0
externalintegerspec Inhib8X
externalstring(255) Srcefilename
externalinteger superscalar = 1
externalinteger G2traceMOO = 0
finish
externalinteger Xoptimiseoptions = 0 {referenced b Fortran optimiser}
externalinteger Poptimiseoptions = 0
externalinteger Unasscheck { referenced by PUT}
if Target = Sparc thenstart
externalinteger Sparcfsqrt = 0
finish
if Host=M88000 start
externalroutinespec disabletraps
finish
if HOST=DRS thenstart
externalroutinespec Esourcefile(string(255) name src)
if Usechipfns=Weitek and Env=Sequent thenstart
externalroutinespec Set Weitek Flags
finish
finish
if Host# Sun3 or Env= GOULD thenstart
if Emachine>= 4 thenstart
externalroutinespec Mcodeon
finishelsestart
externalroutinespec Pcodeon
finish
if Compiler= Fortran thenstart
externalintegerspec lineprofile
externalinteger f77plus=0 { set by -f77+ option. Turns on 77+ extensions}
finish
finish
if Compiler= Fortran and (Host# GOULD or Opsys# MPX) thenstart
externalintegerfnspec Compstream (integer fildes1, fildes2)
finish
if Emachine>= 4 thenstart
externalroutinespec Pfaulty
externalroutinespec Pmonon
externalroutinespec Emonon
!GT: %externalroutinespec Set Sigs
externalroutinespec Phex(integer n)
externalroutinespec Pgenerate Object(stringname s)
externalroutinespec Psetfiles(string(255) name src,obj,integer syntax)
externalroutinespec Msetoptions(integer options) {generator control}
externalroutinespec Esetoptions(integer cgoptions,botraceoptions, c
boinhiboptions,proc,fraglow,fraghigh)
externalroutinespec EsetGISoptions(integer buffzone,fullopt,trace, c
inhib,rangeregion)
externalroutinespec Cstring alias "s_cstring" (string(*) name Impstr, integer adCstr)
finishelsestart
externalinteger Msetoptions
externalroutinespec Mfaulty
externalroutinespec Mmonon
externalroutinespec Emonon
!GT: %externalroutinespec Set Sigs
externalroutinespec Phex(integer n)
externalroutinespec Mgenerate Object(stringname s)
externalroutinespec Msetfiles(string(255) name src,obj,integer syntax)
externalroutinespec Cstring(string(*) name Impstr, integer adCstr)
finish
if Compiler= IMP and Host= Sun3 thenstart
externalintegerspec SaveRegs { flag used by mgen and mcode to genearate}
{ code for saving d2-d7,a2-a5 for sun 3 }
{ when invoked by -P regsav }
finish
if Compiler= Fortran Start
externalintegerfnspec FORT77(integer Control,options1,options2,
F77parm,optflags,srcflags,
Console,Liststream,Diagstream,
Diagnostic level,Dsize,Tsize,
Bsize,Lsize,Asize,Nsize)
recordformat Optfilesfmt(integer inaddr,inlen,exaddr,exlen,nusaddr,nuslen)
externalrecord(Optfilesfmt) Optfiles
if Protection=FLEXLM start {Highland's licence server}
externalintegerfnspec getlicense alias "get_license" c
(integer adfeaturename)
ownstring(6) featurename="EPCF77"
finishelseif Protection=ALF start {ADI's licence server}
if Env=Gould start
externalintegerfnspec getadilicense alias "adi_get_gould_f77_license"
externalroutinespec freeadilicense alias "adi_free_gould_f77_license"
finishelsestart
externalintegerfnspec getadilicense alias "adi_get_f77_license"
externalroutinespec freeadilicense alias "adi_free_f77_license"
finish
finishelsestart {EPC timebomb}
externalintegerfnspec accesscontrol alias "access_control_" c
(integer adproducttag, adproductname)
ownstring(5) producttag="F77"
ownstring(6) productname="EPCF77"
finish
finishelsestart
if Target= SPARC or Target= rs6000 or Target=MIPS thenstart
externalroutinespec IMPCOMPILER alias "icl9cezrs6imp"
finishelsestart
externalroutinespec IMPCOMPILER alias "icl9cezgouldimp"
finish
finish
externalstring(15) fnspec Itos (integer n)
externalroutinespec EXIT (integer Process return code) { Sys call }
externalintegerfnspec Open (integer adname,mode) { Sys Call }
externalroutinespec LSeek (integer id,offset,whence) { Sys Call }
externalintegerfnspec Read (integer id,bytead,bytesize) { Sys Call }
externalroutinespec Close (integer id) { Sys Call }
externalintegerfnspec Unlink (integer bytead) { Sys Call }
externalintegerfnspec Mallocalias "getspace" (integer bytesize) { C Library via interface}
externalroutinespec Free (integer bytead) { C Library }
externalintegerfnspec Getfstat alias "s_getfstat" (integer id,bufad)
if Compiler= IMP or (Host= GOULD and Opsys= MPX) thenstart
externalintegerfnspec IsaTTY(integer id) { C library }
finish
if Compiler= IMP Start
recordformat EmasFileHeaderformat(integer dataend,
datastart,
filesize,
filetype,
sum,
datetime,
lda,
ofm)
finish
include "fstatfmt.inc"
if Compiler= Fortran thenstart
routinespec InitialiseSource
constinteger bufsize=4096
owninteger bufad
owninteger PrimarySrcID
owninteger warnlinelen = 0
finish
if Compiler= IMP thenstart
owninteger srclink=0
owninteger workad
externalinteger SrcId
owninteger Srcsize
finish
if Emachine>= 4 thenstart
externalinteger TargetVariant=0
owninteger cgoptions
!*
constinteger cgreport = x'00000001'
constinteger cgcodelist = x'00000002'
constinteger cgschedmon = x'00000004'
constinteger cgparamsind = x'00000008'
constinteger cgpeepmon = x'00000010'
constinteger cgglobsched = x'00000100'
constinteger cgleafopt = x'00000200'
constinteger cgpeepopt = x'00000400'
constinteger cgprofile = x'00010000'
constinteger cgsetdbx = x'00020000'
constinteger cgdiags = x'00040000'
constinteger cglinenos = x'00080000'
constinteger cglinetab = x'00100000'
constinteger cgtrapovf = x'00200000'
constinteger cgregvaropt = x'00400000'
constinteger cgFPUtraps = x'00800000'
constinteger cgschedule = x'01000000'
constinteger cgargchecks = x'02000000'
constinteger cgRTcodelist= x'04000000'
constinteger cglineprof = x'20000000'
constinteger cgcasesense = x'40000000'
constinteger notcgglob = x'FFFFFEFF'
constinteger notcgleaf = x'FFFFFDFF'
constinteger notcgpeep = x'FFFFFBFF'
constinteger notcgsched = x'FEFFFFFF'
if Target#RS6000 start
constinteger cgsmallPIC = x'08000000'
constinteger cglargePIC = x'10000000'
finishelsestart
constinteger cgrndsngl = x'08000000'
constinteger cghssngl = x'10000000'
constinteger cghsflt = x'40000000'
finish
owninteger botraceoptions = 0
owninteger boinhiboptions = 0
owninteger gisproc = 0
owninteger gisfraglow = 0
owninteger gisfraghigh = 0
owninteger gisbuffzone = 0
owninteger gisfullopt = 0
owninteger gistrace = 0
owninteger gisinhib = 0
owninteger rangeregion = -1
finish
constinteger READING = 0
owninteger syntaxcheck=0
owninteger monopt = 0
owninteger mmon = 0
ownbyteintegerarray Cstr(0:255)
owninteger adCstr
ownstring(255) IncludeDir
ownstring(255) IncludePath {a concatenation of all the directories}
{specified by any -Idir options }
externalintegermap Comreg(integer n)
ownintegerarray C(0:60)
result == C(n)
end
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
constinteger Stdin = 0,
Stdout = 1,
Stderr = 2
constinteger active = x'80000000', { Possible values of F77PARM}
depanal = x'40000000',
sdb = x'10000000',
I2 = x'08000000',
Optriads = x'04000000',
Triads = x'02000000',
Maps = x'01000000',
NoWarnlen = x'00002000',
NoWarn77 = x'00001000'
constinteger c
Onetrip = x'00000800',
F77 = x'00000400',
Vaxflag = x'00000200',
Unix = x'00000100',
Strict = x'00000080'
constinteger c
No Warnings = x'00000040',
No Comments = x'00000020',
NoBound = x'00000010'
constinteger c
MinBound = 8,
NoUnass = 4,
Noarg = 2,
NoChar = 1
constinteger Xref = x'00000800', { Possible values of CONTROL}
Code = x'00004000',
Attr = x'00008000',
NoList = x'00000002'
constinteger Listnone = x'00000800', { Possible values of Options1 }
Opt3 = x'00400000',
Opt2 = x'00200000',
Opt1 = x'00100000',
Maxdict = x'00000100',
NoCode = x'00000020',
Optext = x'00000010'
constinteger Dline = x'00000001', { Possible values of Options2 }
Xline = x'00000002',
Yline = x'00000004',
R8 = x'00000008',
List Includes = x'00000010'
constinteger c
Profile = x'00000020',
Noerrors = x'00000040',
Vectorise = x'00000080',
Inclusions = x'00000100',
Exclusions = x'00000200',
UseFarData = x'00000400',
Nounderscore = x'00000800'
constinteger c
nodepcheck = x'00001000',
fuseall = x'00002000',
nofuse = x'00004000',
fuselist = x'00008000',
bslashnatural = x'00010000'
constinteger c
optionalargs = x'00020000',
freeformat = x'00040000',
sroption = x'00080000',
seoption = x'00100000'
constinteger c
nus = x'00200000',
nusfile = x'00400000',
optimisevector = x'00800000',
csoption = x'01000000'
constinteger divset = x'00000001' {Possible values of hardoptions}
constinteger newbr = x'00000002'
{ FORT77 flags }
owninteger F77parm = active!Vaxflag!Unix!NoUnass!Noarg!NoChar!NoBound
owninteger control = NoList
owninteger options1 = 0
if Target= M88000 or Target=RS6000 thenstart
owninteger options2= nus {for 88OPEN conformance}
{or ibm compatibility }
finishelsestart
owninteger options2= 0
finish
owninteger srcflags = 0
owninteger optflags = 0
constinteger quotes = x'00000001' , {possible values for Comreg(27)}
{NoList = x'00000002'} {same as for CONTROL}
NoDiag = x'00000004' ,
iStack = x'00000008' ,
NoCheck = x'00000010' ,
NoArray = x'00000020' ,
NoTrace = x'00000040' ,
iProfile = x'00000080' ,
NoRange = x'00000100' ,
inhibiof = x'00000200' ,
zero = x'00000400' ,
{xref = x'00000800'} {same as for CONTROL}
labels = x'00001000'
constinteger c
let = x'00002000' ,
{code = x'00004000'} {same as for CONTROL}
{attr = x'00008000'} {same as for CONTROL}
opt = x'00010000' ,
iMap = x'00020000' ,
debug = x'00040000' ,
iFree = x'00080000' ,
dynamic = x'00100000' ,
{diag stream set = x'00200000'}
ebcdic = x'00400000'
constinteger c
NoLine = x'00800000' ,
{stack size set = x'01000000'}
NoMain = x'02000000' ,
parmz = x'04000000' ,
parmy = x'08000000' ,
parmx = x'10000000' ,
mismatch = x'20000000'
{not used = x'40000000'}
{not used = x'80000000'}
if Compiler= Fortran thenstart
owninteger dsize = 0
owninteger tsize = 0
owninteger lsize = 0
owninteger bsize = 0
owninteger asize = 0
owninteger nsize = 0
owninteger Diagnostic level = -1 { no diagnostics is default }
externalinteger minvect= 4 {minimum array extent for vector code}
owninteger dup output = 0 {set if info on Stdout is to be copied on Stderr}
if Target=RS6000 start
owninteger nohsflt {set to 1 if user specifies -qnohsflt}
finish
finish
owninteger Liststream = Stdout
owninteger Diagstream = Stderr
owninteger consolestream = 0{STDERR}
routine Abort (string(31) error, string(255) extra info)
!***************************************************************************
!* Reports an error message and then exit(1)'s - if extra info#"" then it *
!* too will be included in the error message *
!***************************************************************************
newline
printstring ("***")
printstring (error)
printstring (extra info) if extra info#""
newline
exit(1)
end; ! Abort
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
if Compiler= Imp thenstart
externalroutine ConSource(string(255)filename, integername filead)
!***************************************************************************
!* Connect source-file. Historically this derives from EMAS where the file *
!* is mapped onto virtual memory. On UNIX systems two alternatives exits: *
!* either the file is read into a large buffer whose address is returned *
!* via FileAd, or the file is simply opened and reading conducted on a *
!* block-by-block basis. In this case, FileAd is preset to -1. *
!***************************************************************************
byteintegerarray Cstr(0:255)
integer adCstr,i
record(Emasfileheaderformat) name Hdr
record(stat information table) Fid
adcstr = addr(cstr(0)){*2}
Cstring(filename,adcstr) { Get source filename in C format}
SrcId = Open(adcstr,READING) { Open source file}
if monopt # 0 then printstring("
SrcID = ") and write(SRcId,4)
if Srcid=3 then SrcID = Open(adcstr,READING) { Open source file}
! THIS IS JUST TILL WE GET AN OBJECT GENERATOR GOING - SRC MUST BE 4
if Srcid=-1 then printstring("
Cannot open source file ") and ->crunch
i = Getfstat(Srcid,addr(Fid)) { Request info. about source}
Srcsize = Fid_filesize { Find out its size}
if Srcsize=0 then printstring("
Empty file - ") and ->crunch
if i=0 start { If ok so far}
if monopt#0 then printstring("
claiming source buffer of ") and phex(Srcsize+32)
filead = malloc(Srcsize+32){//2} { Grab global space for source }
if monopt#0 then printstring(" at ") and phex(filead) and newline
finishelse printstring("
Cannot get status on source ") c { otherwise abort }
and ->crunch
if filead=0 start { abort if failed to get space }
printstring("
Malloc source buffer fails ")
monitor; ->crunch
finish
if monopt#0 then printstring("
file size = ") and write(Srcsize,1)
i = READ(SrcID,(filead{*2})+32,Srcsize) { Read source file into global }
CLOSE(SrcID) { close file }
Hdr == record(filead) { produce a pseudo emas header}
Hdr = 0
Hdr_datastart = 32
Hdr_dataend = 32 + Srcsize
Hdr_ofm = srclink { use spare field in hdr to }
srclink = filead { chain source areas together }
return
crunch: printstring(filename)
stop
end; ! ConSource
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish; !if IMP
externalroutine FreeSourceAreas
!***************************************************************************
!* This routine is called at the end of pass 1 to free source buffers. *
!***************************************************************************
if Compiler = Imp start
cycle
FREE(srclink)
srclink = integer(srclink+28)
repeat until srclink=0
finish
end; ! FreeSourceAreas
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
if Compiler= Fortran thenstart
routine printvers
printstring(F77version)
printstring(F77copyright text)
newline
end; ! printvers
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
routine Output (stringname text)
{This procedure prints the parameter on }
{Stderr. If DUP OUTPUT is not set to zero}
{the text will also be printed on Stdout }
{It assumes that Stderr is the currently }
{selected output stream }
print string (text)
if dup output# 0 thenstart
select output (Stdout)
print string (text)
select output (Stderr)
finish
end; ! Output
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish; !if Fortran
routine Prepare (integer argc, argv)
!***************************************************************************
!* Prepare compiler options from the argument strings collected by the *
!* compiler driver. argc is the number of arguments on the shell statement *
!* argv is a pointer to an array of string pointers specifying the argum- *
!* ents as null-terminated strings. *
!***************************************************************************
integerfnspec readn
integerfnspec readbv
routinespec readnn(integername val1,val2)
ownbyteintegerarrayformat argfm(1:1000)
ownbyteintegerarrayname args
ownintegerarrayformat argptrfm(1:100)
ownintegerarrayname argptr
integer argument
integer i,vptr,c,ptr,invalid
string(254) source,s,object,root
integer table
integer slen
integer setsigs flag {set to 1 if signal traps are to be set}
{set to 0 otherwise }
owninteger com26= 0
if ADI Shared Commons=YES start
externalroutinespec shcom list set up(string(32) common)
byteintegername new shcom byte
string(32) new shcom {temp for -SC option}
finish
if Compiler= IMP thenstart
record(Emasfileheaderformat) name Hdr
owninteger workK = 2047
owninteger srcad
owninteger com27= x'01000000' {stack size set} ! iFree ! NoList
owninteger com28 = 0
owninteger com23 = -1
owninteger com40 = Stderr
owninteger noisy = 1
stringname params {mapped onto Cstr while processing private options}
finish
if Compiler= Fortran thenstart
record(stat information table) Fid
integer filead
integer type
integer ID
integer size
integer x
ownstring(5) producttag="F77"
ownstring(6) productname="EPCF77"
ownstring(80) Warning 1 Text= ""
conststring(4) array Warning 1 Option (1:7)= " -d" , " -U" , " -V" ,
" -C" , " -g" , " -pl",
" -pt"
{the above order is dependent upon the order in}
{which Prepare looks for inconsistent options }
integer Warning 1 flag
finish
if Compiler= IMP thenstart
comreg(40) = 2 { Imp error stream }
setsigs flag= 1 { set signals after processing any options/switches}
finishelsestart
size= 0
setsigs flag= 0 { dont set signals}
finish
argptr == array(argv,argptrfm)
argument = 1
adcstr = addr(Cstr(0))
Includepath = ""
object = "" { not explicitly specified }
{---------------------------------------------------------------------------}
{ ********* Analyse Streams specified }
{ If list or diag stream is not tied to console: , tell compiler }
{ with a negative number. Otherwise set positive }
if Compiler= IMP or (Host= GOULD and Opsys= MPX) thenstart
if IsaTTY(Stdout)#1 then Liststream = - Stdout
unless Diagstream=0 start
if IsaTTY(Stderr)#1 then Diagstream = - Stderr
finish
finishelse if Compstream (Stdout,Stderr)= 0 then Liststream= - Stdout
select output (stderr) { All status messages to go to STDERR}
if Compiler= Fortran Start
printvers
if Protection=FLEXLM start
i = getlicense(addr(featurename))
finishelseif Protection=ALF start
i = getadilicense
finishelsestart
i = access control(addr(producttag), addr(productname))
finish
if i#0 then EXIT(1)
finish
{---------------------------------------------------------------------------}
{ *********** Options following - are second parameter }
{ Standard UNIX single letter options }
if argc < 2 start { No command line arguments }
EXIT(0)
finish
cycle
args == array(argptr(argument+1),argfm)
if args(1)='-' start
argument = argument+1
vptr = 2 { discard '-' }
cycle
c = args(vptr)
exit if c = 0
ifc
c = '1' start
if Compiler= Fortran thenstart
if args(vptr+1)='3' and args(vptr+2)='2' start { - 132 }
Options2 = Options2 ! freeformat
warnlinelen = 132
vptr = vptr+2
finishelsestart { ONETRIP every DO loop to exec at least once }
F77parm = F77parm!Onetrip
finish
finish
finishelseifc
c = 'C' start { array bound checks on }
if args(vptr+1)='S' thenstart {-CS case sensitivity on}
if Compiler=Fortran thenstart
options2=options2!csoption
vptr = vptr + 1
finish
finishelsestart { array bound checks on }
if Compiler= IMP thenstart
com27 = com27&(¬NoArray)
finishelsestart
F77parm = (F77parm!MinBound)&(¬NoChar)
finish
finish
finish elseifc
c = 'g' start {SDB flag or gis buff }
if args(vptr+1)='i' thenstart {-gisbuff= }
vptr = vptr + 7
i = 0
cycle
c = args(vptr+1) {get digits}
exit unless '0' <= c <= '9'
i = (i*10) + (c - '0')
vptr = vptr+1
repeat
if c = '+' then vptr = vptr + 1
gisbuffzone=i {set value}
finishelsestart {-g}
F77parm = F77parm!sdb
com26 = com26!4 { tell PUT }
cgoptions = cgoptions & (¬cgschedule) {scheduling off}
finish
finish elseifc
c = 'G' start {Listing reqd}
c = args(vptr+1)
if Compiler= IMP thenstart
com27 = com27&(¬NoList)
finishelsestart
Control = Control&(¬NoList)
if c='1' or c='2' start
if c='1' then Options2=Options2!ListIncludes { and list include files }
if c='2' then Options1=Options1! Optext { and show code movement by optimiser }
vptr=vptr+1
c = args(vptr+1)
finish
finish
if c='X' then vptr=vptr+1
finishelseifc
c = 'u' thenstart
if args(vptr+1)= 's' and args(vptr+2)= '+' thenstart { -underscore }
options2 = options2 & (~nus)
vptr = vptr + 2
finishelsestart
F77parm = F77parm!x'4000' { type=undef }
finish
finishelseifc
c = 'w' start { suppress warnings and comments}
if Compiler= IMP thenstart
noisy= 0
finishelsestart
if args(vptr+1)='7' start { suppress F77 warnings }
F77parm = F77parm!NoWarn77
vptr=vptr+2 { pass over '77' }
finishelse F77parm = F77parm!No Warnings!No Comments!NoWarn77
finish
finishelseifc
c = 'x' start
if Emachine>= 4 thenstart
cgoptions = cgoptions & (¬cgschedule) { -x used }
finish
finishelseifc
c = 'y' start { syntax check}
Options1 = Options1!NoCode
syntaxcheck=1
if Compiler= IMP thenstart
if Emachine>= 4 then Pfaulty c
else Mfaulty
finish
finishelseifc
c = 'p' start { generate profile information }
{ position independent code }
if args(vptr+1)='i' and args(vptr+2)='c' and c
args(vptr+3)='+' thenstart
if Emachine= 4 and Target#RS6000 thenstart
vptr=vptr+2
cgoptions= cgoptions ! cgsmallPIC
finishelsestart
finish
finishelsestart
if args(vptr+1)='l' thenstart
if Emachine= 4 thenstart
cgoptions= cgoptions ! cglineprof
finish
if Target# SPARC and Compiler= Fortran then Lineprofiler = 1
vptr=vptr+1
finishelsestart
if args(vptr+1)='t' thenstart
if Compiler= Fortran then Timeprofiler = 1
vptr=vptr+1
finishelsestart
if Compiler= Fortran then Profiler = 1
Options2 = Options2 ! profile
if Emachine >=4 thenstart
cgoptions= cgoptions!cgprofile
finish
finish
finish
finish
finishelseifc
c = 'P' start {position independent code - large model}
if args(vptr+1)='I' and args(vptr+2)='C' and c
args(vptr+3)='+' thenstart
if Emachine= 4 and Target#RS6000 thenstart
vptr=vptr+2
cgoptions= cgoptions ! cglargePIC
finishelsestart
finish
finish
finishelseifc
c = 'q' thenstart
if Target=RS6000 start
if args(vptr+1)='n' and args(vptr+2)='o' start
if args(vptr+3)='c' and args(vptr+4)='h' start
cgoptions=cgoptions & (~cgtrapovf) {-qnochkof}
vptr=vptr+7
finishelseif args(vptr+3)='r' and args(vptr+4)='n' andc
args(vptr+5)='d' start {-qnorndsngl}
cgoptions=cgoptions & (~cgrndsngl)
vptr=vptr+9
finishelseif args(vptr+3)='h' and args(vptr+4)='s' start
if args(vptr+5)='s' start {-qnohssngl}
cgoptions=cgoptions & (~cghssngl)
vptr=vptr+8
finishelseif args(vptr+5)='f' start {-qnohsflt}
cgoptions=cgoptions & (~cghsflt)
nohsflt=1
vptr=vptr+7
finish
finish
finishelseif args(vptr+1)='c' and args(vptr+2)='h' start
cgoptions=cgoptions ! cgtrapovf {-qchkof}
vptr=vptr+5
finishelse if args(vptr+1)='r' and args(vptr+2)='n' andc
args(vptr+3)='d' start {-qrndsngl}
cgoptions=cgoptions ! cgrndsngl
vptr=vptr+7
finishelseif args(vptr+1)='h' and args(vptr+2)='s' start
if args(vptr+3)='s' start {-qhssngl}
cgoptions=cgoptions ! cghssngl
vptr=vptr+6
finishelseif args(vptr+3)='f' start {-qhsflt}
cgoptions=cgoptions ! cghsflt
vptr=vptr+5
nohsflt=0
finish
finishelsestart
Consolestream = 0
finish
finishelsestart
Consolestream = 0
finish
finishelseifc
c = 'S' thenstart {list of shared commons}
if (ADI Shared commons=YES) and (args(vptr+1) = 'C') start
vptr=vptr+1
while args(vptr) # '+' cycle
vptr=vptr+1
i=0
while (args(vptr+i) # ',') and (args(vptr+i) # '+') and i<32 cycle
new shcom byte == byteinteger(addr(new shcom) + i + 1)
new shcom byte = args(vptr+i)
i=i+1
repeat
new shcom byte == byteinteger(addr(new shcom))
new shcom byte = i {set up length}
vptr=vptr+i
shcom list set up(new shcom) {pass as string}
while (args(vptr) # ',') and (args(vptr) # '+') cycle
vptr=vptr+1
repeat
repeat
finishelsestart
Control = Control!code
if Emachine>= 4 thenstart
cgoptions=cgoptions!cgcodelist
finishelsestart
if Compiler= IMP thenstart
com27 = com27 ! code
finish
finish
finish
finishelseifc
c = 'a' start { xref listing }
if Compiler= Fortran andc
args(vptr+1)='u' and args(vptr+2)='t' andc
args(vptr+3)='o' thenstart {automatic}
Autoflag=1
vptr=vptr+3
finishelsestart
if Compiler= Fortran andc
Host= DRS and Env= Sequent thenstart
if args(vptr+1)='t' and args(vptr+2)='s' thenstart {ats}
ATSfort=1
vptr=vptr+2
finishelse Control = Control!xref!attr
finishelse Control = Control!xref!attr
finish
finishelseifc
c = 'U' thenstart { unassigned checking on }
if Target= Gould thenstart
F77parm = F77parm&(¬(NoUnass!Noarg))
finishelsestart
F77parm = F77parm&(¬NoUnass)
finish
Unasscheck=1
finishelseifc
c = 'O' start { optimisation }
cgoptions = cgoptions ! cgschedule ! cgpeepopt ! cgleafopt
if Compiler = IMP start
com27 = com27!opt
finishelsestart
{ enable instr scheduling}
if args(vptr+1)='X' start { default case - just -O }
Options1=Options1!opt1
vptr=vptr+1
finishelsestart
Options1=Options1!opt1 if Host=drs or Fregopt=1
cycle
vptr=vptr+1
c=args(vptr)
exit if c='X'
if c='1' thenstart
Options1=Options1!opt1 if Host#drs and Fregopt=0
Comopt3 =1 if Fregopt=1 {available}
cgoptions=cgoptions!cgparamsind
finishelsestart
if c='2' then Options1=Options1!opt2
if c='3' thenstart
recipopt=1 {compile-time invert}
finish
if c='4' or c='5' thenstart
cgoptions = cgoptions ! cgglobsched
if c='5' then gisfullopt = 1
finish
finish
repeat
finish
finish
finishelseifc
c = 'D' start { Conditional compilation markers }
if Compiler= Fortran thenstart
vptr = vptr + 1
c = args(vptr)
if c='D' then Options2 = Options2 ! Dline
if c='X' then Options2 = Options2 ! Xline
if c='Y' then Options2 = Options2 ! Yline
finish
finishelseifc
c = 'n' start
if Compiler= Fortran thenstart
vptr = vptr + 1
c = args(vptr)
if c='b' thenstart
vptr = vptr + 1
c = args(vptr)
if c='s' thenstart
Options2 = Options2 ! bslashnatural
finish
->continue
finish
if c='v' then Inhib8X=1
if c='u' thenstart
vptr = vptr + 1
c = args(vptr)
if c='s' thenstart; ! nus
Options2=Options2!nus
vptr = vptr + 1
if args(vptr)='+' then ->continue
s = ""
cycle
s = s.tostring(args(vptr))
vptr = vptr + 1
repeat until args(vptr) = '+'
cstring(s,addr(cstr(0)))
ID = OPEN(addr(cstr(0)),READING)
if ID<0 start
Abort ("Failed to open -nus file","")
finish
i = Getfstat(ID,addr(Fid))
size = Fid_filesize
filead = malloc(size)
i = READ(ID,filead,size)
if i<0 start
Abort ("Failed to read -nus file","")
finish
Close(ID)
Optfiles_nusaddr = filead
Optfiles_nuslen = size
Options2=Options2 ! nusfile
finish
finish
finish
finishelseifc
c = 'e' start { switch off error reporting }
Options2 = Options2! noerrors
finishelseifc
c = 'r' start { force double precision }
vptr = vptr+1 { get over '8' }
Options2 = Options2 ! R8
finishelseifc
c = 'f' start
if Target = Sparc thenstart {look for fsqrt}
if args(vptr+1)='s' and args(vptr+2)='q' and c
args(vptr+3)='r' and args(vptr+4)='t' and c
args(vptr+5)='+' thenstart
Sparcfsqrt=1
vptr=vptr+5
->continue
finish
finish
if Compiler= Fortran thenstart
c = args(vptr+1)
if c='f' thenstart { free format }
Options2 = Options2 ! freeformat
warnlinelen = 132
vptr= vptr + 1
finishelsestart { Use Far Data }
if Target=GOULD thenstart
if c = 'X' then vptr = vptr + 1
Options2 = Options2 ! UseFarData
finishelsestart
Options2 = Options2 ! freeformat
warnlinelen = 132
finish
finish
finish
finishelseifc
c = 'b' start { NP1 Vectorise }
vptr = vptr + 1
c = args(vptr)
if c = 's' then Options2 = Options2 ! bslashnatural
if c = 'm' then Options2 = Options2 ! optionalargs
finishelseifc
c = 's' start { scalar SUM }
if Allowvector= 1 thenstart
vptr = vptr + 1
c = args(vptr)
if c = 'r' then Options2 = Options2 ! sroption
if c = 'e' then Options2 = Options2 ! sroption ! seoption
finishelsestart
if Allowparallel#0 thenstart
if args(vptr+1)='i' and args(vptr+2)='n' and c
args(vptr+3)='g' and args(vptr+4)='l' and c
args(vptr+5)='e' thenstart {single}
Paralleloptions=Paralleloptions!1
vptr=vptr+5
finish
finish
finish
finishelseifc
c = 'V' start
if Target= Gould thenstart { NP1 Vectorise }
if Allowvector= 1 thenstart
Options2 = Options2 ! Vectorise
finish
finishelsestart { Parameter Checking }
F77parm = F77parm&(¬Noarg)
finish
finishelseifc
c = 'W' start { File of routine names }
{ for Optimiser }
if Compiler= Fortran start
vptr = vptr +1 { get over 'O' }
type = args(vptr)
if type = 's' start { -Ws,<digits> (lines) }
vptr = vptr + 1
i = 0
cycle
c = args(vptr+1)
exit unless '0' <= c <= '9'
i = (i*10) + (c - '0')
vptr = vptr+1
repeat
vptr = vptr+1 if c='+'
vptr = vptr+1
Opt2max=i
continue
finish
vptr = vptr +2
s = ""
cycle
s = s.tostring(args(vptr))
vptr = vptr + 1
repeat until args(vptr) = '+'
cstring(s,addr(cstr(0)))
ID = OPEN(addr(cstr(0)),READING)
if ID<0 start
Abort ("Failed to open -WO file","")
finish
i = Getfstat(ID,addr(Fid))
size = Fid_filesize
filead = malloc(size)
i = READ(ID,filead,size)
if i<0 start
Abort ("Failed to read -WO file","")
finish
Close(ID)
if type = 'i' start
Optfiles_inaddr = filead
Optfiles_inlen = size
Options2 = Options2 ! Inclusions
finishelsestart
Optfiles_exaddr = filead
Optfiles_exlen = size
Options2 = Options2 ! Exclusions
finish
finish { fortran }
finishelseifc
c = 'I' or c = 'i' start { set default integer size }
vptr = vptr + 1
c = args(vptr)
if c = '2' then F77Parm = F77Parm!I2 elsec
if c # '4' and args(vptr-1) = 'I' thenstart
ptr = addr(s)
cycle
ptr = ptr + 1
byteinteger(ptr)= c
if c = '+' thenexit
vptr = vptr + 1
c = args (vptr)
repeat
i = ptr - (addr(s))
if i > 1 then length(s) = i and Includepath = Includepath . s
finish
finishelseifc
c = 'o' start { nominate an alternative object filename }
ptr = addr(object)
cycle
v ptr = vptr + 1
c = args(vptr)
exit if c = '+'
ptr = ptr + 1
byteinteger(ptr) = c
repeat
length(object) = ptr - addr(object)
finishelseif c = 'Y' start
if Allowparallel# 0 thenstart
vptr = vptr + 1
c = args(vptr)
ptr = addr(s)
cycle
if c = '+' thenexit
ptr = ptr + 1
byteinteger(ptr)= c
vptr = vptr + 1
c = args (vptr)
repeat
i = ptr - (addr(s))
if i > 0 thenstart
length(s) = i
if Nunshcom<127 thenstart
Nunshcom = Nunshcom+1
Unshcom(Nunshcom) <- s
finishelsestart
Abort ("Only 127 unshared common blocks allowed","")
finish
finish
finish
finishelseifc
c = 'N' start { Table size }
vptr = vptr + 1
table = args(vptr)
i = 0
cycle
c = args(vptr+1)
exit unless '0' <= c <= '9'
i = (i*10) + (c - '0')
vptr = vptr+1
repeat
if c = '+' then vptr = vptr + 1
if Compiler= Fortran thenstart
if table = 'd' then dsize = i
if table = 't' then tsize = i
if table = 'l' then lsize = i
if table = 'b' then bsize = i
if table = 'x' then nsize = i
if table = 'a' then asize = i
finishelsestart
workK= i
finish
finishelseifc
c = '7' start { line length check}
if Compiler= Fortran thenstart
vptr=vptr+1
c = args(vptr)
if c='2' thenstart
warnlinelen = 72
c = args(vptr+1)
finishelsestart
if Env=Gould and c='7' start
c = args(vptr+1)
if c='+' start
f77plus=1 {77+ extensions}
vptr=vptr+1
finish
finish
finish
finish
finishelseifc
c = 'd' start { Diagnostics }
if Compiler= Fortran thenstart
i = 0
cycle
c = args(vptr+1)
exit unless '0' <= c <= '9'
i = (i*10) + (c - '0')
vptr = vptr+1
repeat
if c = '+' then vptr = vptr + 1
Diagnostic level = I
finish
finishelseifc
c = 'm' thenstart { parallel }
if Allowparallel#0 thenstart
if args(vptr+1)='p' thenstart
vptr=vptr+1 { pass over 'p' }
Parallelise=1
finish
finish
if Compiler= IMP thenstart
com28 = com28!x'100'
workK = 2047 if workK<2047
finish
finish
continue:
not implemented:
vptr = vptr+1
repeat
finish else exit
repeat
if Allowparallel#0 thenstart
if Parallelise=1 and Lineprofiler=1 then Lineprofiler=0
if Parallelise=1 and Timeprofiler=1 then Timeprofiler=2
finish
if OCScompliant=0 and (Target=M88000 and Object Format=ISBSDOMRON) start
options2 = options2&(~nus) {hardwire -us only for OMRON}
finish
argument = argument+1
{----------------------------------------------------------------------------}
{ ********* SOURCE FILE is third parameter }
source=""
args == array(argptr(argument),argfm)
vptr = 1
argument = argument+1
cycle
source=source.tostring(args(vptr))
vptr=vptr+1
repeat until args(vptr)=0
root = source
length(root) = length(root)-1 { discard 'i' }
if Compiler= Fortran thenstart
Srcefilename=source {available for error reports}
printstring(source)
newline
finish
{----------------------------------------------------------------------------}
{ ******** Fourth parameter is -P text used for private verbose options }
if Host= Sun3 and Compiler= IMP thenstart
SaveRegs=0 { assume registers are not to be saved }
finish
s = ""
if Compiler= IMP thenstart
params== string (AdCstr) {params will be used to save the identity}
params= "" { of the private options specified }
finish
if argptr(argument)=0 then ->NOfourthPARAM
args == array(argptr(argument),argfm)
vptr = 1
cycle
c = args(vptr)
if c=',' or c='/' or c=0 start
exit if s="(NULL)" {no long options}
invalid=0
if Compiler = IMP start
if s = "LIST" then start; com27 = com27&(¬NoList)
finishelseif s = "CODE" thenstart
com27 = com27 ! code
if Host# Sun3 or Env= GOULD thenstart
if Emachine>= 4 then Mcodeon c
else Pcodeon
finishelse control= control ! code
{ s = "DIAG" %then Diagstream = 2 {Stderr}{ %elseifc }
finishelseif s = "OPT" then start
com27 = com27!opt
finishelseif s = "QUOTES" or s="CASESENS" then start;
com27 = com27!1
finishelseif s = "MAP" then start
com27 = com27!iMap
finishelseif s = "FIXED" then start
com27 = com27&(¬iFree)
finishelseif s = "PROFILE" then start
com27 = com27!iProfile
finishelseif s = "NOTRACE" then start
com27 = com27!NoTrace
finishelseif s = "NOLINE" then start
com27 = com27!NoLine
finishelseif s = "NOCHECK" then start
com27 = com27!NoCheck
finishelseif s = "MIPS2" then start
TargetVariant=5{R4000}
finishelseif s = "CHECK" then start
com27 = com27&(¬Nocheck)
finishelseif s = "NODIAG" then start
com27 = com27!NoDiag
finishelseif s = "NOARRAY" then start
com27 = com27!NoArray
finishelseif s = "ARRAY" then start
com27 = com27&(¬NoArray)
finishelseif s = "PARMX" then start
com27 = com27!parmx
finishelseif s = "PARMY" then start
com27 = com27!parmy
finishelseif s = "PARMZ" then start
com27 = com27!parmz
finishelseif s = "LINE" then start
com27 = com27&(¬NoLine)
finishelseif s = "MINWORK" then start
com28 = com28&x'FFFFFEFF'
workK = 128
finishelseif s = "BIGWORK" then start
workK = 512
finishelseif s = "MAXWORK" then start
workK = 2047 if workK<2047
finish elseif s = "MAXDICT" then start
com28 = com28!x'100'
finishelseif Host= Sun3 and s = "REGSAV" then start
SaveRegs= 1
finishelsestart
{ none of these } invalid=invalid+1
{GT}finish
finish
if s = "SCAN" thenstart
if Emachine>= 4 then Pfaulty c
else Mfaulty
Options1 = Options1!NoCode
syntaxcheck= 1
finish elseifc
s = "VERSION" then start; printstring(reldate); finishelseifc
s = "OPTIONS" then start; monopt = 1; finishelseifc
{GT: messed up an edit - check against original if line below is OK }
s = "SET" then start; setsigs flag = 1; finishelseifc
s = "UNSET" then start; setsigs flag= 0; finishelseifc
s = "FILEMON" orc
s = "FMON" then start; com26= com26!16; finishelseifc
s = "MALLOCMON" then start; com26= com26!128
mmon=1; finishelseifc
s = "CGMON" thenstart
if Emachine>=4 then cgoptions=cgoptions!cgreport
finish elseifc
s = "CGSCHED" thenstart
if Emachine>=4 thenstart
cgoptions=cgoptions!cgschedule
finish
finish elseifc
s = "CGSCHEDMON" thenstart
if Emachine>=4 thenstart
cgoptions=cgoptions!cgschedule!cgschedmon
finish
finish elseifc
s = "CGPEEPMON" thenstart
if Emachine>=4 thenstart
cgoptions=cgoptions!cgpeepmon
finish
finish elseifc
s = "PMON" orc
s = "P" thenstart
if Emachine>= 4 then Pmonon c
else Mmonon
finish elseifc
s = "EMON" orc
s = "E" then Emonon elsec
{ none of these } invalid=invalid+1
if compiler = IMP start
if invalid=2 then s="[".s."]"
if params="" then params=s else params=params.",".s
finish
if c=0 then exit
s=""
vptr = vptr+1 { discard , or / }
continue
finish
if 'a'<=c<='z' then c = c - 32
s = s.tostring(c)
if Compiler = Fortran or Compiler = Imp Start
if s="G" thenstart
c = args(vptr+1)
vptr = vptr+1
if c='x' thenstart
cgoptions = cgoptions & notcgsched
finishelseif c
c='l' thenstart
cgoptions = cgoptions & notcgleaf
finishelseif c
c='g' thenstart
cgoptions = cgoptions ! cgglobsched
finishelseif c
c='p' thenstart
cgoptions = cgoptions & notcgpeep
finishelseif c
c='Y' thenstart
cgoptions = cgoptions ! cgschedmon
finishelseif c
c='m' thenstart
i = readn
cgoptions = cgoptions ! ((i&15)<<12)
finishelseif c
c='t' thenstart
gistrace = readbv
finishelseif c
c='I' thenstart
gisinhib = readbv
finishelseif c
c='B' thenstart
boinhiboptions = readbv
finishelseif c
c='P' thenstart
gisproc = readn
finishelseif c
c='R' thenstart
readnn(gisfraglow,gisfraghigh)
finishelseif c
c='u' thenstart
rangeregion = readn
finishelseif c
c='b' thenstart
botraceoptions = readbv
finishelsestart
printstring("invalid option g".tostring(c))
newline
finish
s=""
finish
finish
if Compiler = Fortran start
if s = "SF" or s="OF" or s="LIMIT" or s="MINVECT" c
or s="X" or s="Z" start
i = 0
cycle
c = args(vptr+1)
exit unless '0' <= c <= '9'
i = (i*10) + (c - '0')
vptr = vptr+1
repeat
if s="X" then Xoptimiseoptions = Xoptimiseoptions ! i
if s="Z" then Poptimiseoptions = Poptimiseoptions ! i
if s="SF" then srcflags = i
if s="OF" then optflags=i
if s="LIMIT" then optcontrols=optcontrols ! i
{%if s="LIM" %then options2=options2!(i<<16)}
if s="MINVECT" then minvect=i
s=""
finish
finish
vptr = vptr+1
repeat
NOFOURTHPARAM:
!check if signal traps are to be set (for diagnostics}
!
Set Sigs unless setsigs flag= 0
comreg(26)= com26 if com26# 0
comreg(27)= com27 if Compiler= Imp and com27# 0
comreg(28)= com28 if Compiler= Imp and com28# 0
if Compiler= Fortran start
!*
!***************************************************************************
!* analyse options/switches specified *
!***************************************************************************
!*
Warning 1 Flag= 0
if options1&(opt1!opt2!opt3) # 0 thenstart
if Diagnostic level # -1 thenstart
Warning 1 Flag= 1
finish
if F77parm&NoUnass = 0 thenstart
Warning 1 Flag= Warning 1 Flag ! 2
finish
if F77parm&Noarg = 0 thenstart
Warning 1 Flag= Warning 1 Flag ! 4
finish
if F77parm&MinBound # 0 thenstart
Warning 1 Flag= Warning 1 Flag ! 8
finish
if F77parm&sdb # 0 thenstart
Warning 1 Flag= Warning 1 Flag ! 16
finish
if Lineprofiler # 0 thenstart
Warning 1 Flag= Warning 1 Flag ! 32
finish
if Emachine= 4 andc
(cgoptions & cglineprof) # 0 then Warning 1 Flag= Warning 1 Flag ! 32
if Timeprofiler # 0 then Warning 1 Flag= Warning 1 Flag ! 64
!
!(Optimising overrides Diagnostics, Unassigned Checking, Argument
! Checking, Array Bound Checks, SDB, Line Profiling,
! and Time Profiling}
if Warning 1 Flag# 0 thenstart {undo any damage}
F77parm = (F77parm & ( ¬(MinBound!sdb)) ! NoChar ! NoUnass ! Noarg )
if Emachine= 4 thenstart
cgoptions= cgoptions & (~cglineprof)
finish
Diagnostic level = -1
!Note:
! Check consistency of options before calling Msetoptions. Any
! inconsistency however cannot be reported until the status of
! the listing and error stream has been established - hence set
! a flag which will be inspected later
finish
finish
finish
if Emachine>= 4 thenstart
!*
!***************************************************************************
!* prepare options for code generator *
!***************************************************************************
!*
if Compiler= IMP thenstart
if (com27 & opt )# 0 then com27=com27 ! NoLine ! NoArray ! NoTracec
and comreg(27)= com27
if (com27 & NoTrace)= 0 then cgoptions= cgoptions ! cgdiags
if (com27 & NoLine )= 0 then cgoptions= cgoptions ! cglinenos
if (com27 & Nocheck)= 0 then cgoptions= cgoptions ! cgFPUtraps
finish
if Compiler= Fortran thenstart
if Diagnostic level>= 0 orc
(F77parm & 15) # 7 then cgoptions=cgoptions ! cgdiags ! cglinenos
if (F77parm & sdb) # 0 then cgoptions=cgoptions ! cgsetdbx
if (F77parm & Noarg)= 0 then cgoptions=cgoptions ! cgargchecks
if (Options1 & opt1)# 0 then cgoptions=cgoptions ! cgregvaropt
finish
!
if Target = M88000 or Target = SPARC then start
{ no instruction scheduling if any diagnostic options are set }
if (cgoptions & (cgdiags ! cglinenos ! cgsetdbx ! cgargchecks) <> 0) c
then cgoptions = cgoptions & (¬cgschedule)
finish
!
if options2&csoption#0 then cgoptions=cgoptions!cgcasesense {-CS}
if Compiler = Fortran or Compiler = Imp thenstart {modified 06/07/93}
Esetoptions(cgoptions,botraceoptions,boinhiboptions,gisproc, c
gisfraglow,gisfraghigh)
EsetGISoptions(gisbuffzone,gisfullopt,gistrace, c
gisinhib,rangeregion)
finishelsestart
Msetoptions (cgoptions)
finish
finishelsestart
Msetoptions = F77parm
finish
{--------------------------------------------------------------------------}
s = source
{i=i+1 %while s ->("/").s}
IncludeDir = ""
slen=length(s)
cycle i=slen,-1,1
if charno(s,i)='/' thenstart
IncludeDir = s
length(Includedir)=i
charno(s,i)=slen-i
s=string(addr(s)+i)
exit
finish
repeat
!%if length(s)>14 %start
!print string ("Error: File name longer than 14 characters ")
!print string ( s )
!newline
!EXIT(1)
!%finish
if object="" thenstart
slen= length(s) - 1 {prepare to discard 'f' or 'i'}
if Compiler= Fortran thenstart
if charno(s,slen)='f' thenstart
slen= slen - 1 {allow for .fv}
finishelsestart
if (charno(s,slen)='o' and charno(s,slen-1)='f') thenstart
slen= slen - 2 {allow for .for}
finish
finish
finish
length(s)= slen
object = s."o"
finish
if Compiler= Imp and (com27 & NoList)= 0 thenstart
!*
!***************************************************************************
!* print header to the listing file (if IMP and LIST) *
!***************************************************************************
!*
if params= "" then params= "Defaults"
if Diagstream> Liststream thenstart
print string (source) {on Stderr}
newline
finish
select output (Stdout)
print string ("Source: "); print string (source); newline
print string ("Object: "); print string (object); newline
print string ("Parms: "); print string (params); newline
finishelsestart
if Compiler= IMP then print string (source) and newline
finish
if Host=DRS thenstart
Esourcefile(source) { Inform gen of sourcefilename }
finish
if Emachine>= 4 thenstart
Psetfiles(source,object,syntaxcheck) { Inform Put of source and object}
finishelsestart
Msetfiles(source,object,syntaxcheck) { Inform Put of source and object}
finish
if Compiler= Fortran start
Cstring(source,adcstr)
primarySrcID = Open(adcstr,READING)
if primarySrcID<0 thenstart
Abort ("Failed to open Sourcefile - ",source)
finish
finish
if Compiler= IMP start
!*
!***************************************************************************
!* Claim compiler work-space by allocating WorkAd kbytes from memory. *
!***************************************************************************
!*
if monopt#0 then printstring("
claiming workspace at ")
{ Set up Work File }
workad = malloc(workK*1024)
if monopt#0 then phex(workad) and printstring(" of ") and phex(workk*1024)
comreg(14) = workad
Hdr == record(workad)
Hdr = 0
Hdr_datastart = 32
Hdr_filesize = workK*1024
!*
!***************************************************************************
!* Connect source-file. In this case simply open the file for reading. *
!***************************************************************************
!*
ConSource(source,srcad) { grab source file }
selectinput(Srcid)
comreg(1)=Srcsize
comreg(46) = srcad { c46 holds address for Peter }
com23= -1 if noisy= 0
if (com27 & NoList)= 0 orc
(Control & Code )# 0 orc
noisy = 1 thenstart
com23= Stdout
com40= -1 if Diagstream> 0 and Liststream> 0
finish
comreg(40)= com40
comreg(23)= com23
select output (com23)
finish
if Compiler= Fortran start
{--------------------------------------------------------------------------}
{ ********* Analyse Options/Switches specified }
if control&2=0 thenstart {listing requested}
if Liststream< 0 or Diagstream< 0 thenstart
select output (Stdout)
dup output= 1
printvers
print string (source)
newlines (2)
select output (Stderr)
finishelse newline
finish
if gisbuffzone#0 and (cgoptions & cgglobsched#cgglobsched) thenstart
Warning 1 Text="Warning: -gisbuff= option used without -O4 or -O5
"
Output (Warning 1 Text)
finish
if Warning 1 flag# 0 thenstart
i= 1
Warning 1 Text= ""
while Warning 1 Flag# 1 cycle
if Warning 1 Flag & 1# 0 thenstart
Warning 1 Text= "," . Warning 1 Option(i) . Warning 1 Text
finish
i= i + 1
Warning 1 Flag= Warning 1 Flag>> 1
repeat
x= length(Warning 1 Text)
Warning 1 Text= Warning 1 Option(i) . Warning 1 Text
if x# 0 then Warning 1 Text= "s" . Warning 1 Text . " are" c
else Warning 1 Text= Warning 1 Text . " is"
Warning 1 Text= "Warning: Diagnostic option" . Warning 1 Text c
. " overridden by -O
"
Output (Warning 1 Text)
finish {warning about inconsistent options}
if control&code#0 then selectoutput(Stdout)
finish
if Compiler= Fortran Start
bufad = malloc(bufsize+1) { get buffer to read source into }
InitialiseSource
if monopt#0 start
select output (Stdout)
printstring("
FORT77( Control = "); phex(control)
printstring("
options1 = "); phex(options1)
printstring("
options2 = "); phex(options2)
printstring("
F77parm = "); phex(F77parm)
printstring("
Optflags = "); phex(optflags)
printstring("
Comopt3 = "); write(Comopt3,1)
printstring("
recipopt = "); write(recipopt,1)
printstring("
Opt2max = "); write(Opt2max,1)
printstring("
optcontrols = "); phex(optcontrols)
printstring("
misalignedreals = "); write(misalignedreals,1)
printstring("
Srcflags = "); phex(Srcflags)
printstring("
Liststream = "); write(Liststream,1)
printstring("
Console = "); write(2,1)
printstring("
Diagstream = "); write(Diagstream,1)
printstring("
Diagnostic level = "); write(Diagnostic level,1)
printstring("
Dsize = "); write(Dsize,1)
printstring("
Tsize = "); write(Tsize,1)
printstring("
Bsize = "); write(Bsize,1)
printstring("
Lsize = "); write(Lsize,1)
printstring("
Asize = "); write(Asize,1)
printstring("
Nsize = "); write(Nsize,1)
newline
printstring("
cgoptions = "); phex(cgoptions)
newline
finish; !Note currently selected may be either STDOUT or STDERR at this point
finish
Cstring(object,adcstr) { leave object filename in buffer for unlink }
integerfn readn
integer i,c
i = 0
cycle
c = args(vptr+1)
exit unless '0' <= c <= '9'
i = (i*10) + (c-'0')
vptr=vptr+1
repeat
result = i
end {readn}
integerfn readbv
integer i,j,c
i = 0
j = readn
err: unless 0<=j<=31 thenstart
printstring("invalid bit vector
")
result = 0
finish
cycle
i = i ! (1<<j)
c = args(vptr+1)
exit unless c = ':'
vptr=vptr+1
j = readn
unless 0<=j<=31 then -> err
repeat
result = i
end {readbv}
routine readnn(integername val1,val2)
integer i,c
val1 = readn
c = args(vptr+1)
unless c = ':' thenstart
printstring("invalid fragrange
")
val2 = 0
return
finish
vptr=vptr+1
val2 = readn
end {readnn}
end; ! Prepare
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
externalroutine COMPILE alias "main" (integer argc, argv)
routinespec print summary (integer i)
string(1) s
integer i
!
if Compiler= Fortran then recipopt = 0
if Target=RS6000 start
nohsflt=0 {user has not used -qnohsflt yet}
finish
if Host = M88000 then start
integer DiagStopper
DiagStopper = M'ZDIA' { in case of compiler crash! }
finish
!
if Host = M88000 then start
disabletraps { disable all 88k fpu traps }
{ and set rounding mode to nearest }
finish
!
if Target = M88000 then start
cgoptions = cgschedule { default is to enable instr scheduling }
finish
!
if Host=MIPs start
cgoptions = cgschedule { Mips default is to schedule }
finish
Prepare( argc, argv) { to keep stack size down }
if Host=DRS and Usechipfns=Weitek thenstart
if Env=Sequent then Set Weitek Flags
finish
if Compiler= IMP start
IMPCOMPILER
if comreg(24)=0 or comreg(27)=8 start { return code }
FREE(workad)
i= comreg(47) {=> continue to generate the object file}
finishelse i= -1 {=> terminate quickly with a failure }
finishelsestart
i=FORT77(Control,options1,options2,F77parm,Optflags,Srcflags,0,Liststream,
Diagstream,diagnostic level,Dsize,Tsize,Bsize,Lsize,Asize,Nsize)
finish
select output (Stderr)
print summary (i) if Compiler= Fortran or (i> 0 and comreg(40)# -1)
if i>=0 start
if syntaxcheck=0 thenstart
select output (Stdout)
if Emachine>= 4 then Pgenerateobject (s) c
else Mgenerateobject (s)
select output (Stderr)
finish
if Protection=ALF start
freeadilicense
finish
EXIT(0)
finishelsestart
! i = UNLINK(AdCstr)
if Protection=ALF start
freeadilicense
finish
EXIT(1)
finish
if Compiler= Fortran thenstart
routine print summary (integer i)
string(31) s,t
integer n
n= i
n=-n if n< 0
s= "
".itos (n)
if i< 0 then t= " Error" c
else t= " Line"
s= s.t
if i>1 or i<-1 then s= s . "s"
if i>0 thenstart
if syntaxcheck= 0 then t= " Compiled
" else t= " Analyzed
"; finishelse t= "
"; s= s.t
output (s)
end; ! print summary
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish
if Compiler= IMP thenstart
routine print summary (integer i)
string(63) s,t
s= "
".itos (i)
if i= 1 then t= " Statement" c
else t= " Statements"
s= s.t
if syntaxcheck= 0 then t= " Translated to C
" else t= " Analyzed
"; s= s.t
print string (s)
end; ! print summary
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish
end; ! COMPILE
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
if Compiler= Fortran thenstart
externalroutine DeleteObjectFile
integer i
i = UNLINK(AdCstr)
end; ! DeleteObjectFile
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish
if Compiler= Fortran start
!---------------------------------------------------------------------------
!************************* SPACE CLAIMED HERE *****************************
!---------------------------------------------------------------------------
!*
externalroutine F77area(integer Index,Size,integername Address)
conststring(9)array Id(0:6)= c
"T#DICT","T#NAMES","T#TRIADS","T#BLOCKS","T#TABS",
"T#LOOPS","T#BUFFS"
!integer I
! I=malloc(0);! to find current address
! %if I>0 %thenstart;! force alignment to 4K boundary
! %if I&X'FFF'#0 %thenstart
! I=malloc(I&X'FFFFF000'+X'1000'-I)
! %finish
! %finish
Address=malloc(Size)
if mmon#0 start
printstring("
Creating area ")
printstring(Id(Index))
printstring(" size = X")
phex(Size)
finish
if Address>0 thenstart
if mmon#0 start
printstring(" address = X")
phex(Address)
newline
finish
finishelsestart
printstring("Create area response=")
write(Address,1)
newline
stop
finish
end; ! F77area
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
!---------------------------------------------------------------------------
!****************** SOURCE INPUT TO COMPILER *****************************
!---------------------------------------------------------------------------
owninteger id { file descriptor of current source file }
ownbyteintegerarray spacepat(0:71)=' '(72)
owninteger adspaces
owninteger next
owninteger linestart
owninteger left
recordformat incfm(integer parent,next,left,bufad,id)
ownrecord(incfm) name inc
if Bytesreversed=YES thenstart
constinteger EOF = X'00001901'
finishelsestart
constinteger EOF = X'01190000'
finish
routine InitialiseSource
id = PrimarySrcid
adspaces = addr(spacepat(0))
linestart = bufad
left=0
{ left = READ(id,bufad,bufsize) }
{ %if left = 0 %start } { end of file }
{ printstring(" }
{ Source is Empty ") }
{ exit(0) }
{ %finish }
{ %if left<bufsize %then byteinteger(bufad+left)=NL %and left=left+1 }{ make sure all lines terminate }
next = bufad
inc == record(0)
end; ! InitialiseSource
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
externalroutine Closeinc(integer Lwad)
! Force closure of an include file.
! Closeinc is called when an end line has been specified on the
! INCLUDE statement and this has been reached (Gould Fortran-77+)
integer lbad,i,parent
lbad=lwad
integer(lbad) = EOF
CLOSE(id)
free(bufad) { release buffer space }
parent = addr(inc)
if parent#0 start { safety first - should always be true}
next = inc_next { reset vars to parent file }
left = inc_left
bufad = inc_bufad
id = inc_id
i = inc_parent
free(parent) { release include record space }
inc == record(i)
finish
end {Closeinc}
externalroutine SourceLine(integer Lwad,integername long)
integer t,i,linesize,parent,top,lbad
{------------------- Have we run out of data ? ---------------------------}
lbad = lwad
if left <= 0 start { Buffer is empty }
left = READ(id,bufad,bufsize)
if left = 0 start { end of file }
integer(lbad) = EOF
CLOSE(id)
free(bufad) { release buffer space }
parent = addr(inc)
if parent#0 start { if it was an include file }
next = inc_next { reset vars to parent file }
left = inc_left
bufad = inc_bufad
id = inc_id
i = inc_parent
free(parent) { release include record space }
inc == record(i)
finish
return
finish
if left = bufsize start { Have not got endoffile in buffer }
top = bufad+left-1 { backup to end of last complete line }
cycle i = top,-1,bufad { to avoid split lines }
if byteinteger(i)=NL start
left = left - (top-i)
LSEEK(id,i-top,1) { adjust file position back }
exit
finish { to reread incomplete line next time }
repeat
finish elsestart { put an extra NL in case last line incomplete }
if byteinteger(bufad+left-1)#NL then byteinteger(bufad+left) = NL andc
left = left + 1
finish
next = bufad
finish
{ --------------- ch by ch through source ---------------------}
linestart = next
next = next + 1 while byteinteger(next) # NL
{ OR }
! **NLch { search for NL character }
! **next { starting at byte address 'next' }
! **bufsize { stop after 'bufsize characters - always a nl there }
! *PUT_x'FD9E' { swne }
! *DISCARD { get rid of true/false }
! **=next { put address of NL in next }
{--------------- set up LINE buffer -------------------}
long = 0
linesize = next - linestart
left = left - (linesize + 1)
if warnlinelen # 0 thenstart
i = linesize
if byteinteger(lbad+1) = 9 {tab} then i = i + 5
if i > warnlinelen then long = warnlinelen
finish
linesize = 132 if linesize > 132
next = next + 1 { over NL }
if byteinteger(next-2)=13{CR} then linesize=linesize-1 { Lose CR's }
byteinteger(lbad) = linesize { lbad(0) = length }
t = lbad + 1
**linestart; **t; **linesize; *MVB
! %cycle i=0,1,linesize-1
! byteinteger(t+i)=byteinteger(linestart+i)
! %repeat
if linesize < 73 start { insert trailing spaces }
t = lbad + linesize + 1
i = 72 - linesize
**adspaces; **t; **i; *MVB
! %cycle i=0,1,71-linesize
! byteinteger(t+i)=32
! %repeat
finish
end; ! SourceLine
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
externalroutinespec putincname(string(*)name s,
integer j)
externalintegerfn select include(string(255) Incname)
ownbyteintegerarray cstr(0:255)
ownstring(13) usr include text= "/usr/include/"
ownstring(7) INCLUDE text= "include"
integer i,parent,parentid,slen, cstr adr
string(255) s
string(255) Searchpaths1 {writable copy of IncludeDir}
stringname Searchpaths2 {mapped onto the next path in Searchpaths1}
parentid = id
cstr adr = addr(cstr(0))
{ If there is no '/' in the Include file name then look for it in }
{ the directory containing the source , not the current directory }
if charno(Incname,1)= '/' then s= Incname c
else s= IncludeDir . Incname
putincname(s,1)
Cstring(s,cstr adr)
ID = Open(cstr adr,READING)
if ID = -1 start
if charno(Incname,1) = '/' then -> cant open
{ If the Include file name wasnt found, try the directories specified}
{ by the -I option (if any) so long as the Include file name does not}
{ start with a '/' }
if Includepath # "" thenstart
Searchpaths1 = Includepath
Searchpaths2== Searchpaths1
cycle {through all the pathnames specified by -I}
slen= length(Searchpaths2)
cycle i= 1,1,slen {locate terminating '+'}
exit if charno(Searchpaths2,i)= '+'
repeat
length(Searchpaths2)= i - 1
s= Searchpaths2 {= searchpath for Incname}
Searchpaths2== string (addr(Searchpaths2) + i)
length(Searchpaths2)= slen - i {discard current searchpath}
{ from the list }
s = s."/".Incname
Cstring(s,cstr adr)
ID = Open(cstr adr,READING)
if ID >= 0 then -> Include Opened
if Searchpaths2= "" thenexit
repeat
finish
{ If no success from the -I<dir> option, try the current working directory}
Cstring(Incname, cstr adr)
ID = Open(cstr adr,READING)
if ID >= 0 then -> Include Opened
{ If no success from the current working directory, try /usr/include}
s = usr include text . Incname
Cstring(s,cstr adr)
ID = Open(cstr adr,READING)
if ID = -1 then -> cant open
finish
Include Opened:
parent = addr(inc)
i = malloc( 32 {size of inc})
inc == record(i)
inc_bufad = bufad
inc_parent = parent
inc_id = parentid
inc_next = next
inc_left = left
bufad = malloc(bufsize+1) { get buffer to read source into }
left = 0 { trigger READ on next source line request }
if comreg(26)&4#0 {sdb/dbx} thenstart
if Emachine>= 4 then Psetfiles(s,INCLUDE text,0) { for DBX } c
else Msetfiles(s,INCLUDE text,0) { for DBX }
finish
result = 0
cant open: ID = parentid
result = 1
end; ! Select Include
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
externalintegerfn Checknus(stringname s)
integer I,J,C,ad,len
ownbyteintegerarray A(0:31)
!*
if options2&nus=0 then result=0 {no nus option}
if options2&nusfile=0 then result=1 {no underscores}
ad=optfiles_nusaddr
len=optfiles_nuslen
J=0
cycle I=0,1,Len-1
C=byteinteger(Ad+I)
{printstring("Char:");write(C,1);newline}
if C<=' ' or C=',' thenstart {valid separators?}
if J>0 thenstart
A(0)=J
if s=string(addr(A(0))) then result=1
J=0
finish
finishelsestart
if 'A'<=C<='Z' then C=C-'A'+'a'
if J<31 thenstart
J=J+1
A(J)=C
finish
finish
repeat
A(0)=J
if s=string(addr(A(0))) then result=1
result=0
end; ! Checknus
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish
if Target=M88000 start
externalintegerfn Nusoption
if options2&nus=0 then result=0
result=1
end; ! Nusoption
finish
!
! Copyright (c) 1991 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
if Compiler= Fortran thenstart
externalroutine x alias "pow_ri"
end
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!
finish
endoffile
!
! Copyright (c) 1987 Edinburgh Portable Compilers Ltd. All Rights Reserved.
!