! version for ELFPUT in C %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." !* $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 %externalroutinespec Set Sigs %alias "f_setsigs" %externalroutinespec Phex(%integer n) %externalroutinespec Pgenerate Object(%stringname s) %externalroutinespec Psetfiles(%integer srcad,objad,%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 %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" %finish %else %iF Target=DRS %or Target=PENTIUM %start %externalroutinespec IMPCOMPILER %alias "icl9cezdrsimp" %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 Malloc%alias "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', Onetrip = x'00000800', F77 = x'00000400', Vaxflag = x'00000200', Unix = x'00000100', Strict = x'00000080', No Warnings = x'00000040', No Comments = x'00000020', NoBound = x'00000010', 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', Profile = x'00000020', Noerrors = x'00000040', Vectorise = x'00000080', Inclusions = x'00000100', Exclusions = x'00000200', UseFarData = x'00000400', Nounderscore = x'00000800', nodepcheck = x'00001000', fuseall = x'00002000', nofuse = x'00004000', fuselist = x'00008000', bslashnatural = x'00010000', optionalargs = x'00020000', freeformat = x'00040000', sroption = x'00080000', seoption = x'00100000', 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' , 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' , 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 Target=RS6000 %start %owninteger nohsflt {set to 1 if user specifies -qnohsflt} %finish %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} %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 = 256 %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 ! printstring("args"); space; printsymbol(args(vptr+1)); ! printsymbol(args(vptr+2)); printsymbol(args(vptr+3)); newline %if Target=RS6000 %start %if args(vptr+1)='p' %and args(vptr+2)='p' %andc args(vptr+3)='c' %start TargetVariant=6 {POWER} vptr=vptr+3 %finish %else %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, (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) %finishelseifc 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 %elsec %if table = 't' %then tsize = i %elsec %if table = 'l' %then lsize = i %elsec %if table = 'b' %then bsize = i %elsec %if table = 'x' %then nsize = i %elsec %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 = 1023 %if workK<1023 %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 com27 = com27&(\NoList) %elseifc 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 %finish %elseifc s = "OPT" %then com27 = com27!opt %elseifc s = "MAP" %then com27 = com27!iMap %elseifc s = "FIXED" %then com27 = com27&(\iFree) %elseifc s = "PROFILE" %then com27 = com27!iProfile %elseifc s = "NOTRACE" %then com27 = com27!NoTrace %elseifc s = "NOLINE" %then com27 = com27!NoLine %elseifc s = "NOCHECK" %then com27 = com27!NoCheck %elseifc s = "MIPS2" %then TargetVariant=5{R4000} %elseifc s = "PPRO" %then TargetVariant=7 { Pro variant} %elseifc s = "PPRO2" %then TargetVariant=8 { Use P6 instr set} %elseifc s = "PPROONLY" %then TargetVariant=8 { Use P6 instr set} %elseifc s = "CHECK" %then com27 = com27&(\Nocheck) %elseifc s = "NODIAG" %then com27 = com27!NoDiag %elseifc s = "NOARRAY" %then com27 = com27!NoArray %elseifc s = "ARRAY" %then com27 = com27&(\NoArray) %elseifc s = "PARMX" %then com27 = com27!parmx %elseifc s = "PARMY" %then com27 = com27!parmy %elseifc s = "PARMZ" %then com27 = com27!parmz %elseifc s = "QUOTES" %then com27 = com27!quotes %elseifc s = "LINE" %then com27 = com27&(\NoLine) %elseifc s = "MINWORK" %then com28 = com28&x'FFFFFEFF' %c %and workK = 128 %elseifc s = "BIGWORK" %then workK = 512 %elseifc s = "MAXWORK" %then %start workK = 1023 %if workK<1023 %finish %elseifc s = "MAXDICT" %then com28 = com28!x'100' %elseifc Host= Sun3 %andc s = "REGSAV" %then SaveRegs= 1 %elsec { none of these } invalid=invalid+1 %finish %if s = "SCAN" %thenstart %if Emachine>= 4 %then Pfaulty %c %else Mfaulty Options1 = Options1!NoCode syntaxcheck= 1 %finish %elseifc s = "VERSION" %then printstring(reldate) %elseifc s = "OPTIONS" %then monopt = 1 %elseifc s = "SET" %then setsigs flag= 1 %elseifc s = "UNSET" %then setsigs flag= 0 %elseifc s = "FILEMON" %orc s = "FMON" %then com26= com26!16 %elseifc s = "MALLOCMON" %then com26= com26!128 %c %and mmon=1 %elseifc 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 = Fortran %start %if s = "LIST" %then Control = Control&(\NoList) %elseifc s = "XREF" %then Control = Control!xref %elseifc s = "OPT" %then control = control!opt %elseifc s = "CODE" %thenstart %if Host# Sun3 %or Env= GOULD %thenstart %if Emachine>= 4 %then Mcodeon %c %else Pcodeon %finishelse control= control ! code %finish %elseifc s = "ATTR" %then Control = Control!attr %elseifc s = "QUOTES" %then Control = Control!1 %elseifc s = "D1" %then options1=options1!x'10000' %elseifc s = "D2" %then options1=options1!x'20000' %elseifc s = "D3" %then options1=options1!x'30000' %elseifc s = "D4" %then options1=options1!x'40000' %elseifc { s = "NOUND" %then options2=options2!Nounderscore %elseifc } s = "DEPANAL" %then F77parm = F77parm!depanal %elseifc s = "NODEPCHECK" %then options2=options2!nodepcheck %elseifc s = "NOFUSE" %then options2=options2!nofuse %elseifc s = "FUSEALL" %then options2=options2!fuseall %elseifc s = "FUSELIST" %then options2=options2!fuselist %elseifc s = "OV" %then options2=options2!optimisevector %elseifc s = "DIV" %then hardoptions=hardoptions!divset %elseifc s = "NEWBR" %then hardoptions=hardoptions!newbr %elseifc s = "PROF" %thenstart %if Host# Sun3 %or Env= GOULD %then lineprofile=1 %finish %elseifc s = "OPTRIADS" %then F77parm = F77parm!Optriads %elseifc s = "TRIADS" %then F77parm = F77parm!Triads %elseifc s = "MAPS" %then F77parm = F77parm!Maps %elseifc s = "MISALIGN" %then misalignedreals= 1 %elseifc s = "STRICT" %then F77parm = F77parm!Strict %elseifc s = "NOWARNLEN" %then F77parm = F77parm!NoWarnlen %elseifc s = "NOWARNINGS" %then F77parm = F77parm!No Warnings %elseifc s = "NOCOMMENTS" %then F77parm = F77parm!No Comments %elseifc s = "NOBOUND" %then F77parm = F77parm!NoBound %elseifc s = "MINBOUND" %then F77parm = F77parm!MinBound %elseifc s = "NOUNASS" %then F77parm = F77parm!NoUnass %elseifc s = "NOARG" %then F77parm = F77parm!Noarg %elseifc s = "NOCHAR" %then F77parm = F77parm!NoChar %elseifc s = "NOWARN77" %then F77parm = F77parm!NoWarn77 %elseifc s = "F77" %then F77parm = F77parm!F77 %elseifc s = "NOVAX" %then F77parm = F77parm&(\Vaxflag) %elseifc s = "NOUNIX" %then F77parm = F77parm&(\Unix) %elseifc s = "OPT1" %then Options1 = Options1!opt1 %elseifc s = "OPT2" %then Options1 = Options1!opt2 %elseifc s = "OPT3" %then Options1 = Options1!opt3 %elseifc s = "OPTEXT" %then Options1 = Options1!optext %elseifc s = "NOFREG" %then Comopt3 = 0 %elseifc s = "LIMIT1" %then optcontrols=optcontrols!1 %elseifc s = "LIMIT2" %then optcontrols=optcontrols!2 %elseifc s = "LIMIT4" %then optcontrols=optcontrols!4 %elseifc s = "LIMIT8" %then optcontrols=optcontrols!8 %elseifc s = "LIMIT16" %then optcontrols=optcontrols!16 %elseifc s = "NOUNROLL" %then optcontrols=optcontrols!16 %elseifc s = "NONUMCHUNKS" %thenstart %if Allowparallel# 0 %thenstart Paralleloptions=Paralleloptions!1 %finish %finish %elseifc s = "PT0" %then Timeprofiler=3 %elseifc s = "PTS" %then Timeprofiler=4 %elseifc s = "PTP" %then Timeprofiler=5 %elseifc s = "FULLBOUND" %then F77parm = F77parm & (\(NoBound!MinBound)) %elseifc s = "CTRIADS" %then ctriads=1 %elseifc s = "MOO" %then G2traceMOO=1 %elseifc s = "LISTNONE" %then Options1 = Options1!listnone %elsec { none of these } invalid=invalid+1 %finish %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 ! NoTrace%c %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 %begin %integer ad1,ad2 %ownintegerarray cspace(0:511) ad1=addr(cspace(0)); ad2=addr(cspace(256)) Cstring(Source,ad1); Cstring(Object,ad2) Psetfiles(ad1,ad2,syntaxcheck) { Inform Put of source and object} %end %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< 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(31) s,t s= " ".itos (i) %if i= 1 %then t= " Statement" %c %else t= " Statements" s= s.t %if syntaxcheck= 0 %then t= " Compiled " %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 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 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. !