%conststring(50) reldate = " Imp version 8/aug/87 " { 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} { 5/August/87 Pass profile option to code generator in comreg(1) mf16i} %CONSTSTRING (100) F77version = %c "Gould Common Fortran UTX/32 Release 1.0 (15 Sept 86) " %constinteger pnx=0 %constinteger Gould=1 %constinteger host = Gould %constinteger Imp = 1, Fortran = 0 %constinteger Language =Imp %if host=pnx %thenstart %constinteger BSCALE=2 %finishelsestart %constinteger BSCALE=1 %finish %externalroutinespec Mmonon %externalroutinespec Emonon %externalroutinespec Mcodeon %externalroutinespec Set Sigs %externalroutinespec Phex(%integer n) %externalroutinespec Mgenerate Object(%stringname s) %externalroutinespec Msetfiles(%string(255) %name src,obj,%integer syntax) %if Language = Fortran %Start %externalintegerfnspec FORT77(%integer Control,options1,options2, F77parm,optflags,srcflags, Console,Liststream,Diagstream, Diagnostic level,Dsize,Tsize, Bsize,Lsize,Asize,sp2) %recordformat Optfilesfmt(%integer inaddr,inlen,exaddr,exlen) %externalrecord(Optfilesfmt) Optfiles %finishelsestart %externalroutinespec ICL9CEZGOULDIMP %finish %externalintegerfnspec Fstat(%integer filedes,bufad) %externalstring(15) %fnspec Itos(%integer n) %externalroutinespec Mfaulty %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(%integer bytesize) { C Library } %externalroutinespec Free(%integer bytead) { C Library } %externalroutinespec Cstring(%string(*) %name Impstr, %integer adCstr) %externalintegerfnspec IsaTTY(%integer id) {C library call} %if host= pnx %thenstart %externalroutinespec reversebytes(%integer ad,len) %finish %if language = IMP %Start %recordformat EmasFileHeaderformat(%integer dataend, datastart, filesize, filetype, sum, datetime, lda, ofm) %finish %recordformat file information table(%shortinteger device number, %integer inode, %shortinteger filemode, nlinks, userid, groupid, rdevnum,dummy, %integer filesize, datelastread, datelastwrite, datelastupdate,a,b,c,d,e,f,g,h) %constinteger READING = 0 %constinteger bufsize=4096 %owninteger bufad %owninteger PrimarySrcID %routinespec InitialiseSource %owninteger syntaxcheck=0 %owninteger monopt = 0 %owninteger srclink=0 %owninteger workad %externalintegermap Comreg(%integer n) %ownintegerarray C(0:50) %result == C(n) %end %constinteger NullStream = -1, Stdin = 0, Stdout = 1, Stderr = 2 %constinteger Version = 1, Release = 0, Fortran77 = 2 %constinteger active = x'80000000', { Possible values of F77PARM} 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', Vax = 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' { FORT77 flags } %owninteger F77parm = active!vax!unix!nounass!noarg!nochar!nobound, control = NoList, options2 = 0, options1 = 0, srcflags = 0, optflags = 0 %owninteger Liststream = Stdout %owninteger Diagstream = Stderr %owninteger Diagnostic level = -1 { no diagnostics is default } %owninteger dup output= 0 {set to 1 if info on Stdout is to be reproduced on Stderr} %owninteger mmon = 0 %ownbyteintegerarray Cstr(0:255) %owninteger adCstr %owninteger dsize = 0, tsize = 0, lsize = 0, bsize = 0, asize %if Language = Imp %start %externalroutine consource(%string(255) filename, %integername filead) %byteintegerarray Cstr(0:255) %integer adCstr,srcid,i,srcsize %record(Emasfileheaderformat) %name Hdr %record(file information table) fid %constinteger READMODE = 0 adcstr = addr(cstr(0)) Cstring(filename,adcstr) { Get source filename in C format} SrcID = Open(adcstr,readmode) { Open source file} %if srcid=3 %then srcid=open(adcstr,readmode) { just till objgen going } %if srcid=-1 %then printstring(" Cannot open source file ") %and ->crunch i = Fstat(srcid,addr(fid)) { Request info. about source} srcsize = fid_filesize { Find out its size} %if i=0 %start { If ok so far} filead = malloc(srcsize+32) { Grab global space for source } %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)+32,srcsize) { Read source file into global } 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 } printstring(" source at ");write(filead,0);newline %return crunch: printstring(filename) %stop %end %finish %externalroutine FreeSourceAreas { ccalled on completion of p1 } %if Language = Imp %start %cycle FREE(srclink) srclink = integer(srclink+28) %repeat %until srclink=0 %finish %end %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 %routine Prepare (%integer argc, argv) { params from C. Parameter argc is the number of parameters. } { parameter argv is the address of C strings. } { IE. In this row of bytes the parameters are each terminated } { by a zero byte. } %ownbyteintegerarrayformat argfm(1:1000) %ownbyteintegerarrayname args %ownintegerarrayformat argptrfm(1:100) %ownintegerarrayname argptr %integer argument %integer i,vptr,c,size,type,ID,filead %string(254) source,s,object,root %integer table %integer setsigs flag {set to 1 if signal traps are to be set} %record(file information table) fid %owninteger com27 = x'01080000' { 2 on end is nolist } %if Language = imp %Start %record(Emasfileheaderformat) %name Hdr %owninteger workK = 256 %owninteger scan = 0 %finish %owninteger srcad,srcsize %ownstring(66) Warning Text 1= " Warning: Diagnostic options -d, -C, -g are overridden by -O " %owninteger Pflag = 0 { options for Put interface } comreg(28) = 0 comreg(1)=0 %if language=imp %then selectoutput(-1) argptr == array(argv,argptrfm) argument = 1 adcstr = addr(Cstr(0))*BSCALE size = 0 !setsigs flag= 0 {=> dont set signals} setsigs flag= 1 {=> set signals after processing any options/switches} {---------------------------------------------------------------------------} { *********** Options following - are second parameter } { Standard UNIX single letter options } %cycle args == array(argptr(argument+1)//bscale,argfm) %if args(1)='-' %start argument = argument+1 vptr = 2 { discard '-' } %cycle c = args(vptr) %exit %if c = 0 %ifc c = '1' %thenc { ONETRIP every DO loop to exec at least once } F77parm = F77parm!onetrip %elseifc c = 'C' %thenc { array bound checks on } F77parm = (F77parm!minbound)&(\nochar) %elseifc c = 'g' %start { SDB flag } F77parm = F77parm!sdb comreg(26) = comreg(26)!4 { tell PUT } %finish %elseifc c = 'G' %start {Listing reqd} Control = Control&(\NoList) %if language=IMP %then selectoutput(stdout) c = args(vptr+1) %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 %finish %finishelseifc c = 'u' %thenc { type=undef } F77parm = F77parm!x'4000' %elseifc c = 'w' %start { suppress warnings and comments} %if args(vptr+1)='7' %start { suppress F77 warnings } F77parm = F77parm!Nowarn77 vptr=vptr+2 { pass over '77' } %finishelse F77parm = F77parm!nowarnings!nocomments!Nowarn77 %finishelseifc c = 'y' %start { syntax check} Options1 = Options1!NoCode syntaxcheck=1 %finishelseifc c = 'p' %thenc { generate profile information } Options2 = Options2 ! profile %and comreg(1)=1 %elseifc c = 'S' %start { code listing } Control = Control!code %if language=Imp %then com27=com27!x'4000' %andc Mcodeon %finishelseifc c = 'a' %thenc { xref listing } Control = Control!xref!attr %elseifc c = 'v' %thenc { unassigned checking on } F77parm = F77parm&(\(nounass!noarg)) %elseifc c = 'O' %start { optimisation } %if Language = imp %start com27 = com27!x'10000' %finishelsestart %if args(vptr+1)='X' %start { default case - just -O } options1=options1!opt2!opt1 %finishelsestart %cycle vptr=vptr+1 c=args(vptr) %exit %if c='X' %if c='1' %then Options1=Options1!opt1 %if c='2' %then Options1=Options1!opt2 %repeat %finish %finish %finishelseifc c = 'D' %start { Conditional compilation markers } 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 %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 = 'V' %start { NP1 Vectorise } Options2 = Options2 ! Vectorise %finishelseifc c = 'W' %start { File of routine names } { for Optimiser } %if language=fortran %start vptr = vptr +1 { get over 'O' } type = args(vptr) vptr = vptr + 2 { get over type and comma } 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 printstring(" Failed to open Optimiser -W file ") newline exit(1) %finish i = FSTAT(ID,addr(FID)) size = Fid_filesize filead = malloc(size) i = READ(ID,filead,size) %if i<0 %start printstring(" Failed to read Optimiser -W file ") newline exit(1) %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' %start { set default integer size } vptr = vptr + 1 c = args(vptr) %if c = '2' %then F77Parm = F77Parm!I2 %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 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 = 'a' %then asize = i %finishelseifc c = 'd' %start { Diagnostics } i = 0 %cycle c = args(vptr+1) %exit %unless '0' <= c <= '9' i = (i*10) + (c - '0') vptr = vptr+1 %repeat Diagnostic level = I %finish not implemented: vptr = vptr+1 %repeat %finish %else %exit %repeat 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 Language = Imp %Start selectoutput(StDerr) printstring(source) newline %if control&nolist#0 %then selectoutput(-1) %else selectoutput(1) printstring("Source: ".source." Parms set: ") %finish {----------------------------------------------------------------------------} { ******** Fourth parameter is -P text used for private verbose options } s = "" %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 %if Language = Imp %start printstring("Defaults") %and %exit %if s="(NULL)" %if s#"" %then printstring(s) %and printstring(",") %if s = "LIST" %then Com27 = Com27&x'FFFFFFFD' %elseifc s = "CODE" %then Com27 = Com27!x'4000' %andc Mcodeon %elseifc { s = "DIAG" %then Diagstream = 2 {Stderr}{ %elseifc } s = "OPT" %then com27 = com27!x'10000' %elseifc s = "FIXED" %then com27 = com27&x'FFF7FFFF' %elseifc s = "PROFILE" %then com27 = com27!x'80' %elseifc s = "NOTRACE" %then com27 = com27!x'40' %elseifc s = "NOLINE" %then com27 = com27!x'00800000' %elseifc s = "NODIAG" %then com27 = com27!4 %elseifc s = "NOARRAY" %then com27 = com27!x'20' %elseifc s = "NOCHECK" %then com27=com27!x'10' %elseifc s = "PARMY" %then com27=com27!x'8000000' %elseifc s = "PARMZ" %then com27 = com27!x'4000000' %elseifc s = "MAXDICT" %then comreg(28) = comreg(28)!x'100' %andc workK = 513 %finish %if s = "SCAN" %then Mfaulty %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 = "PMON" %orc s = "P" %then Mmonon %elseifc s = "EMON" %orc s = "E" %then Emonon %if Language = Fortran %start %exit %if s="(NULL)" { no long options } %if s = "LIST" %then Control = Control&(\NoList) %elseifc s = "XREF" %then Control = Control!xref %elseifc s = "OPT" %then control = control!x'10000' %elseifc s = "CODE" %then Control = Control!code %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 = "MALLOCMON" %then comreg(26)=comreg(26)!128 %and mmon=1 %elseifc s = "OPTRIADS" %then F77parm = F77parm!optriads %elseifc s = "TRIADS" %then F77parm = F77parm!triads %elseifc s = "MAPS" %then F77parm = F77parm!maps %elseifc s = "STRICT" %then F77parm = F77parm!strict %elseifc s = "NOWARNLEN" %then F77parm = F77parm!NOWarnlen %elseifc s = "NOWARNINGS" %then F77parm = F77parm!nowarnings %elseifc s = "NOCOMMENTS" %then F77parm = F77parm!nocomments %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&(\vax) %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 = "FULLBOUND" %then F77parm = F77parm & (\(nobound!minbound)) %elseifc s = "LISTNONE" %then Options1 = Options1!listnone %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 language=Fortran %start %if s = "SF" %or s="OF" %or s="LIM" %start i = 0 %cycle c = args(vptr+1) %exit %unless '0' <= c <= '9' i = (i*10) + (c - '0') vptr = vptr+1 %repeat %if s="SF" %then srcflags = i %if s="OF" %then optflags=i %if s="LIM" %then options2=options2!(i<<16) s="" %finish %finish vptr = vptr+1 %repeat NOFOURTHPARAM: !check if signal traps are to be set (for diagnostics} ! Set Sigs %unless setsigs flag= 0 {--------------------------------------------------------------------------} { ********* Analyse Streams specified } %if Language=Fortran %Start select output (stderr); !All status messages to go to STDERR printstring(source) newline %finish s = source i=i+1 %while s ->("/").s %if length(s)>14 %start print string ("Error: File name longer than 14 characters ") print string ( s ) newline EXIT(1) %finish comreg(27) = com27 length(s) = length(s)-1 { discard 'f' } object=s."o" %if Language = Imp %Start printstring(" Object: ".object) %finish Msetfiles(source,object,0) { Inform Put of source and object} Cstring(source,adcstr) %if host=pnx %then reversebytes(addr(Cstr(0)),length(source)+1) primarySrcID = Open(adcstr,0 {reading}) %if primarySrcID<0 %then printstring(" Failed to open Sourcefile - ".source) %and newline %and Exit(1) { If list or diag stream is not tied to console: , tell compiler } { with a negative number. Otherwise set positive } %if IsaTTY(Stdout)#1 %then Liststream = - Stdout %if IsaTTY(Stderr)#1 %then Diagstream = - Stderr { Set up Work File } i = malloc(0) %if i&x'fff'#0 %then i=malloc(4096-((i&x'fff')+20)) { align data top } %if Language = Imp %start %if monopt#0 %then printstring(" claiming workspace at ") 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 consource(source,srcad) { grab source file } comreg(46) = srcad { c46 holds address for Peter } %if control&nolist=0 %then comreg(23) = StDout %else comreg(23) = -1 %if control&nolist=0 %and Diagstream>0 %and Liststream>0 %thenc comreg(40) = -1 %else comreg(40) = Stderr %finish {--------------------------------------------------------------------------} { ********* Analyse Options/Switches specified } %if control&2=0 %thenstart {listing requested} select output (Stdout) %if Liststream< 0 %or Diagstream< 0 %thenstart print string (source) newline dup output= 1 %finish %if language=Fortran %start printstring(F77version) newline select output (Stderr) %finish %finish %if options1&opt3 # 0 %andc { Optimising forbidden} ( Diagnostic level # -1 %orc { with Diagnostics } F77parm&(nounass!noarg) = 0 %orc { or Unassigned } F77parm&minbound # 0 %orc { or bound checks } F77parm&sdb # 0 ) %start { or SDB } Output (Warning Text 1) { and undo any damage } F77parm = (F77parm & ( \(minbound!sdb)) ! Nochar ! nounass ! noarg ) Diagnostic Level = -1 %finish i = malloc(0) %if i&x'fff'#0 %then i=malloc(4096-((i&x'fff')+20)) { align data top } %if Language=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(" 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) newline %finish; !Note currently selected may be either STDOUT or STDERR at this point Cstring(object,adcstr) { leave object filename in buffer for unlink } %if host=pnx %then reversebytes(addr(Cstr(0)),length(object)+1) %finish %end %externalroutine COMPILE %alias "main" (%integer argc, argv) %externalroutinespec initaux(%integer Nkb) %routinespec print summary (%integer i) %string(1) s %integer i initaux(128) prepare( argc, argv) { to keep stack size down } %if Language = Imp %start ICL9CEZGOULDIMP %if comreg(24)=0 %or comreg(27)=8 %start { return code } FREE(workad) Mgenerateobject(s) %if control&nolist#0 %start selectoutput(StdErr) write(comreg(47),1) printstring(" Statements Compiled ") %finish EXIT(0) %finishelse EXIT(1) %finishelsestart i=fort77(Control,options1,options2,F77parm,Optflags,Srcflags,2,Liststream, Diagstream,diagnostic level,Dsize,Tsize,Bsize,Lsize,Asize,0) select output (Stderr) print summary (i) %if i>=0 %start %if syntaxcheck=0 %then Mgenerateobject (s) EXIT(0) %finishelsestart i = UNLINK(AdCstr) EXIT(1) %finish %finish %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= " Analysed "; %finishelse t= " "; s= s.t output (s) %end %end %externalroutine DeleteObjectFile %integer i i = UNLINK(AdCstr) %end %if Language = 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 %if host=PNX %thenstart Address=Address>>1 %finish %end;! F77area !--------------------------------------------------------------------------- !****************** 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 host= pnx %thenstart %constinteger EOF= X'19010000' %finishelsestart %constinteger EOF = x'01190000' %finish %routine InitialiseSource id = PrimarySrcid adspaces = addr(spacepat(0))*BSCALE 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 80 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 %externalintegerfn select include(%string(255) incname) %ownbyteintegerarray cstr(0:255) %integer i,parent,j,parentid parentid = id Cstring(Incname,addr(cstr(0))) %if host=pnx %then reversebytes(addr(cstr(0)),length(Incname)+1) ID = Open(addr(cstr(0)),reading) %if ID = -1 %start ID = parentid %result = 1 %finish parent = addr(inc) i = 32 {sizeof(inc) } j = malloc(i) inc == record(j//BSCALE) 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 %then Msetfiles(incname,"include",0) { for DBX } %result = 0 %end %finish %externalroutine x %alias "pow_ri" %end %if language=IMP %start %externalroutine poweroften %end %finish %endoffile