{****************************************************************************} { } { System dependent routines. } { } {****************************************************************************} %externalstring(255)%fnspec uinfs %alias "S#UINFS"(%integer n) %EXTERNAL %ROUTINE %SPEC Define %ALIAS "S#DEFINE"(%INTEGER channel, %STRING (255) File, %INTEGER %NAME Afd,Flag) %externalintegerfnspec IOCP %alias "S#IOCP"(%integer ep,adr) %EXTERNAL %INTEGER %MAP %SPEC ComReg %ALIAS "S#COMREGMAP"(%INTEGER N) %EXTERNAL %ROUTINE %SPEC ICLpascalcompiler %ROUTINE %SPEC InitialiseCompiler %EXTERNAL %ROUTINE %SPEC EMAS3ClaimChannel(%INTEGER %NAME Chan) %EXTERNAL %ROUTINE %SPEC Eproc %alias "E#PROC" (%STRING %NAME Name, %INTEGER Prop,Numpars, Paramsize,Astacklen, %INTEGER %NAME Id) %EXTERNAL %ROUTINE %SPEC Eentry%alias "E#ENTRY" (%INTEGER Index,Numpars,ParamSize,LocalSize, DiagDisp, %STRING %NAME Name) %EXTERNAL %INTEGER %FN %SPEC Exname %alias "E#XNAME" (%INTEGER Type, %STRING %NAME Xref) %EXTERNAL %ROUTINE %SPEC Edataentry %alias "E#DATAENTRY" (%INTEGER Area,Offset,Length, %STRING %NAME Name) %EXTERNAL %ROUTINE %SPEC Edataref %alias "E#DATAREF" (%INTEGER Area,Offset,Length, %STRING %NAME Name) %EXTERNAL %INTEGER %FN %SPEC existtype %ALIAS "S#EXISTTYPE"(%STRING (255) file) ! from ibm assembler which claims to evaluate exactly and round to 128 bits %CONSTLONGLONGREALARRAY POWERS (-78:75)= %C {Ten to the -78} R'001DA48CE468E7C772026520247D3556' , {Ten to the -77} R'011286D80EC190DC73617F3416CE4156' , {Ten to the -76} R'01B94470938FA89B73CEF808E40E8D5B' , {Ten to the -75} R'0273CAC65C39C96174615B058E891859' , {Ten to the -74} R'03485EBBF9A41DDC75DCD8E37915AF38' , {Ten to the -73} R'042D3B357C0692AA760A078E2BAD8D83' , {Ten to the -72} R'051C45016D841BAA774644B8DB4C7872' , {Ten to the -71} R'0611AB20E472914A786BEAF3890FCB47' , {Ten to the -70} R'06B0AF48EC79ACE878372D835A9DF0C7' , {Ten to the -69} R'076E6D8D93CC0C1179227C7218A2B67C' , {Ten to the -68} R'084504787C5F878A7AB58DC74F65B20E' , {Ten to the -67} R'092B22CB4DBBB4B67BB1789C919F8F49' , {Ten to the -66} R'0A1AF5BF109550F27C2EEB61DB03B98D' , {Ten to the -65} R'0B10D9976A5D52977D5D531D28E253F8' , {Ten to the -64} R'0BA87FEA27A539E97DA53F2398D747B3' , {Ten to the -63} R'0C694FF258C744327E0747763F868CD0' , {Ten to the -62} R'0D41D1F7777C8A9F7F448CA9E7B41802' , {Ten to the -61} R'0E29233AAAADD6A3008AD7EA30D08F01' , {Ten to the -60} R'0F19B604AAACA6260136C6F25E825961' , {Ten to the -59} R'101011C2EAABE7D702E23C577B1177DD' , {Ten to the -58} R'10A0B19D2AB70E6E02D65B6ACEAEAE9D' , {Ten to the -57} R'11646F023AB269050345F922C12D2D22' , {Ten to the -56} R'123EC56164AF81A3044BBBB5B8BC3C35' , {Ten to the -55} R'13273B5CDEEDB106050F55519375A5A1' , {Ten to the -54} R'1418851A0B548EA306C99552FC298785' , {Ten to the -53} R'14F53304714D926506DFD53DD99F4B30' , {Ten to the -52} R'15993FE2C6D07B7F07ABE546A8038EFE' , {Ten to the -51} R'165FC7EDBC424D2F08CB6F4C2902395F' , {Ten to the -50} R'173BDCF495A9703D09DF258F99A163DB' , {Ten to the -49} R'18256A18DD89E6260AAB7779C004DE69' , {Ten to the -48} R'1917624F8A762FD80B2B2AAC18030B02' , {Ten to the -47} R'19E9D71B689DDE710BAFAAB8F01E6E11' , {Ten to the -46} R'1A9226712162AB070C0DCAB3961304CA' , {Ten to the -45} R'1B5B5806B4DDAAE40D689EB03DCBE2FF' , {Ten to the -44} R'1C391704310A8ACE0EC1632E269F6DDF' , {Ten to the -43} R'1D23AE629EA696C10F38DDFCD823A4AB' , {Ten to the -42} R'1E164CFDA3281E3810C38ABE071646EB' , {Ten to the -41} R'1EDF01E85F912E3710A36B6C46DEC52F' , {Ten to the -40} R'1F8B61313BBABCE211C62323AC4B3B3E' , {Ten to the -39} R'20571CBEC554B60D12BBD5F64BAF0507' , {Ten to the -38} R'213671F73B54F1C8139565B9EF4D6324' , {Ten to the -37} R'2222073A8515171D145D5F9435905DF7' , {Ten to the -36} R'23154484932D2E72155A5BBCA17A3ABA' , {Ten to the -35} R'23D4AD2DBFC3D0771587955E4EC64B45' , {Ten to the -34} R'2484EC3C97DA624A16B4BD5AF13BEF0B' , {Ten to the -33} R'255313A5DEE87D6E17B0F658D6C57567' , {Ten to the -32} R'2633EC47AB514E65182E99F7863B6960' , {Ten to the -31} R'272073ACCB12D0FF193D203AB3E521DC' , {Ten to the -30} R'2814484BFEEBC29F1A863424B06F352A' , {Ten to the -29} R'28CAD2F7F5359A3B1A3E096EE45813A0' , {Ten to the -28} R'297EC3DAF94180651B06C5E54EB70C44' , {Ten to the -27} R'2A4F3A68DBC8F03F1C243BAF513267AB' , {Ten to the -26} R'2B318481895D96271D76A54D92BF80CB' , {Ten to the -25} R'2C1EF2D0F5DA7DD81EAA27507BB7B07F' , {Ten to the -24} R'2D1357C299A88EA71F6A58924D52CE4F' , {Ten to the -23} R'2DC16D9A0095928A1F2775B7053C0F18' , {Ten to the -22} R'2E78E480405D7B962058A9926345896F' , {Ten to the -21} R'2F4B8ED0283A6D3D21F769FB7E0B75E5' , {Ten to the -20} R'302F39421924844622BAA23D2EC729AF' , {Ten to the -19} R'311D83C94FB6D2AC2334A5663D3C7A0E' , {Ten to the -18} R'3212725DD1D243AB24A0E75FE645CC48' , {Ten to the -17} R'32B877AA3236A4B4244909BEFEB9FAD5' , {Ten to the -16} R'33734ACA5F6226F025ADA6175F343CC5' , {Ten to the -15} R'34480EBE7B9D5856266C87CE9B80A5FB' , {Ten to the -14} R'352D09370D4257362703D4E1213067BD' , {Ten to the -13} R'361C25C26849768128C2650CB4BE40D6' , {Ten to the -12} R'37119799812DEA1129197F27F0F6E886' , {Ten to the -11} R'37AFEBFF0BCB24AA29FEF78F69A5153A' , {Ten to the -10} R'386DF37F675EF6EA2ADF5AB9A2072D44' , {Ten to the -9} R'3944B82FA09B5A522BCB98B405447C4B' , {Ten to the -8} R'3A2AF31DC46118732CBF3F70834ACDAF' , {Ten to the -7} R'3B1AD7F29ABCAF482D5787A6520EC08D' , {Ten to the -6} R'3C10C6F7A0B5ED8D2E36B4C7F3493858' , {Ten to the -5} R'3CA7C5AC471B47842E230FCF80DC3372' , {Ten to the -4} R'3D68DB8BAC710CB22F95E9E1B089A027' , {Ten to the -3} R'3E4189374BC6A7EF309DB22D0E560419' , {Ten to the -2} R'3F28F5C28F5C28F531C28F5C28F5C28F' , {Ten to the -1} R'4019999999999999329999999999999A' , {Ten to the 0} R'41100000000000003300000000000000' , {Ten to the 1} R'41A00000000000003300000000000000' , {Ten to the 2} R'42640000000000003400000000000000' , {Ten to the 3} R'433E8000000000003500000000000000' , {Ten to the 4} R'44271000000000003600000000000000' , {Ten to the 5} R'45186A00000000003700000000000000' , {Ten to the 6} R'45F42400000000003700000000000000' , {Ten to the 7} R'46989680000000003800000000000000' , {Ten to the 8} R'475F5E10000000003900000000000000' , {Ten to the 9} R'483B9ACA000000003A00000000000000' , {Ten to the 10} R'492540BE400000003B00000000000000' , {Ten to the 11} R'4A174876E80000003C00000000000000' , {Ten to the 12} R'4AE8D4A5100000003C00000000000000' , {Ten to the 13} R'4B9184E72A0000003D00000000000000' , {Ten to the 14} R'4C5AF3107A4000003E00000000000000' , {Ten to the 15} R'4D38D7EA4C6800003F00000000000000' , {Ten to the 16} R'4E2386F26FC100004000000000000000' , {Ten to the 17} R'4F16345785D8A0004100000000000000' , {Ten to the 18} R'4FDE0B6B3A7640004100000000000000' , {Ten to the 19} R'508AC7230489E8004200000000000000' , {Ten to the 20} R'5156BC75E2D631004300000000000000' , {Ten to the 21} R'523635C9ADC5DEA04400000000000000' , {Ten to the 22} R'5321E19E0C9BAB244500000000000000' , {Ten to the 23} R'54152D02C7E14AF64680000000000000' , {Ten to the 24} R'54D3C21BCECCEDA14600000000000000' , {Ten to the 25} R'558459516140148447A0000000000000' , {Ten to the 26} R'5652B7D2DCC80CD248E4000000000000' , {Ten to the 27} R'5733B2E3C9FD080349CE800000000000' , {Ten to the 28} R'58204FCE5E3E25024A61100000000000' , {Ten to the 29} R'591431E0FAE6D7214B7CAA0000000000' , {Ten to the 30} R'59C9F2C9CD04674E4BDEA40000000000' , {Ten to the 31} R'5A7E37BE2022C0914C4B268000000000' , {Ten to the 32} R'5B4EE2D6D415B85A4DCEF81000000000' , {Ten to the 33} R'5C314DC6448D93384EC15B0A00000000' , {Ten to the 34} R'5D1ED09BEAD87C034F78D8E640000000' , {Ten to the 35} R'5E13426172C74D82502B878FE8000000' , {Ten to the 36} R'5EC097CE7BC9071550B34B9F10000000' , {Ten to the 37} R'5F785EE10D5DA46D51900F436A000000' , {Ten to the 38} R'604B3B4CA85A86C4527A098A22400000' , {Ten to the 39} R'612F050FE938943A53CC45F655680000' , {Ten to the 40} R'621D6329F1C35CA454BFABB9F5610000' , {Ten to the 41} R'63125DFA371A19E655F7CB54395CA000' , {Ten to the 42} R'63B7ABC62705030555ADF14A3D9E4000' , {Ten to the 43} R'6472CB5BD86321E3568CB6CE6682E800' , {Ten to the 44} R'6547BF19673DF52E5737F2410011D100' , {Ten to the 45} R'662CD76FE086B93C58E2F768A00B22A0' , {Ten to the 46} R'671C06A5EC5433C6590DDAA16406F5A4' , {Ten to the 47} R'68118427B3B4A05B5AC8A8A4DE845987' , {Ten to the 48} R'68AF298D050E43955AD69670B12B7F41' , {Ten to the 49} R'696D79F82328EA3D5BA61E066EBB2F89' , {Ten to the 50} R'6A446C3B15F992665C87D2C40534FDB5' , {Ten to the 51} R'6B2AC3A4EDBBFB805D14E3BA83411E91' , {Ten to the 52} R'6C1ABA4714957D305E0D0E549208B31B' , {Ten to the 53} R'6D10B46C6CDD6E3E5F0828F4DB456FF1' , {Ten to the 54} R'6DA70C3C40A64E6C5F51999090B65F68' , {Ten to the 55} R'6E6867A5A867F10360B2FFFA5A71FBA1' , {Ten to the 56} R'6F4140C78940F6A2614FDFFC78873D45' , {Ten to the 57} R'7028C87CB5C89A256271EBFDCB54864B' , {Ten to the 58} R'71197D4DF19D60576367337E9F14D3EF' , {Ten to the 59} R'71FEE50B7025C36A630802F236D04754' , {Ten to the 60} R'729F4F2726179A22644501D762422C94' , {Ten to the 61} R'7363917877CEC055656B21269D695BDD' , {Ten to the 62} R'743E3AEB4AE138356662F4B82261D96A' , {Ten to the 63} R'7526E4D30ECCC321675DD8F3157D27E2' , {Ten to the 64} R'76184F03E93FF9F468DAA797ED6E38ED' , {Ten to the 65} R'76F316271C7FC390688A8BEF464E3946' , {Ten to the 66} R'7797EDD871CFDA3A695697758BF0E3CC' , {Ten to the 67} R'785EF4A74721E8646A761EA977768E5F' , {Ten to the 68} R'793B58E88C75313E6BC9D329EAAA18FC' , {Ten to the 69} R'7A25179157C93EC76C3E23FA32AA4F9D' , {Ten to the 70} R'7B172EBAD6DDC73C6D86D67C5FAA71C2' , {Ten to the 71} R'7BE7D34C64A9C85D6D4460DBBCA87197' , {Ten to the 72} R'7C90E40FBEEA1D3A6E4ABC8955E946FE' , {Ten to the 73} R'7D5A8E89D75252446F6EB5D5D5B1CC5F' , {Ten to the 74} R'7E3899162693736A70C531A5A58F1FBB' , {Ten to the 75} R'7F235FADD81C282271BB3F07877973D5'; %CONST %INTEGER SourceChannel= -81 %RECORD %FORMAT pf(%INTEGER bits1,bits2) %externalinteger studentpascal=0 %EXTERNAL %RECORD (pf) pascparmbits=0 %EXTERNAL %ROUTINE EMASzPascal %string(6)user user=uinfs(1) %if charno(user,4)='U' %then studentpascal=1 %else studentpascal=0 comreg(24)=16 pascparmbits_bits1=comreg(27) pascparmbits_bits2=comreg(28) *la_1,8; *sll_1,12; *ar_11,1 InitialiseCompiler ICLpascalcompiler %END { IMP version of FILEIO, contains input support for Pascal compiler } %CONST %INTEGER ForReading= 0, ForWriting = 1, ForBoth = 2 %OWN %INTEGER ResetFlag,RewriteFlag { Flag first call to Reset and Rewrite } %OWN %INTEGER Tracing= 0 %RECORD %FORMAT UNIXString(%BYTE %INTEGER %ARRAY Contents(1:255)) %OWN %RECORD (UNIXString) Argv0,Argv1,Argv2,Argv3,Argv4,Argv5,Argv6 %OWN %INTEGER %ARRAY ArgV(0:6) %EXTERNAL %INTEGER %SPEC PArgV %EXTERNAL %INTEGER %SPEC PArgC %RECORD %FORMAT UNIXFileFmt(%BYTE %INTEGER %ARRAY Buffer(1:512), %INTEGER Descriptor,FileAddress,StartofLine,EndofLine,EndofBuffer, BufferIndex,Mode,EOFFlag) %STRING (255) %FN ImpString(%INTEGER Ad) { return an Imp string containing the characters in the array at Ad } %OWN %STRING (255) Str Str="" %WHILE 0#Byteinteger(Ad)#' ' %CYCLE Str=Str.ToString(Byteinteger(Ad)) Ad=Ad+1 %REPEAT %RESULT=Str %END { of ImpString } %ROUTINE CString(%STRING (255) %NAME S, %RECORD (UNIXString) %NAME CS) %INTEGER I CS=0 %FOR I=1,1,Length(S) %CYCLE CS_Contents(I)=byteinteger(Addr(S)+I) %REPEAT %END { of CString } %RECORD %FORMAT CAPFmt(%INTEGER I,J,K) %EXTERNAL %ROUTINE Terminate(%INTEGER StringAd) %INTEGER N %RECORD (UNIXString) %NAME CS CS==record(StringAd) N=1 %WHILE CS_Contents(N)#' ' %CYCLE N=N+1 %REPEAT CS_Contents(N)=0 %END { of Terminate } %EXTERNAL %INTEGER %FN HeadsMatch(%INTEGER Name,U, %RECORD (CAPFmt) Prefix) { Dummy } %IF Tracing#0 %THEN %START printstring("heads match ") newline %MONITOR %FINISH %RESULT=1 %END { of Headsmatch } %ROUTINE InitialiseCompiler { Initialise compiler environment for Pascal } ResetFlag=0 RewriteFlag=0 Tracing=Comreg(26)&32 CString("Pascal",Argv0) CString("-d***G1D2",Argv1) CString("T1",Argv2) CString("OPTIONS",Argv3) CString("EMAS-A Vsn 1.17",Argv4) CString("",Argv5) CString("EMAS-A Pascal test compiler for Pascal",Argv6) ArgV(0)=Addr(Argv0) Argv(1)=Addr(Argv1) ArgV(2)=Addr(Argv2) ArgV(3)=Addr(Argv3) ArgV(4)=Addr(Argv4) ArgV(5)=Addr(Argv5) ArgV(6)=Addr(Argv6) PArgC=6 PArgV=Addr(Argv(0)) %END { of InitialiseCompiler } %EXTERNAL %INTEGER %FN Accessible(%INTEGER FileNameAd,Mode) %INTEGER ftype %STRING (60) FileName FileName=ImpString(FileNameAd) %IF Tracing#0 %THEN %START Printstring("accessible ") Printstring(FileName) Write(Mode,3) Newline %FINISH ftype=existtype(filename) %IF ftype=3 %THEN %RESULT=1; ! exists and is a character file %RESULT=0 %END { of Acessible } %EXTERNAL %ROUTINE ResetFile(%INTEGER FileAd,NameAd) %STRING (60) Name %RECORD (UNIXFileFmt) %NAME TheFile %INTEGER Chan,Flag,AFD Name=ImpString(NameAd) TheFile==record(FileAd) %IF tracing#0 %THEN %START printstring("reset source file") printstring(name) write(filead,12) newline %FINISH %IF ResetFlag=0 %THEN %START { First call this compilation } ResetFlag=1 Chan=-81 %FINISH %ELSE %START EMAS3ClaimChannel(Chan) DEFINE(chan,name,afd,flag) %IF Flag#0 %THEN %MONITOR %AND %STOP %FINISH TheFile=0 TheFile_Descriptor=Chan TheFile_BufferIndex=1 TheFile_StartofLine=1 TheFile_EndofLine=1 TheFile_EndofBuffer=1 TheFile_Mode=ForReading %END { of ResetFile } %ROUTINE ReadFileBuffer(%INTEGER FileAd) %INTEGER Amount,Char,I %RECORD (UNIXFileFmt) %NAME File %ON %EVENT 9 %START %IF tracing#0 %START printstring("file ended (trap) "); write(filead,12); newline %FINISH File_EOFFlag=1 ->Set %FINISH %IF Tracing#0 %THEN %START printstring("read file buffer ") write(filead,12) newline %FINISH File==record(FileAd) %RETURN %IF File_EOFFlag#0 selectinput(File_Descriptor) Amount=0 ! Readch(Char) ! %WHILE Char#NL %CYCLE ! Amount=Amount+1 ! File_Buffer(Amount)=Char ! ReadCh(Char) ! %IF Char=25 %THEN %START ! File_EOFFlag=1 ! %IF tracing#0 %START ! printstring("file ended (em) "); write(filead,12) ! newline ! %FINISH ! ->Set ! %FINISH ! %REPEAT amount=iocp(28,addr(file)) %if amount<0 %then amount=0 %and File_EOFflag=1 Set: Amount=Amount+1 File_Buffer(Amount)=NL %IF Tracing#0 %THEN %START %FOR I=1,1,Amount %CYCLE printch(file_buffer(I)) %REPEAT %FINISH File_EndofBuffer=Amount File_StartofLine=1 File_FileAddress=File_FileAddress+Amount %END { of ReadFileBuffer } %EXTERNAL %ROUTINE ReadFileLine(%INTEGER FileAd) %IF Tracing#0 %THEN %START printstring("read file line ") write(filead,12) newline %FINISH ReadFileBuffer(FileAd) %END { of ReadFileLine } %EXTERNAL %INTEGER %FN EndofFile(%INTEGER FileAd) %RECORD (UNIXFileFmt) %NAME File File==record(FileAd) %RESULT=File_EOFFlag %END { of EndofFile } %EXTERNAL %ROUTINE CloseFile(%INTEGER FileAd) { Dummy } %END { of CloseFile } {17/10/85 - new routines elinestart, eprecall } {21/10/85 - new routine eprocref } {23/10/85 - additional parameters to paseprc & Eproc } {28/10/85 - new routine writename } {28/11/85 - make Namesaddr & Names external } { - remove param form call to Enextproc } {---------------------------------------------------------------} {11/01/86 - add spec for Eproclevel. (agh) } {22/01/86 - modify call to Eproc to omit Level in Prop field. } { Add call to settrap to force errors to be taken by } { IMP. } {27/01/86 - Add PNames to pass source and object file-names. } {06/02/86 - Add Psave, Prestore and Pdiscard. } {17/02/86 - Add ECaseEntry, ECaseJump, and EcaseEnd. } {18/02/86 - Add Evrestore, and Evdiscard. } {24/03/86 - Change Estkglobalind to Estkgind. } {08/04/86 - Trap name-table overflow and modify SetName to PERQ } { addressing. } {08/04/86 - Add Eswapmode for byte-swap control. } {09/04/86 - Add ecode and mcode tracing control } {01/05/86 - Delete name-table. Strings are passed when required } {---------------------------------------------------------------} {12/05/86 - Tidy version for boot. } {21/05/86 - Add LRtoLR and LRtoSR for real/real conversions. } {26/05/86 - Add SRtoLR for real/real conversions. } !* !*********************************************************************** !* Imports * !*********************************************************************** !* !* !* !*********************************************************************** !* P A S C A L E - C O D E I N T E R F A C E * !*********************************************************************** !* !* %EXTERNAL %ROUTINE EndImp(%INTEGER Code) !*********************************************************************** !* Terminate compiler returning "no of lines if successful. * !* If unsuccessful then returns no of errors * !*********************************************************************** %INTEGER i %IF code>=0 %THEN i=0 %ELSE i=8 comreg(47)=imod(code) comreg(24)=i %END; ! EndImp !* %EXTERNAL %ROUTINE PasEprc(%INTEGER Adid,Level,Prop,Numpars,Paramsize, Astacklen, %INTEGER %NAME Id) !*********************************************************************** !* Call procedure entry routine. * !*********************************************************************** %STRING (32) %NAME Name Name==string(Adid) Eproc(Name,Prop,Numpars,Paramsize,Astacklen,Id) %END; ! PasEprc !* %EXTERNAL %ROUTINE PasEntr(%INTEGER Adid,Numpars,ParamSize,StackSize,DiagDisp) !*********************************************************************** !* Call procedure side-entry (to pass diag-table displacement). * !*********************************************************************** %STRING (32) %NAME Name Name==string(Adid) Eentry(0,Numpars,Paramsize,StackSize,DiagDisp,Name) %END; ! PasEntr !* %EXTERNAL %INTEGER %FUNCTION PasExnm(%INTEGER Type,Adid) !*********************************************************************** !* Pass external name reference. * !*********************************************************************** %STRING (32) %NAME Name Name==string(Adid) %RESULT=Exname(Type,Name) %END; ! PasExnm !* %EXTERNAL %ROUTINE Pasdent(%INTEGER Area,Offset,Length,Adid) !*********************************************************************** !* Pass data entry. * !*********************************************************************** %STRING (32) %NAME Name Name==string(Adid) Edataentry(Area,Offset,Length,Name) %END; ! Pasdent !* %EXTERNAL %ROUTINE Pasdref(%INTEGER Area,Offset,Length,Adid) !*********************************************************************** !* Pass external data reference. * !*********************************************************************** %STRING (32) %NAME Name Name==string(Adid) Edataref(Area,Offset,Length,Name) %END; ! Pasdref !* %EXTERNAL %ROUTINE LRtoSR(%INTEGER R1Addr,R2Addr) !*********************************************************************** !* Convert long (64-bit) real to short (32-bit) real. * !*********************************************************************** real(R2Addr)=longreal(R1Addr) %END; ! LRtoSR !* %EXTERNAL %ROUTINE LRtoLR(%INTEGER R1Addr,R2Addr) !*********************************************************************** !* Convert long (64-bit) real to long (64-bit) real. * !*********************************************************************** longreal(R2Addr)=longreal(R1Addr) %END; ! LRtoLR !* %EXTERNAL %ROUTINE SRtoLR(%INTEGER R1Addr,R2Addr) !*********************************************************************** !* Convert short (32-bit) real to long (64-bit) real. * !*********************************************************************** longreal(R2Addr)=real(R1Addr) %END; ! SRtoLR !* !* !*********************************************************************** !* P A S C A L P U T I N T E R F A C E * !*********************************************************************** !* !* %EXTERNAL %ROUTINE Pnames(%INTEGER SrcAdid,ObjAdid) !*********************************************************************** !* Pass source and object file names. * !*********************************************************************** ! %STRING (32) %NAME SrcName,ObjName ! SrcName==string(SrcAdid) ! ObjName==string(ObjAdid) ! Psetfiles(SrcName,ObjName) %END; ! Pnames !* %EXTERNAL %ROUTINE Pgen(%INTEGER ObjAdid) !*********************************************************************** !* Trigger object file generation. * !*********************************************************************** ! %STRING (32) %NAME ObjName ! ObjName==string(ObjAdid) ! PGenerateObject(ObjName) %END; ! Pgen !* !* %externalroutine ENTER %end %externallongrealfn powerof10(%integer val) %if val<-78 %then %Result=0 %if val>75 %then %result=R'7FFFFFFFFFFFFFFF' %result=powers(val) %end %EXTERNAL %LONG %REAL %FN INREAL(%INTEGER LEN,ADR) !*********************************************************************** !* Extract a real value from the text denoted by len&adr. * !* The syntax has already been checked. Real evaluation is performed * !* to maximum accuracy using double-precision arithmetic. It is the * !* compiler's respnsibility to truncate the result if required. * !*********************************************************************** %CONST %INTEGER TRUE= 1,FALSE=0 { denotes Boolean 'true' & 'false' } %INTEGER NEGATIVE,CH,I %LONG %LONG %REAL RWORK,SCALE %ROUTINE GETCH %IF LEN=0 %THEN CH=127 %else %Start CH=BYTEINTEGER(ADR) ADR=ADR+1 LEN=LEN-1 %finish %END GETCH %MONITOR %AND %STOP %UNLESS '0'<=CH<='9' RWORK=CH-'0' %CYCLE GETCH %EXIT %UNLESS '0'<=CH<='9' RWORK=10.0*RWORK+(CH-'0') %REPEAT %IF LEN=0 %THEN %RESULT=RWORK %IF CH='.' %THEN %START SCALE=10.0 %CYCLE GETCH %EXIT %UNLESS '0'<=CH<='9' RWORK=RWORK+(CH-'0')/SCALE SCALE=10.0*SCALE %REPEAT %FINISH %IF LEN=0 %THEN %RESULT=RWORK %IF CH='e' %OR CH='E' %THEN %START NEGATIVE=FALSE GETCH %IF CH='+' %THEN GETCH %IF CH='-' %THEN NEGATIVE=TRUE %AND GETCH I=CH-'0' %IF LEN>0 %THEN %START GETCH I=10*I+(CH-'0') %FINISH %IF NEGATIVE=TRUE %THEN I=-I %IF I<-78 %THEN %RESULT=0 %IF I>75 %THEN %RESULT=R'7FFFFFFFFFFFFFFF' RWORK=RWORK*POWERS(I) %FINISH %RESULT=RWORK %END; ! ReadRl %END %OF %FILE