!*********************************************************************** !* * !* RUN-TIME CODE FOR THE C COMPILER * !* FOR BOTH VME AND EMAS * !* * !*********************************************************************** %CONST %INTEGER ISO=0 %CONST %INTEGER EBCDIC=1 %CONST %INTEGER VME= 0 %CONST %INTEGER EMAS= 1 %CONST %INTEGER emasa=2 !*********************************************************************** !* * !* SET CHCODE = ISO FOR EMAS * !* = EBCDIC FOR VME * !* * !* SET TARGET = EMAS FOR EMAS * !* = VME FOR VME * !* * !* For VME external function names must start with ICL9CA * !* and for EMAS they must start with ICL9CA * !* * !*********************************************************************** %CONST %INTEGER CHCODE=ISO %CONST %INTEGER TARGET= EMASA { ISO CHARACTER CONSTANTS } %CONST %BYTE %INTEGER NUL= X'00' %CONST %BYTE %INTEGER SOH= X'01' %CONST %BYTE %INTEGER STX= X'02' %CONST %BYTE %INTEGER ETX= X'03' %CONST %BYTE %INTEGER EOT= X'04' %CONST %BYTE %INTEGER ENQ= X'05' %CONST %BYTE %INTEGER ACK= X'06' %CONST %BYTE %INTEGER BEL= X'07' %CONST %BYTE %INTEGER BS= X'08' %CONST %BYTE %INTEGER HT= X'09' %CONST %BYTE %INTEGER VT= X'0B' %CONST %BYTE %INTEGER FF= X'0C' %CONST %BYTE %INTEGER CR= X'0D' %CONST %BYTE %INTEGER SO= X'0E' %CONST %BYTE %INTEGER SI= X'0F' %CONST %BYTE %INTEGER DLE= X'10' %CONST %BYTE %INTEGER DC1= X'11' %CONST %BYTE %INTEGER DC2= X'12' %CONST %BYTE %INTEGER DC3= X'13' %CONST %BYTE %INTEGER DC4= X'14' %CONST %BYTE %INTEGER NAK= X'15' %CONST %BYTE %INTEGER SYN= X'16' %CONST %BYTE %INTEGER ETB= X'17' %CONST %BYTE %INTEGER CAN= X'18' %CONST %BYTE %INTEGER EM= X'19' %CONST %BYTE %INTEGER XSUB= X'1A' %CONST %BYTE %INTEGER ESC= X'1B' %CONST %BYTE %INTEGER FS= X'1C' %CONST %BYTE %INTEGER GS= X'1D' %CONST %BYTE %INTEGER RS= X'1E' %CONST %BYTE %INTEGER US= X'1F' %IF CHCODE=EBCDIC %THEN %START { CHARACTER CONVERSION TABLES } %CONST %BYTE %INTEGER %ARRAY ITOETAB(0:255)= %C 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, 64, 79, 127, 123, 91, 108, 80, 125, 77, 93, 92, 78, 107, 96, 75, 97, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 122, 94, 76, 126, 110, 111, 124, 193, 194, 195, 196, 197, 198, 199, 200, 201, 209, 210, 211, 212, 213, 214, 215, 216, 217, 226, 227, 228, 229, 230, 231, 232, 233, 74, 224, 90, 95, 109, 121, 129, 130, 131, 132, 133, 134, 135, 136, 137, 145, 146, 147, 148, 149, 150, 151, 152, 153, 162, 163, 164, 165, 166, 167, 168, 169, 192, 106, 208, 161, 7, 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62, 225, 65, 66, 67, 68, 69, 70, 71, 72, 73, 81, 82, 83, 84, 85, 86, 87, 88, 89, 98, 99, 100, 101, 102, 103, 104, 105, 112, 113, 114, 115, 116, 117, 118, 119, 120, 128, 138, 139, 140, 141, 142, 143, 144, 154, 155, 156, 157, 158, 159, 160, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, 191, 202, 203, 204, 205, 206, 207, 218, 219, 220, 221, 222, 223, 234, 235, 236, 237, 238, 239, 250, 251, 252, 253, 254, 255 %CONST %BYTE %INTEGER %ARRAY ETOITAB(0:255)= %C 0, 1, 2, 3, 156, 9, 134, 127, 151, 141, 142, 11, 12, 13, 14, 15, 16, 17, 18, 19, 157, 10, 8, 135, 24, 25, 146, 143, 28, 29, 30, 31, 128, 129, 130, 131, 132, 133, 23, 27, 136, 137, 138, 139, 140, 5, 6, 7, 144, 145, 22, 147, 148, 149, 150, 4, 152, 153, 154, 155, 20, 21, 158, 26, 32, 160, 161, 162, 163, 164, 165, 166, 167, 168, 91, 46, 60, 40, 43, 33, 38, 169, 170, 171, 172, 173, 174, 175, 176, 177, 93, 36, 42, 41, 59, 94, 45, 47, 178, 179, 180, 181, 182, 183, 184, 185, 124, 44, 37, 95, 62, 63, 186, 187, 188, 189, 190, 191, 192, 193, 194, 96, 58, 35, 64, 39, 61, 34, 195, 97, 98, 99, 100, 101, 102, 103, 104, 105, 196, 197, 198, 199, 200, 201, 202, 106, 107, 108, 109, 110, 111, 112, 113, 114, 203, 204, 205, 206, 207, 208, 209, 126, 115, 116, 117, 118, 119, 120, 121, 122, 210, 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, 231, 123, 65, 66, 67, 68, 69, 70, 71, 72, 73, 232, 233, 234, 235, 236, 237, 125, 74, 75, 76, 77, 78, 79, 80, 81, 82, 238, 239, 240, 241, 242, 243, 92, 159, 83, 84, 85, 86, 87, 88, 89, 90, 244, 245, 246, 247, 248, 249, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 250, 251, 252, 253, 254, 255 %FINISH %CONST %LONG %INTEGER randmpy= 1103515245 %CONST %INTEGER randadd= 12345 %CONST %LONG %REAL DZ= 0 { STANDARD FILE CONSTANTS } %CONST %INTEGER opread= 1 %CONST %INTEGER opwrite= 2 %CONST %INTEGER oprdwr= 3 %CONST %INTEGER StdIn= 0 %CONST %INTEGER StdOut= 1 %CONST %INTEGER StdErr= 2 %CONST %INTEGER EOF= -1 %CONST %INTEGER CPrintf= 1 %CONST %INTEGER CFPrintf= 2 %CONST %INTEGER CScanf= 3 %CONST %INTEGER CFScanf= 4 %CONST %INTEGER SFPrintf= 5 %CONST %INTEGER SFScanf= 6 %CONST %INTEGER Nobufftype= 0 %CONST %INTEGER Linebufftype= 1 %CONST %INTEGER Fullbufftype= 2 %CONST %INTEGER Filesize= 4096 %CONST %INTEGER Bufsize= 256 %CONST %INTEGER Seekset= 0 %CONST %INTEGER Seekcur= 1 %CONST %INTEGER Seekend= 2 !*********************************************************************** !* * !* Specs for EMAS specific function calls * !* * !*********************************************************************** %IF Target=EMAS %OR target=emasa %THEN %START %OWN %INTEGER icl9caerrno %EXTERNAL %ROUTINE %SPEC FILL %ALIAS "S#FILL"(%INTEGER len,from,filler) %EXTERNAL %ROUTINE %SPEC MOVE %ALIAS "S#MOVE"(%INTEGER len,from,to) %ROUTINE %SPEC Buff to File(%INTEGER chan,add,nchs) %INTEGER %FN %SPEC RAND %EXTERNAL %INTEGER %FUNCTION %SPEC current packed dt %ALIAS "S#CURRENTPACKEDDT" %EXTERNAL %STRING %FUNCTION %SPEC unpack date %ALIAS "S#UNPACKDATE"(%INTEGER d) %EXTERNAL %STRING %FUNCTION %SPEC unpack time %ALIAS "S#UNPACKTIME"(%INTEGER t) %FINISH %IF target=emasa %START %EXTERNAL %ROUTINE %SPEC emas3string(%STRING %NAME vector,value) %EXTERNAL %ROUTINE %SPEC destroy %ALIAS "S#DESTROY"(%STRING (255) File, %INTEGER %NAME flag) %EXTERNAL %ROUTINE %SPEC rename %ALIAS "S#RENAME"(%STRING (255) file,newfile, %INTEGER %NAME flag) %RECORD %FORMAT chdrform(%INTEGER conad,filetype,datastart,dataend) %EXTERNAL %ROUTINE %SPEC connect %ALIAS "S#OLDCONNECT"(%STRING (255) file, %INTEGER mode,hole,prot, %RECORD (chdrform) %NAME r, %INTEGER %NAME flag) %EXTERNAL %ROUTINE %SPEC change file size %ALIAS "S#CHANGEFILESIZE"(%STRING (255) file, %INTEGER newsize, %INTEGER %NAME flag) %EXTERNAL %ROUTINE %SPEC disconnect %ALIAS "S#DISCONNECT"(%STRING (255) file, %INTEGER %NAME flag) %EXTERNAL %INTEGER %FN %SPEC DVALIDATE(%INTEGER %NAME adr,len,rw{r=0}) %FINISH %IF target=emas %START %EXTERNAL %ROUTINE %SPEC destroy %ALIAS "S#DESTROY"(%STRING (255) s) %EXTERNAL %ROUTINE %SPEC rename %ALIAS "S#RENAME"(%STRING (255) s) %EXTERNAL %ROUTINE %SPEC connect %ALIAS "S#CONNECT"(%STRING (15) s, %INTEGER size, %RECORD (FFm) %NAME r, %INTEGER %NAME flag) %EXTERNAL %ROUTINE %SPEC Change File Size %ALIAS "S#CHANGEFILESIZE"(%STRING (15) file, %INTEGER size, %INTEGER %NAME flag) %EXTERNAL %ROUTINE %SPEC Disconnect %ALIAS "S#DISCONNECT"(%STRING (15) file, %INTEGER %NAME flag) %FINISH !*********************************************************************** !* * !* Specs for VME specific function calls * !* * !*********************************************************************** %IF Target=VME %THEN %START %EXTERNAL %INTEGER ICL9CAERRNO %EXTERNAL %INTEGER %FN %SPEC CC REMOVE %ALIAS "S#CCREMOVE"(%STRING %NAME FILE NAME) %EXTERNAL %INTEGER %FN %SPEC CC RENAME %ALIAS "S#CCRENAME"(%STRING %NAME OLD NAME,NEW NAME) %EXTERNAL %INTEGER %FN %SPEC CC TMPFILE %ALIAS "S#CCTMPFILE"(%INTEGER CHANNEL) %EXTERNAL %ROUTINE %SPEC CC SETBUF %ALIAS "S#CCSETBUF"(%INTEGER CHANNEL,BUFFER PTR) %EXTERNAL %INTEGER %FN %SPEC CC SETVBUF %ALIAS "S#CCSETVBUF"(%INTEGER CHANNEL,BUFFER PTR,TYPE,BUFFER SIZE) %EXTERNAL %INTEGER %FN %SPEC CC STRERROR %ALIAS "S#CCSTRERROR"(%STRING %NAME USER TEXT) %EXTERNAL %INTEGER %FN %SPEC EXECUTE %ALIAS "S#EXECUTE"(%STRING %NAME COMMAND) %EXTERNAL %ROUTINE %SPEC ICL9CA ENVINIT(%INTEGER anything) %EXTERNAL %INTEGER %FN %SPEC WRITE TEXT %ALIAS "S#WRITETEXT"(%INTEGER channel,startadd,len) %EXTERNAL %INTEGER %FN %SPEC READ TEXT %ALIAS "S#READTEXT"(%INTEGER channel,startadd,len) %EXTERNAL %INTEGER %FN %SPEC READ DATA %ALIAS "S#READDATA"(%INTEGER channel,startadd,len) %EXTERNAL %INTEGER %FN %SPEC WRITE DATA %ALIAS "S#WRITEDATA"(%INTEGER channel,startadd,len) %EXTERNAL %INTEGER %FN %SPEC CCFOPEN %ALIAS "S#CCFOPEN"(%INTEGER channel,flag, %STRING %NAME Filename) %EXTERNAL %INTEGER %FN %SPEC CCFCLOSE %ALIAS "S#CCFCLOSE"(%INTEGER channel) %EXTERNAL %INTEGER %FN %SPEC CCFFLUSH %ALIAS "S#CCFFLUSH"(%INTEGER channel) %EXTERNAL %INTEGER %FN %SPEC CCFSEEK %ALIAS "S#CCFSEEK"(%INTEGER channel,offset,ptrname) %EXTERNAL %INTEGER %FN %SPEC CCFTELL %ALIAS "S#CCFTELL"(%INTEGER channel) %EXTERNAL %INTEGER %FN %SPEC CCUNGETC %ALIAS "S#CCUNGETC"(%INTEGER char,channel) %EXTERNAL %LONG %REAL %FN %SPEC TIME DIFF %ALIAS "S#DIFFTIME"(%LONG %REAL T2,T1) %EXTERNAL %LONG %INTEGER %FN %SPEC READ CPU CLOCK %ALIAS "S#READCPUCLOCK" %EXTERNAL %ROUTINE %SPEC DATE and TIME %ALIAS "S#DANDT"(%LONG %INTEGER CTime, %STRING %NAME Date,Time) %EXTERNAL %INTEGER %FN %SPEC READ JS VAR %ALIAS "S#READJSVAR"(%STRING (32) Jsvarname, %INTEGER option, %INTEGER adres) %FINISH !*********************************************************************** !* * !* General Specs * !* * !*********************************************************************** %RECORD %FORMAT FFm(%INTEGER Conad,Filetype,Datastart,Dataend) %EXTERNAL %ROUTINE %SPEC out file %ALIAS "S#OUTFILE"(%STRING (255) file, %INTEGER size,hole,prot, %INTEGER %NAME conad,flag) %EXTERNAL %INTEGER %MAP %SPEC comreg %ALIAS "S#COMREGMAP"(%INTEGER n) !%EXTERNAL %ROUTINE %SPEC ndiag %ALIAS "S#NDIAG"(%INTEGER pc,lnb,fault,inf) %ROUTINE %SPEC OPEH(%INTEGER errno,a,b,c) %EXTERNAL %LONG %REAL %FUNCTION %SPEC cpu time %ALIAS "S#CPUTIME" %EXTERNAL %ROUTINE %SPEC phex %ALIAS "S#PHEX"(%INTEGER n) %RECORD %FORMAT filerec(%STRING (255) Fnm, %BYTE %INTEGER eofmark,errmark,lastop,flags, %INTEGER Initcon,Conad,Fptr, Filelength, %INTEGER Bufadd,Bufsize,Bufptr,Buftype,Dataend,seekptr) %RECORD %FORMAT allhead(%HALF %INTEGER mode,form, %INTEGER H0,nextblock,back) %OWN %RECORD (filerec) %ARRAY FFinfo(0:80) %EXTERNAL %INTEGER %FN %SPEC CCTo Integer %ALIAS "S#CCTOINTEGER"(%INTEGER Data Ad,Data Len, %INTEGER Int Len,Int Ptr, Mode) %EXTERNAL %INTEGER %FN %SPEC CCTo Real %ALIAS "S#CCTOREAL"(%INTEGER Data Ad,Data Len,Int Len,Int Ptr,Dec Len,Dec Ptr, %INTEGER Exp Len,Exp Ptr,Decs,Scale Factor,Mode) %INTEGER %FN %SPEC malloc(%INTEGER elsize) %INTEGER %FN %SPEC free(%INTEGER ptr) %INTEGER %FN %SPEC strlen(%INTEGER stradd) %INTEGER %FN %SPEC strcat(%INTEGER s1,s2) !*********************************************************************** !* * !* Global variables used for storage allocation, I/O and Date/Time * !* * !*********************************************************************** %CONST %INTEGER SpFree= 3 %CONST %INTEGER Captured= 12 %CONST %INTEGER SizeHead= 16 %CONST %INTEGER alloclimit= 500000 %CONST %INTEGER MaxBuff= 512 %OWN %INTEGER StartFreeSpace,allocspac,Spallspace,startst %OWN %BYTE %INTEGER %ARRAY Res(0:511) %OWN %INTEGER ARes,Inptr,ebadr,seed,strtoken,restr,resptr %OWN %INTEGER ModeIO,ChanIO,PtrIO,ConAdIO,Onexitcount %CONST %INTEGER Default= -21 %CONST %INTEGER Set= 0 %CONST %INTEGER UnSet= 1 %OWN %INTEGER Infield,Field,Strsize,Spset,Hashset,Ljst,Pluset,pad %OWN %INTEGER Message stream,Outchars,Inchars,Noassign %OWN %STRING (26) tempfilename %OWN %STRING (255) strnum,jsvarstr %OWN %INTEGER %ARRAY sg(1:6) %OWN %INTEGER %ARRAY onex(1:32) %RECORD %FORMAT timestruct(%INTEGER sec,min,hour,mday,mon,year,wday,yday,isdst) %OWN %RECORD (timestruct) TM %OWN %STRING (26) strtime %CONST %INTEGER %ARRAY dayone(85:99)=1,2,3,4,6,0,1,2,4,5,6,7,2,3,4 %CONST %STRING (3) %ARRAY wdayname(0:6)= "Sun","Mon","Tue","Wed","Thu","Fri","Sat" %CONST %STRING (3) %ARRAY monname(0:11)= "Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec" %CONST %INTEGER %ARRAY yday(0:11)= 0,31,59,90,120,151,181,212,243,273,304,334 %OWN %INTEGER Tracing %OWN %INTEGER Errno %CONST %INTEGER roff= 20; {offset for RUNC parms} %IF target=EMAS %OR target=emasa %THEN %START !**************************************************************************** ! ! ERROR MESSAGES ! !**************************************************************************** ! !---Ranges of Fault Types: ! ! %CONST %INTEGER Min IMP Error= 6, Max IMP Error= 36, Min IO Error= 201, Max IO Error= 229, Min C LIB Error= 300, Max C LIB Error= 325, Min C RT Error= 401, Max C RT Error= 402 %CONST %STRING (24) %ARRAY IMP ERRORS(Min IMP ERROR:Max IMP Error)= %C %C {Fault 6} "ARRAY BOUNDS EXCEEDED" , {Fault 7} "CAPACITY EXCEEDED" , {Fault 8} "" , {Fault 9} "" , {Fault 10} "" , {Fault 11} "UNASSIGNED VARIABLE" , {Fault 12} "" , {Fault 13} "" , {Fault 14} "" , {Fault 15} "ILLEGAL EXPONENTIATION" , {Fault 16} "SWITCH LABEL NOT SET" , {Fault 17} "" , {Fault 18} "ILLEGAL CYCLE" , {Fault 19} "INT PT TOO LARGE" , {Fault 20} "ARRAY INSIDE OUT" , {Fault 21} "NO RESULT" , {Fault 22} "PARAM NOT DESTINATION" , {Fault 23} "PROGRAM TOO LARGE" , {Fault 24} "" , {Fault 25} "" , {Fault 26} "" , {Fault 27} "IOCP ERROR" , {Fault 28} "" , {Fault 29} "" , {Fault 30} "" , {Fault 31} "" , {Fault 32} "RESOLUTION FAULT" , {Fault 33} "" , {Fault 34} "SYMBOL INSTEAD OF STRING" , {Fault 35} "STRING INSIDE OUT" , {Fault 36} "WRONG PARAMS PROVIDED" %CONST %STRING (28) %ARRAY IO ERRORS(Min IO ERROR:Max IO Error)= %C %C {Fault 201} "INTERNAL ERROR1" , {Fault 202} "INTERNAL ERROR2" , {Fault 203} "INTERNAL ERROR3" , {Fault 204} "INTERNAL ERROR4" , {Fault 205} "TOO MANY AREAS REQUIRED" , {Fault 206} "FACILITY NOT IMPLEMENTED" , {Fault 207} "" , {Fault 208} "" , {Fault 209} "CANNOT OPEN FILE" , {Fault 210} "FILE IS NOT DEFINED" , {Fault 211} "FILE IS NOT OPEN" , {Fault 212} "FILE NOT AVAILABLE" , {Fault 213} "FILE NOT POSITIONED" , {Fault 214} "FILE DOES NOT EXIST" , {Fault 215} "FILE ALREADY EXISTS" , {Fault 216} "FILE ALREADY CLOSED" , {Fault 217} "FILE FULL" , {Fault 218} "INPUT ENDED" , {Fault 219} "INVALID I/O OPERATION" , {Fault 220} "NO WRITE PERMISSION" , {Fault 221} "NO ACCESS PERMISSION" , {Fault 222} "RECORD NUMBER OUT OF RANGE" , {Fault 223} "RECORD LENGTH TOO LARGE" , {Fault 224} "RECORD WRONG LENGTH" , {Fault 225} "RECORD NUMBER WRONG LENGTH" , {Fault 226} "INVALID POSITIONING REQUEST" , {Fault 227} "INVALID TYPE" , {Fault 228} "INVALID BUFFER SIZE" , {Fault 229} "FILE ALREADY WRITTEN OR READ" %CONST %STRING (33) %ARRAY C LIB ERRORS(Min C LIB Error:Max C LIB Error)= %C %C {Fault 300} "INVALID STREAM POINTER" , {Fault 301} "CHANNEL ALREADY OPEN" , {Fault 302} "READ AFTER WRITE" , {Fault 303} "WRITE AFTER READ" , {Fault 304} "TOO MANY FILES OPENED" , {Fault 305} "INCOMPATIBLE CONVERSION SPECIFIER" , {Fault 306} "INVALID ADDRESS" , {Fault 307} "SETBUF NOT ALLOWED AFTER I/O OP" , {Fault 308} "" , {Fault 309} "" , {Fault 310} "BLOCK WAS NOT ALLOCATED" , {Fault 311} "NO FREE SPACE AVAILABLE" , {Fault 312} "" , {Fault 313} "" , {Fault 314} "" , {Fault 315} "" , {Fault 316} "" , {Fault 317} "" , {Fault 318} "" , {Fault 319} "" , {Fault 320} "INVALID SIGNAL NUMBER" , {Fault 321} "SIG_DFL SIGNAL SENT" , {Fault 322} "ENVIRONMENT NAME TOO LONG" , {Fault 323} "ONEXIT LIMIT EXCEEDED" , {Fault 324} "" , {Fault 325} "ABORT CALLED" %CONST %STRING (21) %ARRAY C RT ERRORS(Min C RT Error:Max C RT Error)= %C %C {Fault 401} "UNASSIGNED VARIABLE" , {Fault 402} "ARRAY BOUNDS EXCEEDED" %FINISH {conditional compilation} %IF target=VME %START %ROUTINE Fill(%INTEGER len,from,filler) !*********************************************************************** !* Plant multiple copies of a filler byte * !*********************************************************************** %INTEGER i %IF len<=0 %THEN %RETURN i=X'18000000'!len *LDTB_i *LDA_from *LB_filler *MVL_ %L = %DR %END %ROUTINE Move(%INTEGER len,from,to) !*********************************************************************** !* A copy of the EMAS move routine for VME * !*********************************************************************** %INTEGER i %IF len<=0 %THEN %RETURN i=X'18000000'!LEN *LSS_from *LUH_i *LDTB_i *LDA_to *MV_ %L = %DR %END %FINISH %EXTERNAL %ROUTINE GETRUNC %ALIAS "ICL9CAGETRUNC" !********************************************************************** !* * !* Decode parameters on the RUNC command * !* * !********************************************************************** %INTEGER nargs,argptr %INTEGER i,k,l,m,Jsadd1,Jsadd2 %INTEGER d1,d2 %INTEGER %ARRAY %FORMAT argform(0:128) %INTEGER %ARRAY %NAME argadr %STRING %NAME Jsvarstr1,Jsvarstr2 !* argptr=malloc(1024) Jsvarstr1==string(argptr) argadr==array(argptr+512,argform) Jsadd1=addr(Jsvarstr1) argadr(0)=Jsadd1+1 nargs=1 %IF target=vme %START k=READ JS VAR("ICL9CAENTRY",2,Jsadd1) l=length(Jsvarstr1) %IF k#0 %THEN l=0 %IF CHCODE=EBCDIC %AND l>0 %THEN %START %CYCLE i=1,1,l byteinteger(Jsadd1+i)=ITOETAB(byteinteger(Jsadd1+i)) %REPEAT %FINISH !* Jsadd2=Jsadd1+l+1 Jsvarstr2==string(Jsadd2) k=READ JS VAR("ICL9CAARGS",2,Jsadd2) l=length(Jsvarstr2) ! ! Return with null pointer if Job Space Var cannot be found ! or if returned string is null ! %IF k#0 %OR l=0 %THEN ->RETURN0 ! ! Convert string to Ebcdic ! %IF chcode=ebcdic %THEN %START %CYCLE i=1,1,l byteinteger(Jsadd2+i)=ITOETAB(byteinteger(Jsadd2+i)) %REPEAT %FINISH ! ! Create array of pointers to individual C strings ! argadr(1)=Jsadd2+1 i=2 *LDB_(Jsvarstr2) *INCA_1 L1: *SWNE_ %L = %DR,0,64 *JCC_8, *STD_d1 argadr(i)=d2+1 i=i+1 *LD_d1 *MVL_ %L =1,0,0 ->L1 L2: *STD_d1 byteinteger(d2)=0 byteinteger(Jsadd2)=0 nargs=i %ELSE jsvarstr1="RUN".tostring(0); ! First pseudoparam =command name jsadd2=jsadd1+5 jsvarstr2==string(jsadd2); ! second parameter Unix qualifiers jsvarstr2=""; ! For emas where there is no getstring %IF target=emasa %THEN emas3string("Unix qualifier; any,verbatin,ornull;;",jsvarstr2) l=length(jsvarstr2) argadr(1)=jsadd2+1 i=2 %FOR k=1,1,l %CYCLE; ! space signifies new qualifier %IF charno(jsvarstr2,k)=' ' %START argadr(i)=jsadd2+k+1 i=i+1 charno(jsvarstr2,k)=0; ! C strings are zero terminated %FINISH %REPEAT byteinteger(jsadd2+1+l)=0; ! Zero terminate fina string nargs=i %FINISH; ! emas specific code !* RETURN0: argadr(nargs)=0 %IF target=emasa %START *l_1,40(10) *ST_1,I integer(i+64)=nargs; ! first pseudo prog param is howmany integer(i+68)=argptr+512; ! second is addrees of pointerlist %ELSE *STLN_i m=integer(i) integer(m+roff)=nargs integer(m+roff+4)=argptr+512 %FINISH %RETURN %END; {GETRUNC} !* !* %EXTERNAL %ROUTINE initsown %ALIAS "ICL9CAINITSOWN" !*********************************************************************** !* * !* INITIALISES OWN VARIABLE AREAS * !* * !*********************************************************************** %INTEGER i,m allocspac=0 startst=0 Inptr=0 %FOR i=0,1,80 %CYCLE FFinfo(i)_fnm="" FFinfo(i)_eofmark=0 FFinfo(i)_errmark=0 %REPEAT FFinfo(0)_lastop=OPREAD FFinfo(1)_lastop=OPWRITE FFinfo(2)_lastop=OPWRITE Seed=1 %FOR i=1,1,6 %CYCLE sg(i)=-2 %REPEAT onexitcount=0 %IF Target=VME %THEN Message stream=81 %ELSE Message stream=0 %IF Target=VME %THEN ICL9CA ENVINIT(-1) %IF COMREG(45)=0 %THEN Tracing=Unset %ELSE Tracing=Set !* !* %END; {INITSOWN} %STRING (32) %FN ItoS(%INTEGER n) !*********************************************************************** !* * !* CONVERTS INTEGER TO STRING * !* * !*********************************************************************** %STRING (32) s s="" %CYCLE s=tostring(n-(n//10*10)+'0').s n=n//10 %REPEAT %UNTIL n=0 %RESULT=s %END; !ITOS %INTEGER %FN stoi(%STRING (32) str) !*********************************************************************** !* * !* CONVERT STRING TO INTEGER * !* * !*********************************************************************** %INTEGER value,sym,x,len value=0 len=length(str) %FOR x=1,1,len %CYCLE sym=Charno(str,x) %UNLESS '0'<=sym<='9' %THEN %RESULT=-1 value=10*value+sym&15 %REPEAT %RESULT=value %END; !STOI %STRING (32) %FN HtoI(%STRING (32) str) !*********************************************************************** !* * !* CONVERTS HEX STRING TO EQUIVALENT DECIMAL STRING. * !* * !*********************************************************************** %INTEGER value,sym,val,len,x value=0 len=length(str) %FOR x=1,1,len %CYCLE sym=CharNo(str,x) %IF '0'<=sym<='9' %THEN val=sym-'0' %ELSE %IF 'a'<=sym<='f' %THEN val=sym-'a'+10 %ELSE val=sym-'A'+10 value=value+(val*(16\\(len-x))) %REPEAT %RESULT=ItoS(value) %END; !HTOI %STRING (32) %FN OtoI(%STRING (32) str) !*********************************************************************** !* * !* CONVERTS OCT STRING TO EQUIVALENT DECIMAL STRING. * !* * !*********************************************************************** %INTEGER value,sym,val,len,x value=0 len=length(str) %FOR x=1,1,len %CYCLE sym=CharNo(str,x) val=sym-'0' value=value+(val*(8\\(len-x))) %REPEAT %RESULT=ItoS(value) %END; !OTOI %ROUTINE IntegerF(%INTEGER Sgn) !*********************************************************************** !* * !* FORMATS AN INTEGER(or REAL) ACCORDING TO SPEC AT ADDRESS ARES * !* * !*********************************************************************** %INTEGER i,len,value,Space,astr,nch ARes=addr(Res(0)) astr=addr(strnum)+1 len=length(strnum) %IF StrSize=Default %THEN %START %IF Field\=Default %AND Field>len %THEN %START Space=Field-len Inptr=Field %IF LJst=UnSet %THEN %START Fill(Space,Ares,pad) Move(len,astr,Ares+Space) %IF Sgn=Set %AND pad='0' %THEN %START i=-1 %CYCLE i=i+1 nch=byteinteger(Ares+i) %REPEAT %UNTIL nch='+' %OR nch='-' byteinteger(Ares+i)='0' byteinteger(Ares)=nch %FINISH %FINISH %ELSE %START Move(len,astr,Ares) Fill(Space,Ares+len,pad) %FINISH %FINISH %ELSE %START Move(len,astr,Ares) Inptr=len %FINISH %FINISH %ELSE %IF StrSize>len %THEN %START Space=StrSize-len %IF Sgn=Unset %THEN pad=' ' %ELSE pad='0' Fill(Space,Ares,pad) Move(len,astr,Ares+Space) Inptr=Strsize %FINISH %ELSE %START Move(len,astr,Ares) Inptr=len %FINISH %END; {INTEGERF} %INTEGER %FN FLG(%INTEGER priv) !*********************************************************************** !* * !* INTERPRET THE OPTIONS ON THE FILE OPEN CALL * !* * !*********************************************************************** %INTEGER i,flag,c i=0 flag=0 c=byteinteger(priv) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %WHILE c\=Nul %CYCLE %IF i=0 %THEN %START %IF c='r' %THEN Flag=Flag!X'00' %ELSE %IF c='w' %THEN flag=flag!X'01' %ELSE %IF c='a' %THEN flag=flag!X'02' %FINISH %ELSE %START %IF i=1 %THEN %START %IF c='b' %THEN flag=flag!X'08' %ELSE %IF c='+' %THEN flag=flag!X'04' %FINISH %ELSE %START %IF i=2 %THEN %START %IF c='b' %THEN flag=flag!X'08' %FINISH %FINISH %FINISH i=i+1 c=byteinteger(priv+i) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %REPEAT %RESULT=flag %END; {FLG} %EXTERNAL %INTEGER %FN fopen %ALIAS "ICL9CAFOPEN"(%INTEGER file,priv) !*********************************************************************** !* * !* (** fopen **) * !* * !*********************************************************************** %RECORD (FFm) r %STRING (255) FileName %INTEGER Flag,i,j,k,key,conad,F,Mode byteinteger(addr(Filename))=strlen(file) %FOR i=1,1,strlen(file) %CYCLE byteinteger(addr(Filename)+i)=byteinteger(file+i-1) %REPEAT %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,strlen(file) %CYCLE byteinteger(addr(Filename)+i)=ETOITAB(byteinteger(addr(Filename)+i)) %REPEAT %FINISH Flag=0 key=81 %FOR i=80,-1,3 %CYCLE %IF Filename=FFinfo(i)_fnm %THEN %RESULT=0 %IF FFinfo(i)_fnm="" %THEN key=i %REPEAT %IF key=81 %THEN ICL9CAERRNO=304 %AND %RESULT=0 flag=FLG(priv) %IF TARGET=VME %THEN %START k=CCFOPEN(Key,Flag,Filename) %IF k<0 %THEN flag=flag!X'08' {stream to be treated as binary} %IF k>0 %THEN ICL9CAERRNO=k %AND %RESULT=0 %FINISH %IF TARGET=EMAS %OR target=emasa %THEN %START %IF Flag&X'01'#0 %THEN %START Outfile(Filename,Filesize,0,0,Conad,F) %IF F#0 %THEN %RESULT=0 FFinfo(key)_Filelength=Filesize %IF Flag&X'08'=0 %THEN integer(Conad+12)=3 %ELSE integer(Conad+12)=4 %FINISH %ELSE %START %IF Flag&X'07'=0 %THEN Mode=1 %ELSE Mode=3 Connect(Filename,Mode,0,0,r,F) %IF F#0 %THEN %START %IF Flag&X'07'#0 %THEN %START Outfile(Filename,Filesize,0,0,Conad,F) %IF F#0 %THEN %RESULT=0 FFinfo(key)_Filelength=Filesize %IF Flag&X'08'=0 %THEN integer(Conad+12)=3 %ELSE integer(Conad+12)=4 %FINISH %ELSE OPEH(335,0,11,0) %FINISH %ELSE %START Conad=r_Conad %IF Flag&X'07'#0 %THEN %START j=integer(Conad)+4096 Change File Size(Filename,j,F) %IF F#0 %THEN OPEH(335,0,11,0) %FINISH FFinfo(key)_Filelength=integer(Conad+8) %FINISH %FINISH FFinfo(key)_Initcon=Conad FFinfo(key)_Conad=Conad+32 FFinfo(key)_fptr=Conad+32 %IF Flag&X'08'#0 %THEN FFinfo(key)_Buftype=Fullbufftype %ELSE FFinfo(key)_Buftype=LineBuffType %IF Bufsize=0 %THEN FFinfo(key)_Buftype=Nobufftype FFinfo(Key)_Bufsize=Bufsize FFinfo(key)_Bufadd=Malloc(Bufsize) FFinfo(key)_Bufptr=0 FFinfo(key)_Dataend=Bufsize FFinfo(key)_Seekptr=Conad+32 %FINISH FFinfo(key)_Fnm=Filename; !in ISO FFinfo(key)_flags=Flag FFinfo(key)_eofmark=0 FFinfo(key)_errmark=0 FFinfo(key)_lastop=OPRDWR %RESULT=key %END; !ICL9CAFOPEN %EXTERNAL %INTEGER %FN fclose %ALIAS "ICL9CAFCLOSE"(%INTEGER chan) !*********************************************************************** !* * !* S (** fclose **) * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=300 %IF FFinfo(chan)_fnm="" %THEN %RESULT=0 %IF TARGET=VME %THEN %START k=CCFCLOSE(chan) FFinfo(chan)_fnm="" %IF k\=0 %THEN ICL9CAERRNO=k %AND %RESULT=k %RESULT=0 %FINISH %IF TARGET=EMAS %OR target=emasa %THEN %START %IF FFinfo(chan)_flags&X'07'#0 %THEN %START %IF FFinfo(chan)_Buftype#NoBufftype %THEN %START %IF FFinfo(chan)_Bufptr>0 %THEN Buff to File(chan,FFinfo(chan)_Bufadd,FFinfo(chan)_Bufptr) k=Free(FFinfo(chan)_Bufadd) %FINISH %FINISH Disconnect(FFinfo(chan)_fnm,k) %IF k#0 %THEN ICL9CAERRNO=216 %AND %RESULT=216 FFinfo(chan)_fnm="" %RESULT=0 %FINISH %END; {FCLOSE} %EXTERNAL %INTEGER %FN freopen %ALIAS "ICL9CAFREOPEN"(%INTEGER file,priv,Chan) !************************************************************************* !* !* FIRST CLOSES THE STREAM ASSOCIATED WITH CHAN AND ATTEMPTS TO OPEN !* THE NEW FILE AT THE SAME CHANNEL. !* !************************************************************************* %RECORD (FFm) r %STRING (255) Filename %INTEGER Flag,i,j,k,Conad,F,Mode %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=0 k=FCLOSE(Chan) flag=FLG(priv) %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,strlen(file) %CYCLE byteinteger(addr(Filename)+i)=ETOITAB(byteinteger(addr(Filename)+i)) %REPEAT %FINISH %IF TARGET=VME %THEN %START k=CCFOPEN(Chan,Flag,Filename) %IF k<0 %THEN flag=flag!X'08' {stream to be treated as binary} %IF k>0 %THEN ICL9CAERRNO=k %AND %RESULT=0 %FINISH %IF TARGET=EMAS %OR target=emasa %THEN %START %IF Flag&X'01'#0 %THEN %START Outfile(Filename,Filesize,0,0,Conad,F) %IF F#0 %THEN %RESULT=0 FFinfo(Chan)_Filelength=Filesize %IF Flag&X'08'=0 %THEN integer(Conad+12)=3 %ELSE integer(Conad+12)=4 %FINISH %ELSE %START %IF Flag&X'07'=0 %THEN Mode=1 %ELSE Mode=3 Connect(Filename,Mode,0,0,r,F) %IF F#0 %THEN %START %IF Flag&X'07'#0 %THEN %START Outfile(Filename,Filesize,0,0,Conad,F) %IF F#0 %THEN %RESULT=0 FFinfo(Chan)_Filelength=Filesize %IF Flag&X'08'=0 %THEN integer(Conad+12)=3 %ELSE integer(Conad+12)=4 %FINISH %ELSE OPEH(335,0,11,0) %FINISH %ELSE %START Conad=r_Conad %IF Flag&X'07'#0 %THEN %START j=integer(Conad)+4096 Change File Size(Filename,j,F) %IF F#0 %THEN OPEH(335,0,11,0) %FINISH FFinfo(Chan)_Filelength=integer(Conad+8) %FINISH %FINISH FFinfo(Chan)_Initcon=Conad FFinfo(Chan)_Conad=Conad+32 FFinfo(Chan)_fptr=Conad+32 %IF Flag&X'08'#0 %THEN FFinfo(Chan)_Buftype=Fullbufftype %ELSE FFinfo(Chan)_Buftype=LineBuffType %IF Bufsize=0 %THEN FFinfo(Chan)_Buftype=Nobufftype FFinfo(Chan)_Bufsize=Bufsize FFinfo(Chan)_Bufadd=Malloc(Bufsize) FFinfo(Chan)_Bufptr=0 FFinfo(Chan)_Dataend=Bufsize FFinfo(Chan)_Seekptr=Conad+32 %FINISH FFinfo(Chan)_Fnm=Filename FFinfo(Chan)_flags=Flag FFinfo(Chan)_eofmark=0 FFinfo(Chan)_errmark=0 FFinfo(Chan)_lastop=OPRDWR %RESULT=Chan %END; {FREOPEN} !*********************************************************************** !* * !* Emas Specific routines and function for I/O and files * !* * !*********************************************************************** %IF Target=EMAS %OR target=emasa %THEN %START %EXTERNAL %INTEGER %FN setvbuf %ALIAS "ICL9CASETVBUF"(%INTEGER Chan,buf,type,size) !*********************************************************************** !* * !* Set Buffer type, size and Buffer area for Chan * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN OPEH(211,0,11,0) %IF FFinfo(chan)_lastop#OPRDWR %THEN OPEH(334,0,11,0) FFinfo(chan)_Buftype=type %IF buf#0 %THEN %START FFinfo(chan)_Bufsize=size k=Free(FFinfo(chan)_Bufadd) FFinfo(chan)_Bufadd=buf %FINISH %RESULT=0 %END; {SETVBUF--(9.5.6)} %EXTERNAL %INTEGER %FN setbuf %ALIAS "ICL9CASETBUF"(%INTEGER Chan,buf) !*********************************************************************** !* * !* Specifies Buffer area and Buffer type * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN OPEH(211,0,11,0) %IF buf=0 %THEN k=Setvbuf(Chan,buf,0,0) %ELSE k=Setvbuf(Chan,buf,2,Bufsize) %RESULT=0 %END; {SETBUF} %ROUTINE Buff to File(%INTEGER chan,add,nchs) !*********************************************************************** !* * !* Transfer data from buffer to file * !* * !*********************************************************************** %INTEGER flag,newsize,m %IF FFinfo(chan)_fptr+nchs>FFinfo(chan)_Initcon+FFinfo(chan)_Filelength %THEN %START newsize=FFinfo(chan)_Filelength+4096 Change File Size(FFinfo(chan)_fnm,newsize,Flag) %IF Flag#0 %THEN OPEH(335,0,11,0) FFinfo(chan)_Filelength=newsize %FINISH move(nchs,add,FFinfo(chan)_fptr) FFinfo(chan)_fptr=FFinfo(chan)_fptr+nchs m=FFinfo(chan)_fptr-FFinfo(chan)_Initcon %IF m>integer(FFinfo(chan)_Initcon) %THEN integer(FFinfo(chan)_Initcon)=m FFinfo(chan)_Bufptr=0 %END; {Buff to File} %INTEGER %FN WRITE TEXT(%INTEGER chan,add,nchs) !*********************************************************************** !* * !* Transfer data from the user's address space to the I/O buffer * !* of a specified channel * !* * !*********************************************************************** %INTEGER Flag,i,j,k,l,m,n,c %SWITCH Btype(0:2) %IF FFinfo(chan)_lastop=OPRDWR %THEN %START %IF FFinfo(chan)_flags&X'07'=0 %THEN OPEH(220,0,11,0) %IF FFinfo(chan)_flags&X'02'#0 %THEN %START FFinfo(chan)_fptr=FFinfo(chan)_Initcon+integer(FFinfo(chan)_Initcon) %FINISH %ELSE FFinfo(chan)_fptr=FFinfo(chan)_Seekptr %FINISH FFinfo(chan)_lastop=OPWRITE ->Btype(FFinfo(chan)_Buftype) Btype(LineBuffType): {Line buffering used for streams} i=0 l=FFinfo(chan)_Bufadd+FFinfo(chan)_Bufsize %CYCLE k=FFinfo(chan)_Bufadd+FFinfo(chan)_Bufptr n=0 m=0 %WHILE k=l %THEN %START m=l-FFinfo(chan)_fptr Move(m,FFinfo(chan)_fptr,add) FFinfo(chan)_fptr=l %RESULT=m %FINISH %ELSE %START Move(nchs,FFinfo(chan)_fptr,add) FFinfo(chan)_fptr=FFinfo(chan)_fptr+nchs %RESULT=nchs %FINISH %END; {FILE TO BUFF} %IF FFinfo(chan)_eofmark=1 %THEN %RESULT=0 %IF FFinfo(chan)_lastop=OPRDWR %THEN %START %IF FFinfo(chan)_flags&X'01'#0 %THEN OPEH(330,0,11,0) FFinfo(chan)_fptr=FFinfo(chan)_Seekptr FFinfo(chan)_Bufptr=FFinfo(chan)_Bufsize %FINISH l=FFinfo(chan)_Initcon+integer(FFinfo(chan)_Initcon) %IF nchs+FFinfo(chan)_fptr<=l %THEN %START Move(nchs,FFinfo(chan)_fptr,add) FFinfo(chan)_fptr=FFinfo(chan)_fptr+nchs %RESULT=nchs %FINISH %ELSE %START m=l-FFinfo(chan)_fptr Move(m,FFinfo(chan)_fptr,add) FFinfo(chan)_fptr=l FFinfo(chan)_eofmark=1 %RESULT=m %FINISH %END; {READ TEXT} %FINISH; {Conditional compilation} %EXTERNAL %INTEGER %FN FFLUSH %ALIAS "ICL9CAFFLUSH"(%INTEGER chan) !*********************************************************************** !* * !* Write unwritten data to file defined by channel * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=300 %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND %RESULT=211 %IF Target=VME %THEN %START k=CCFFLUSH(Chan) %IF k=0 %THEN %RESULT=0 %ELSE %START ICL9CAERRNO=k %RESULT=k %FINISH %FINISH %IF Target=EMAS %OR target=emasa %THEN %START %IF FFinfo(chan)_lastop#OPWRITE %THEN %RESULT=0 %IF FFinfo(chan)_Buftype#Nobufftype %THEN %START %IF FFinfo(chan)_Bufptr>0 %THEN %START Buff to File(chan,FFinfo(chan)_Bufadd,FFinfo(chan)_Bufptr) FFinfo(chan)_Bufptr=0 %FINISH %FINISH %RESULT=0 %FINISH %END; {FFLUSH} %INTEGER %FN CHECKCHANO(%INTEGER Chan) !*********************************************************************** !* * !* check if chan is a valid channel number * !* and if an attempt to write after read is being made * !* * !*********************************************************************** %IF Chan#Stdout %THEN %START %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=300 %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND %RESULT=211 %IF FFinfo(Chan)_lastop=OPREAD %THEN %START %IF FFinfo(Chan)_eofmark#1 %THEN ICL9CAERRNO=303 %AND %RESULT=303 FFinfo(Chan)_eofmark=0 %FINISH %FINISH %RESULT=0 %END; {CHECKCHANO } %INTEGER %FN CHECKCHANI(%INTEGER Chan) !*********************************************************************** !* * !* check if chan is a valid channel number * !* and if an attempt to read after write is being made * !* * !*********************************************************************** %IF Chan#Stdin %THEN %START %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=300 %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND %RESULT=211 %IF FFinfo(Chan)_lastop=OPWRITE %THEN ICL9CAERRNO=302 %AND %RESULT=302 %FINISH %RESULT=0 %END; {CHECKCHANI } %EXTERNAL %INTEGER %FN FREAD %ALIAS "ICL9CAFREAD"(%INTEGER startadd,size,nelem,chan) !*********************************************************************** !* * !* Read from file pointed to by chan * !* * !*********************************************************************** %INTEGER i,j,k,length k=CHECKCHANI(Chan) %IF k#0 %THEN %RESULT=0 length=nelem*size %IF nelem=0 %OR size=0 %THEN %RESULT=0 %IF Target=VME %THEN k=READ DATA(chan,startadd,length) %ELSE k=READ TEXT(chan,startadd,length) %IF k>0 %THEN %START FFinfo(chan)_lastop=OPREAD %RESULT=k//size %FINISH %IF k=0 %THEN %START FFinfo(chan)_eofmark=1 %RESULT=0 %FINISH %ELSE %START ICL9CAERRNO=-k FFinfo(chan)_errmark=1 %RESULT=0 %FINISH %END; {FREAD} %EXTERNAL %INTEGER %FN FWRITE %ALIAS "ICL9CAFWRITE"(%INTEGER startadd,size,nelem,chan) !*********************************************************************** !* * !* Write to file pointed to by chan * !* * !*********************************************************************** %INTEGER i,j,k,length k=CHECKCHANO(Chan) %IF k#0 %THEN %RESULT=0 length=nelem*size %IF nelem=0 %OR size=0 %THEN %RESULT=0 %IF Target=VME %THEN k=WRITE DATA(chan,startadd,length) %ELSE k=WRITE TEXT(chan,startadd,length) %IF k<0 %THEN %START FFinfo(chan)_errmark=1 ICL9CAERRNO=-k %RESULT=0 %FINISH FFinfo(chan)_lastop=OPWRITE %RESULT=k//size %END; {FWRITE} %EXTERNAL %INTEGER %FN FSEEK %ALIAS "ICL9CAFSEEK"(%INTEGER chan,offset,ptrname) !*********************************************************************** !* * !* Sets the file position indicator for file chan * !* * !*********************************************************************** %INTEGER k,newsize,fp,flag %IF %NOT (3<=Chan<=80) %THEN ICL9CAERRNO=300 %AND %RESULT=300 %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND %RESULT=211 %IF Target=VME %THEN %START k=CCFSEEK(chan,offset,ptrname) %IF k\=0 %THEN ICL9CAERRNO=k %AND %RESULT=k FFinfo(chan)_lastop=OPRDWR %RESULT=0 %FINISH %IF Target=EMAS %OR target=emasa %THEN %START k=FFlush(chan) %IF FFinfo(chan)_flags&X'08'=0 %THEN %START fp=FFinfo(chan)_Conad+offset %FINISH %ELSE %START %IF ptrname=Seekset %THEN fp=FFinfo(chan)_Conad+offset %IF ptrname=Seekcur %THEN fp=FFinfo(chan)_fptr+offset %IF ptrname=Seekend %THEN %START fp=FFinfo(chan)_Initcon+integer(FFinfo(chan)_Initcon)+offset %FINISH %FINISH %IF fp<0 %THEN OPEH(226,0,11,0) %IF fp>FFinfo(chan)_Initcon+FFinfo(chan)_Filelength %THEN %START newsize=(fp+4095)&X'FFFFF000' Change file size(FFinfo(chan)_fnm,newsize,Flag) %IF Flag#0 %THEN OPEH(335,0,11,0) FFinfo(chan)_Filelength=newsize %FINISH FFinfo(chan)_Seekptr=fp FFinfo(Chan)_lastop=OPRDWR %RESULT=0 %FINISH %END; {FSEEK} %EXTERNAL %INTEGER %FN FTELL %ALIAS "ICL9CAFTELL"(%INTEGER chan) !*********************************************************************** !* * !* Obtains the current value of file position * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND OPEH(211,0,11,0) %IF Target=VME %THEN %START k=CCFTELL(Chan) %IF k<0 %THEN ICL9CAERRNO=-k %AND OPEH(-k,0,11,0) %RESULT=k %FINISH %IF target=EMAS %OR target=emasa %THEN %START k=FFlush(chan) %RESULT=FFinfo(chan)_fptr-FFinfo(chan)_Conad %FINISH %END; {FTELL} %EXTERNAL %INTEGER %FN REWIND %ALIAS "ICL9CAREWIND"(%INTEGER chan) !*********************************************************************** !* * !* Sets file position pointer to zero * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND OPEH(211,0,11,0) k=FSEEK(chan,0,0) %IF k\=0 %THEN ICL9CAERRNO=k %AND OPEH(k,0,11,0) FFinfo(Chan)_eofmark=0 FFinfo(Chan)_errmark=0 FFinfo(Chan)_lastop=OPRDWR %RESULT=0 %END; {REWIND} %EXTERNAL %INTEGER %FN CLEARERR %ALIAS "ICL9CACLEARERR"(%INTEGER chan) !*********************************************************************** !* * !* Resets end-of-file and error indicators for defined stream * !* * !*********************************************************************** %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm\="" %THEN %START FFinfo(Chan)_eofmark=0 FFinfo(Chan)_errmark=0 %FINISH %RESULT=0 %END; {CLEARERR} %EXTERNAL %INTEGER %FN FEOF %ALIAS "ICL9CAFEOF"(%INTEGER chan) !*********************************************************************** !* * !* Test end-of-file indicator * !* * !*********************************************************************** %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %RESULT=FFinfo(Chan)_eofmark %END; {FEOF} %EXTERNAL %INTEGER %FN FERROR %ALIAS "ICL9CAFERROR"(%INTEGER chan) !*********************************************************************** !* * !* Tests Read/Write error indicator * !* * !*********************************************************************** %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %RESULT=FFinfo(Chan)_errmark %END; {FERROR} %IF target=VME %THEN %START %EXTERNAL %INTEGER %FN PERROR %ALIAS "ICL9CAPERROR"(%INTEGER s) !*********************************************************************** !* * !* Maps error number to an error message and optionally prints it * !* * !*********************************************************************** %EXTERNAL %INTEGER %FUNCTION %SPEC iocp %ALIAS "S#IOCP"(%INTEGER ep,parm) %STRING (255) text %INTEGER i,len,k %IF s=Nul %THEN text="" %ELSE %START len=strlen(s) byteinteger(addr(text))=len %FOR i=1,1,len %CYCLE byteinteger(addr(text)+i)=ETOITAB(byteinteger(s+i-1)) %REPEAT %FINISH k=CC STRERROR(text) %IF text#"" %THEN %START i=iocp(18,0) {temporarily select channel 81} printstring(string(k)) i=iocp(19,0) {select back to current channel} %RESULT=0 %FINISH %ELSE %START len=byteinteger(k) %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,len %CYCLE byteinteger(k+i)=ITOETAB(byteinteger(k+i)) %REPEAT %FINISH %FINISH byteinteger(k+len+1)=0 %RESULT=k+1 %END; {PERROR} %FINISH {conditional compilation} %IF Target=EMAS %OR target=emasa %THEN %START %EXTERNAL %INTEGER %FN tmpnam %ALIAS "ICL9CATMPNAM"(%INTEGER adstr) !*********************************************************************** !* * !* Generate a string to be used as a temporary ffile name * !* * !*********************************************************************** %STRING (26) tname %INTEGER c,i tname="T#CC".ITOS(Rand) byteinteger(addr(tname)+length(tname))=Nul %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,25 %CYCLE byteinteger(addr(tname)+i)=ITOETAB(byteinteger(addr(tname)+i)) %REPEAT %FINISH %IF adstr=Nul %THEN tempfilename=tname %AND %RESULT=addr(tempfilename)+1 i=0 %CYCLE c=byteinteger(addr(tname)+i+1) byteinteger(adstr+i)=c i=i+1 %REPEAT %UNTIL c=Nul %RESULT=adstr %END; {TMPNAM --(9.4.4)} %EXTERNAL %INTEGER %FN remove %ALIAS "ICL9CAREMOVE"(%INTEGER ptr) !*********************************************************************** !* * !* Remove the file * !* * !*********************************************************************** %INTEGER adr,i,l %STRING (255) mid l=strlen(ptr) adr=addr(mid) %FOR i=1,1,l %CYCLE byteinteger(adr+i)=byteinteger(ptr+i-1) %REPEAT byteinteger(adr)=l %IF target=emasa %THEN destroy(mid,i) %ELSE DESTROY(mid) %RESULT=0 %END; {REMOVE--(9.4.1)} %EXTERNAL %INTEGER %FN renam %ALIAS "ICL9CARENAME"(%INTEGER old,new) !*********************************************************************** !* * !* Rename a file * !* * !*********************************************************************** %INTEGER adr,adr1,flag %STRING (255) mid,mida %STRING (2) comma comma=",," byteinteger(addr(comma)+2)=0 adr=addr(mid); byteinteger(adr)=0 adr1=adr+1; byteinteger(adr1)=0 adr1=strcat(adr1,old) adr1=strcat(adr1,addr(comma)+1) adr1=strcat(adr1,new) byteinteger(adr)=strlen(adr1) %IF target=emasa %START mid->mid.(",").mida REname(Mid,Mida,flag) %FINISH %ELSE RENAME(mid) %RESULT=0 %END; {RENAME--(9.4.2)} %EXTERNAL %INTEGER %FN tmpfile %ALIAS "ICL9CATMPFILE" !*********************************************************************** !* * !* Create a temporary binary file * !* * !*********************************************************************** %STRING (3) fl %STRING (26) tmpstr %INTEGER name,afl name=addr(tmpstr)+1 fl="w+b" afl=addr(fl)+1 byteinteger(afl+3)=0 name=tmpnam(name) printstring("tmpfile:"); write(name,11); write(afl,11); newline %RESULT=FOPEN(name,afl) %END; {TMPFILE--(9.4.3)} %FINISH; {Conditional compilation} !*********************************************************************** !* * !* VME specific routines and functions * !* * !*********************************************************************** %IF target=VME %THEN %START %STRING (19) %FN LITOS(%LONG %INTEGER CPU CLOCK) !*********************************************************************** !* * !* Generate unique number using READ CPU CLOCK for TMPNAM * !* * !*********************************************************************** %STRING (19) result *LD_result *MVL_ %L =1,0,19 *STD_ %TOS *LSD_cpu clock *CDEC_0 *DSH_12 *MPSR_X'24' *SUPK_ %L =19 *LD_ %TOS *MVL_ %L =19,31,32 %RESULT=result %END; {LITOS} %EXTERNAL %INTEGER %FN tmpnam %ALIAS "ICL9CATMPNAM"(%INTEGER adstr) !*********************************************************************** !* * !* Generate a string to be used as a temporary ffile name * !* * !*********************************************************************** %STRING (26) tname %INTEGER i tname="ICL9CA".LITOS(Read Cpu Clock) byteinteger(addr(tname)+26)=Nul %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,25 %CYCLE byteinteger(addr(tname)+i)=ITOETAB(byteinteger(addr(tname)+i)) %REPEAT %FINISH %IF adstr=Nul %THEN tempfilename=tname %AND %RESULT=addr(tempfilename)+1 i=0 %CYCLE byteinteger(adstr+i)=byteinteger(addr(tname)+i+1) i=i+1 %REPEAT %UNTIL i=26 %RESULT=adstr %END; {TMPNAM --(9.4.4)} %EXTERNAL %INTEGER %FN remove %ALIAS "ICL9CAREMOVE"(%INTEGER file) !*********************************************************************** !* * !* Destroy the file whose name is pointed to by file * !* * !*********************************************************************** %STRING (255) Filename %INTEGER len,i,k len=strlen(file) byteinteger(addr(Filename))=len %FOR i=1,1,len %CYCLE byteinteger(addr(Filename)+i)=ETOITAB(byteinteger(file+i-1)) %REPEAT %IF Filename="" %THEN %RESULT=0 k=CC REMOVE(Filename) %IF k#0 %THEN ICL9CAERRNO=k %AND %RESULT=k %RESULT=0 %END; {REMOVE --(9.4.1)} %EXTERNAL %INTEGER %FN rename %ALIAS "ICL9CARENAME"(%INTEGER oldfile,newfile) !*********************************************************************** !* * !* Change name of oldfile to newfile * !* * !*********************************************************************** %STRING (255) Old,New %INTEGER leno,lenn,i,k leno=strlen(oldfile) lenn=strlen(newfile) byteinteger(addr(Old))=leno %FOR i=1,1,leno %CYCLE byteinteger(addr(Old)+i)=ETOITAB(byteinteger(oldfile+i-1)) %REPEAT byteinteger(addr(New))=lenn %FOR i=1,1,lenn %CYCLE byteinteger(addr(New)+i)=ETOITAB(byteinteger(newfile+i-1)) %REPEAT %IF Old="" %THEN %RESULT=0 k=CC RENAME(Old,New) %IF k#0 %THEN ICL9CAERRNO=k %AND %RESULT=k %RESULT=0 %END; {RENAME --(9.4.2)} %EXTERNAL %INTEGER %FN tmpfile %ALIAS "ICL9CATMPFILE" !*********************************************************************** !* * !* Open a temporary file * !* * !*********************************************************************** %INTEGER k,key key=81 %FOR k=80,-1,3 %CYCLE %IF FFinfo(k)_fnm="" %THEN key=k %REPEAT %IF key=81 %THEN ICL9CAERRNO=304 %AND %RESULT=0 k=CC TMPFILE(key) %IF k#0 %THEN ICL9CAERRNO=k %AND %RESULT=0 FFinfo(key)_fnm="##TMP".itos(key) FFinfo(key)_flags=X'0C' Ffinfo(key)_eofmark=0 FFinfo(key)_errmark=0 FFinfo(key)_lastop=OPRDWR %RESULT=key %END; {TMPFILE --(9.4.3)} %EXTERNAL %INTEGER %FN system %ALIAS "ICL9CASYSTEM"(%INTEGER str) !*********************************************************************** !* * !* Execute command pointed to by str * !* * !*********************************************************************** %STRING (255) Command %INTEGER len,i,k len=strlen(str) byteinteger(addr(Command))=len %FOR i=1,1,len %CYCLE byteinteger(addr(Command)+i)=byteinteger(str+i-1) %REPEAT k=EXECUTE(Command) %RESULT=k %END; {SYSTEM --(10.4.5)} %EXTERNAL %INTEGER %FN setbuf %ALIAS "ICL9CASETBUF"(%INTEGER chan,bufptr) !*********************************************************************** !* * !* Set buffering information * !* * !*********************************************************************** %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND OPEH(211,0,11,0) %IF FFinfo(chan)_lastop#OPRDWR %THEN ICL9CAERRNO=229 %AND OPEH(229,0,11,0) CC SETBUF(chan,bufptr) %RESULT=0 %END; {SETBUF --(9.5.5)} %EXTERNAL %INTEGER %FN setvbuf %ALIAS "ICL9CASETVBUF"(%INTEGER chan,bufptr,type,size) !*********************************************************************** !* * !* Set buffering info * !* * !*********************************************************************** %INTEGER k %IF %NOT (3<=Chan<=80) %THEN OPEH(300,0,11,0) %IF FFinfo(chan)_fnm="" %THEN ICL9CAERRNO=211 %AND %RESULT=211 %IF FFinfo(chan)_lastop#OPRDWR %THEN ICL9CAERRNO=229 %AND %RESULT=229 k=CC SETVBUF(chan,bufptr,type,size) %IF k\=0 %THEN ICL9CAERRNO=k %AND %RESULT=k %RESULT=0 %END; {SETVBUF --(9.5.6)} %FINISH {conditional compilation} %ROUTINE %SPEC WRITE OUT(%INTEGER chan,add,nchs) %ROUTINE OutString !***************************************************************** !* !* OUTPUTS A STRING TO STDOUT. !* !***************************************************************** %BYTE %INTEGER %ARRAY OutSide(0:500) %INTEGER i,j,k %IF byteinteger(ConAdIO+PtrIO)=Nul %THEN %RETURN i=0 %IF ChanIO\=StdOut %THEN %START %WHILE byteinteger(ConAdIO+PtrIO)\=Nul %CYCLE %IF byteinteger(ConAdIO+PtrIO)='%' %THEN %START %IF byteinteger(ConAdIO+PtrIO+1)='%' %THEN %START PtrIO=PtrIO+1 %FINISH %ELSE %START PtrIO=PtrIO+1 %IF i\=0 %THEN ->pushfile %ELSE %RETURN %FINISH %FINISH OutSide(i)=byteinteger(ConAdIO+PtrIO) i=i+1 PtrIO=PtrIO+1 %REPEAT pushfile: WRITE OUT(ChanIO,addr(Outside(0)),i) %FINISH %ELSE %START %WHILE byteinteger(ConAdIO+PtrIO)\=Nul %CYCLE %IF byteinteger(ConAdIO+PtrIO)='%' %THEN %START %IF byteinteger(ConAdIO+PtrIO+1)='%' %THEN %START PtrIO=PtrIO+1 %FINISH %ELSE %START PtrIO=PtrIO+1 %RETURN %FINISH %FINISH printch(byteinteger(ConAdIO+PtrIO)) PtrIO=PtrIO+1 %REPEAT %FINISH %END; {OUTSTRING} %STRING (255) %FN Getform(%INTEGER %NAME d) !************************************************************************** !* !* GETS CONTROL STRING FOR A PRINT. !* !************************************************************************ %STRING (255) str %INTEGER sb %SWITCH SelPrint(0:255) str="" sb=0 %CYCLE ->SelPrint(byteinteger(ConAdIO+PtrIO)) SelPrint(']'): sb=0 str=str.tostring(']') SelPrint('d'): SelPrint('i'): SelPrint('o'): SelPrint('u'): SelPrint('x'): SelPrint('X'): SelPrint('f'): Selprint('e'): SelPrint('E'): SelPrint('g'): SelPrint('G'): SelPrint('c'): SelPrint('s'): SelPrint('p'): SelPrint('n'): %IF sb=0 %THEN %START d=byteinteger(ConAdIO+PtrIO) PtrIO=PtrIO+1 %RESULT=str %FINISH %ELSE ->SelPrint('#') SelPrint('['): sb=1 SelPrint('0'): SelPrint('1'): SelPrint('2'): SelPrint('3'): SelPrint('4'): SelPrint('5'): SelPrint('6'): SelPrint('7'): SelPrint('8'): SelPrint('9'): SelPrint('-'): SelPrint('+'): SelPrint(' '): SelPrint('.'): SelPrint('l'): SelPrint('L'): SelPrint('h'): SelPrint('#'): str=str.To String(byteinteger(ConAdIO+PtrIO)) PtrIO=PtrIO+1 ->endit SelPrint(*): %IF sb=1 %THEN ->SelPrint('#') d=byteinteger(ConAdIO+PtrIO) %IF d\=Nul %THEN PtrIO=PtrIO+1 %RESULT=str endit: %REPEAT %END; {GETFORM} %ROUTINE DECODE FORMAT(%INTEGER adstr) !*********************************************************************** !* * !* decode print format * !* * !*********************************************************************** %SWITCH Formatflag(0:255) %INTEGER intflag,ptr,nch,l %INTEGER %FN GETNUM %INTEGER nval nval=0 %WHILE '0'<=nch<='9' %CYCLE nval=10*nval+nch&15 ptr=ptr+1 nch=byteinteger(adstr+ptr) %REPEAT %RESULT=nval %END; {GETNUM} pad=' ' Ljst=Unset Strsize=Default Field=Default Pluset=Unset Spset=Unset Hashset=Unset ptr=1 intflag=0 %WHILE intflag=0 %CYCLE nch=byteinteger(adstr+ptr) ->Formatflag(nch) Formatflag('-'): Ljst=Set; ->incptr Formatflag('+'): Pluset=Set; ->incptr Formatflag(' '): Spset=Set; ->incptr Formatflag('#'): Hashset=Set; ->incptr Formatflag('l'): Formatflag('L'): Formatflag('h'): incptr: ptr=ptr+1; ->endflag Formatflag('0'): pad='0' Formatflag('1'): Formatflag('2'): Formatflag('3'): Formatflag('4'): Formatflag('5'): Formatflag('6'): Formatflag('7'): Formatflag('8'): Formatflag('9'): intflag=1; ->endflag Formatflag(Nul): intflag=-1; ->endflag Formatflag('.'): intflag=2 ptr=ptr+1 nch=byteinteger(adstr+ptr) ->endflag Formatflag(*): endflag: %REPEAT %IF intflag<0 %THEN %RETURN %IF intflag=1 %THEN %START l=GETNUM %IF l>0 %THEN Field=l %WHILE nch=' ' %CYCLE ptr=ptr+1 nch=byteinteger(adstr+ptr) %REPEAT %IF nch#'.' %THEN %RETURN ptr=ptr+1 nch=byteinteger(adstr+ptr) %FINISH l=GETNUM %IF l>=0 %THEN Strsize=l %RETURN %END; {DECODE FORMAT} %ROUTINE WRITE OUT(%INTEGER Chan,add,nchs) !*********************************************************************** !* * !* Write text to appropiate output channel or string * !* * !*********************************************************************** %INTEGER i,k %IF Chan#Stdout %THEN %START %IF ModeIO#SFPrintf %THEN %START k=WRITE TEXT(Chan,add,nchs) %IF k<0 %THEN OPEH(-k,0,11,0) %FINISH %ELSE %START Move(nchs,add,restr+resptr) resptr=resptr+nchs %FINISH %FINISH %ELSE %START Select Output(0) %FOR i=0,1,nchs-1 %CYCLE printch(byteinteger(add+i)) %REPEAT %FINISH Outchars=Outchars+nchs %END; {WRITE OUT} %ROUTINE printd(%INTEGER adstr,value) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %INTEGER len,i,k,nch,Sgn %IF value<0 %THEN StrNum=ItoS(-value) %ELSE StrNum=ItoS(value) len=length(StrNum) DECODEFORMAT(adstr) Sgn=Unset %IF value<0 %THEN Strnum="-".Strnum %AND Sgn=Set %ELSE %IF Pluset=Set %THEN %C Strnum="+".Strnum %AND Sgn=Set %ELSE %IF Spset=Set %THEN Strnum=" ".Strnum Integerf(Sgn) WRITE OUT(ChanIO,Ares,Inptr) %END; {PRINTd} %ROUTINE printi(%INTEGER adstr,value) !*********************************************************************** !* * !* PRINTS VALUE ---same as PRINTD----- * !* * !*********************************************************************** printd(adstr,value) %END; {PRINTi} %ROUTINE printo(%INTEGER adstr,value) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %BYTE %INTEGER %ARRAY b(0:11) %INTEGER j,k b(11-j)=(value>>(3*j)&X'07')+'0' %FOR j=10,-1,0 j=1 %WHILE b(j)='0' %AND j<11 %CYCLE j=j+1 %REPEAT b(j-1)=12-j StrNum=String(addr(b(j-1))) DECODE FORMAT(adstr) %IF HashSet=Set %THEN %START StrNum="0".Strnum %FINISH IntegerF(Unset) WRITE OUT(ChanIO,Ares,Inptr) %END; {PRINTo} %ROUTINE printu(%INTEGER adstr,value) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %LONG %INTEGER l,m %INTEGER i,rem,k integer(addr(l))=0 integer(addr(l)+4)=value m=l//10 rem=l-10*m Strnum=ITOS(m).Tostring(rem+'0') DECODE FORMAT(adstr) Pluset=Unset IntegerF(Unset) WRITE OUT(ChanIO,Ares,Inptr) %END; {PRINTu} %ROUTINE printx(%INTEGER adstr,value,e) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %BYTE %INTEGER %ARRAY b(0:8) %BYTE %INTEGER x,c %INTEGER i,j,k %IF e='X' %THEN c='A' %ELSE c='a' %FOR j=7,-1,0 %CYCLE x=(value>>(4*j)&X'0F') %IF x>9 %THEN b(8-j)=x+c-10 %ELSE b(8-j)=x+'0' %REPEAT j=1 %WHILE b(j)='0' %AND j<8 %CYCLE j=j+1 %REPEAT b(j-1)=9-j StrNum=String(addr(b(j-1))) DECODE FORMAT(adstr) %IF HashSet=Set %THEN %START StrNum="0".Tostring(e).Strnum %FINISH IntegerF(Unset) WRITE OUT(ChanIO,Ares,Inptr) %END; {PRINTx} %ROUTINE printf(%INTEGER adstr, %LONG %REAL value) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %LONG %REAL Round,Z,X,Y %INTEGER Stad,Add,I,M,N,Sign,L,J,Sgn,hold,len,nch,k %BYTE %INTEGER %ARRAY tempBuff(0:63) Add=addr(tempbuff(1)) Stad=Add DECODE FORMAT(adstr) %IF Strsize=Default %THEN Strsize=6 X=value X=X+DZ M=StrSize Sgn=Unset Sign=0 %IF X<0 %THEN Sign='-' %ELSE %IF Pluset=Set %THEN Sign='+' %ELSE %IF Spset=Set %THEN Sign=' ' %IF sign#0 %THEN Sgn=set Y=MOD(X) Round=0.5/R'41A0000000000000'**M { Rounding factor } I=0 Z=1 Y=Y+Round %CYCLE I=I+1 Z=10*Z %REPEAT %UNTIL Z>Y %IF Sign#0 %THEN %START Byteinteger(Add)=Sign Add=Add+1 %FINISH J=I-1 Z=R'41A0000000000000'**J %CYCLE %CYCLE L=Intpt(Y/Z) Y=Y-L*Z Z=Z/10 Byteinteger(Add)=L+'0' Add=Add+1 J=J-1 %REPEAT %UNTIL J<0 %IF M=0 %THEN %START Byteinteger(Add)='.' Add=Add+1 M=-1 %FINISH %IF M=-1 %THEN %START tempbuff(0)=Add-Stad StrNum=String(addr(tempbuff(0))) StrSize=Default IntegerF(Sgn) WRITE OUT(ChanIO,Ares,Inptr) %RETURN %FINISH byteinteger(Add)='.' Add=Add+1 J=M-1 Z=R'41A0000000000000'**(J-1) M=-1 Y=10*Y*Z %REPEAT %END; {PRINTf} %ROUTINE printe(%INTEGER adstr, %LONG %REAL value, %INTEGER e) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %LONG %REAL Round,Factor,Lb,Ub,X,Y %INTEGER Stad,Add,Count,Inc,Sign,L,J,Sgn,hold,len,k,i %BYTE %INTEGER %ARRAY tempBuff(0:63) DECODE FORMAT(adstr) %IF Strsize=Default %THEN Strsize=6 hold=Strsize Add=addr(tempbuff(1)) Stad=Add Round=0.5/R'41A0000000000000'**hold Lb=1-Round; Ub=10-Round Sign=0 X=value+DZ Y=X Sgn=Unset %IF X=0 %THEN Count=0 %ELSE %START %IF X<0 %THEN %START Sgn=Set X=-X Sign='-' %FINISH %ELSE %START %IF Pluset=Set %THEN Sign='+' %AND Sgn=Set %ELSE %IF Spset=Set %THEN Sign=' ' %FINISH Inc=1 Count=0 Factor=R'401999999999999A' %IF X<=1 %THEN Factor=10 %AND Inc=-1 %WHILE X=Ub %CYCLE X=X*Factor Count=Count+Inc %REPEAT %FINISH X=X+Round %IF Sign#0 %THEN %START Byteinteger(Add)=Sign Add=Add+1 %FINISH %IF hold<0 %THEN ->Outexp L=IntPt(X) ByteInteger(Add)=L+'0' Add=Add+1 %IF hold>0 %THEN %START ByteInteger(Add)='.' Add=Add+1 %FINISH J=1 %WHILE J<=hold %CYCLE X=(X-L)*10 L=Intpt(X) Byteinteger(Add)=L+'0' Add=Add+1 J=J+1 %REPEAT OutExp: Byteinteger(Add)=e Add=Add+1 %IF Count>=0 %THEN Sign='+' %ELSE %START Sign='-' Count=-Count %FINISH Byteinteger(Add)=Sign J=Count//10 Byteinteger(Add+1)=J+'0' Byteinteger(Add+2)=Count-10*J+'0' tempbuff(0)=(Add+3)-StAd StrNum=String(addr(tempbuff(0))) StrSize=Default IntegerF(Sgn) WRITE OUT(ChanIO,Ares,Inptr) %END; {PRINTe} %ROUTINE printg(%INTEGER adstr, %LONG %REAL value, %INTEGER e) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** DECODE FORMAT(adstr) %IF strsize=Default %THEN Strsize=6 %IF mod(value)<0.0001 %OR mod(value)>10\\Strsize %THEN printe(adstr,value,e) %ELSE printf(adstr,value) %END; {PRINTg} %ROUTINE printc(%INTEGER adstr,value) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %INTEGER new,k new=value&255 %IF CHCODE=EBCDIC %THEN new=ETOITAB(value) WRITE OUT(ChanIO,addr(new)+3,1) %END; {PRINTc} %ROUTINE prints(%INTEGER adcon,adstr) !*********************************************************************** !* * !* PRINTS VALUE * !* * !*********************************************************************** %INTEGER i,j,k,l,m,n,b,len %INTEGER Cfield,Cstrsize,Cljst DECODE FORMAT(adcon) len=strlen(adstr) %IF Strsize#Default %AND Strsizesflag(nch) sflag(' '): sflag(HT): sflag(NL): ->incptr sflag('*'): Noassign=Set; ->incptr sflag(Nul): flag=-1; ->endflag sflag('0'): sflag('1'): sflag('2'): sflag('3'): sflag('4'): sflag('5'): sflag('6'): sflag('7'): sflag('8'): sflag('9'): flag=1; ->endflag sflag(*): incptr: ptr=ptr+1 endflag: %REPEAT %IF flag=1 %THEN %START nval=0 %WHILE '0'<=nch<='9' %CYCLE nval=10*nval+nch&15 ptr=ptr+1 nch=byteinteger(adstr+ptr) %REPEAT %IF nval>0 %THEN Infield=nval %FINISH %RETURN %END; {DECODE S FORMAT} %ROUTINE scand(%INTEGER stradd,resadd) !*********************************************************************** !* * !* READS IN DECIMAL NUMBER. * !* * !*********************************************************************** %INTEGER i,val,cnt,p %BYTE %INTEGER %ARRAY DBuff(0:31) DECODE S FORMAT(stradd) cnt=0 %CYCLE RC(p) %REPEAT %UNTIL iswspace(p)=0 %IF p='-' %OR p='+' %THEN %START cnt=cnt+1 Dbuff(cnt)=p RC(p) %FINISH %WHILE cntCallPrint(d) CallPrint('d'): ival=int(value) printd(addr(str),ival) Outstring %RETURN CallPrint('f'): printf(addr(str),value) OutString %RETURN CallPrint('e'): printe(addr(str),value,'e') OutString %RETURN CallPrint('E'): printe(addr(str),value,'E') OutString %RETURN CallPrint('g'): printg(addr(str),value,'e') OutString %RETURN CallPrint('G'): printg(addr(str),value,'E') OutString %RETURN CallPrint(*): ICL9CAERRNO=305; OPEH(305,0,11,0) %END; {GIVDOUB} %EXTERNAL %INTEGER %FN endio %ALIAS "ICL9CAENDIO" !*********************************************************************** !* * !* TERMINATES AN I/O CALL. * !* * !*********************************************************************** %INTEGER i,k %IF CHCODE=EBCDIC %THEN i=Free(ebadr) %IF ModeIO=Cscanf %OR ModeIO=CFscanf %THEN k=Inchars %ELSE %IF %C ModeIO=CFprintf %OR ModeIO=Cprintf %OR ModeIO=SFPrintf %THEN k=Outchars %ELSE k=0 %IF ModeIO=SFPrintf %THEN %START %IF CHCODE=EBCDIC %THEN %START %FOR i=0,1,resptr-1 %CYCLE byteinteger(restr+i)=ITOETAB(byteinteger(restr+i)) %REPEAT %FINISH byteinteger(restr+resptr)=Nul %FINISH %RESULT=k %END; {ENDIO} %EXTERNAL %ROUTINE givint %ALIAS "ICL9CAGIVINT"(%INTEGER value) !*********************************************************************** !* * !* INTEGER PASSED TO PRINTF FUNCTIONS. * !* * !*********************************************************************** %SWITCH CallPrint(0:255) %SWITCH CallScan(0:255) %STRING (255) str %INTEGER d,j,m,l,rptr str="" d=' ' %IF byteinteger(ConAdIO+PtrIO)=Nul %THEN %RETURN %IF ModeIO=CPrintf %OR ModeIO=CFPrintf %OR ModeIO=SFPrintf %THEN %START rptr=Ptrio str=Getform(d) %IF d='*' %THEN %START; ! code to deal with * in format string str=ITOS(value) l=length(str) %IF l>1 %THEN %START j=ConadIO+strlen(ConadIO) %WHILE j>=ConadIO+PtrIO %CYCLE byteinteger(j+l-1)=byteinteger(j) j=j-1 %REPEAT %FINISH m=ConadIO+PtrIO-2 %FOR j=1,1,l %CYCLE byteinteger(m+j)=Charno(str,j) %REPEAT PtrIO=rptr %RETURN %FINISH str=str.To String(Nul) ->CallPrint(d) CallPrint('d'): printd(addr(str),value) OutString %RETURN CallPrint('i'): printi(addr(str),value) OutString %RETURN CallPrint('o'): printo(addr(str),value) OutString %RETURN CallPrint('u'): printu(addr(str),value) OutString %RETURN CallPrint('x'): printx(addr(str),value,'x') OutString %RETURN CallPrint('X'): printx(addr(str),value,'X') OutString %RETURN CallPrint('f'): printf(addr(str),value) OutString %RETURN CallPrint('e'): printe(addr(str),value,'e') OutString %RETURN CallPrint('E'): printe(addr(str),value,'E') OutString %RETURN CallPrint('g'): printg(addr(str),value,'e') OutString %RETURN CallPrint('G'): printg(addr(str),value,'E') OutString %RETURN CallPrint('c'): printc(addr(str),value) OutString %RETURN CallPrint('s'): %IF target=emasa %START %IF dvalidate(value,16,0)=0 %THEN ->prstring %ELSE *LDTB_X'18000010' *LDA_value *VAL_(%LNB +1) *JCC_12, %FINISH ICL9CAERRNO=306; OPEH(306,0,11,0) prstring: prints(addr(str),value) OutString %RETURN CallPrint('p'): printp(addr(str),value) OutString %RETURN CallPrint('n'): printn(value) OutString %RETURN CallPrint(*): %RETURN %FINISH %ELSE %START str=Getform(d) str=str.To String(Nul) ->CallScan(d) CallScan('E'): CallScan('G'): CallScan('e'): CallScan('f'): CallScan('g'): scanefg(addr(str),value) InString %RETURN CallScan('x'): CAllScan('X'): scanx(addr(str),value) InString %RETURN CallScan('i'): scani(addr(str),value) InString %RETURN CallScan('d'): scand(addr(str),value) InString %RETURN CallScan('o'): scano(addr(str),value) InString %RETURN CallScan('s'): scans(addr(str),value) InString %RETURN CallScan('u'): scanu(addr(str),value) Instring %RETURN CallScan('c'): scanc(addr(str),value) InString %RETURN CallScan('p'): scanp(addr(str),value) InString %RETURN CallScan('n'): scann(value) Instring %RETURN CallScan(']'): scansb(addr(str),value) Instring %RETURN CallScan(*): %RETURN %FINISH %END; {GIVINT} %ROUTINE Convert Format String(%INTEGER str) !*********************************************************************** !* * !* Convert output format string from Ebcdic to Iso * !* * !*********************************************************************** %INTEGER i,len,c len=strlen(str) ebadr=Malloc(len+10) %FOR i=0,1,len-1 %CYCLE c=byteinteger(str+i) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) byteinteger(ebadr+i)=c %REPEAT byteinteger(ebadr+len)=Nul ConadIO=ebadr %END; {CONVERT FORMAT STRING} %EXTERNAL %ROUTINE printff %ALIAS "ICL9CAPRINTF"(%INTEGER adstr) !*********************************************************************** !* * !* NOTE CONTROL STRING FOR PRINTF. * !* * !*********************************************************************** Convert Format String(adstr) ModeIO=CPrintf ChanIO=StdOut PtrIO=0 OutString FFinfo(ChanIO)_lastop=OPWRITE Outchars=0 %END; {PRINTF} %EXTERNAL %ROUTINE fprintf %ALIAS "ICL9CAFPRINTF"(%INTEGER chan,adstr) !*********************************************************************** !* * !* FORMATTED PRINT * !* * !*********************************************************************** %INTEGER k Convert Format String(adstr) ModeIO=CFPrintf ChanIO=chan k=CHECKCHANO(ChanIO) PtrIO=0 OutString FFinfo(ChanIO)_lastop=OPWRITE outchars=0 %END; {FPRINTF} %EXTERNAL %ROUTINE scanff %ALIAS "ICL9CASCANF"(%INTEGER stradd) !*********************************************************************** !* * !* CALLED TO INITIATE SCANF. * !* * !*********************************************************************** Convert Format String(stradd) ModeIO=CScanf ChanIO=StdIn PtrIO=0 Instring FFinfo(ChanIO)_lastop=OPREAD Inchars=0 %END; {SCANF} %EXTERNAL %ROUTINE fscanf %ALIAS "ICL9CAFSCANF"(%INTEGER Chan,stradd) !*********************************************************************** !* * !* CALLED TO INITIATE FSCANF. * !* * !*********************************************************************** %INTEGER k Convert Format String(stradd) ModeIO=CFScanf ChanIO=Chan k=CHECKCHANI(ChanIO) PtrIO=0 Instring FFinfo(ChanIO)_lastop=OPREAD Inchars=0 %END; {FSCANF} %EXTERNAL %ROUTINE sprintf %ALIAS "ICL9CASPRINTF"(%INTEGER resadd,stradd) !*********************************************************************** !* * !* Same as printf except output to string * !* * !*********************************************************************** Convert Format String(stradd) resptr=0 restr=resadd ModeIO=SFPrintf PtrIO=0 ChanIO=-1 Outstring Outchars=0 %END; {SPRINTF} %EXTERNAL %ROUTINE sscanf %ALIAS "ICL9CASSCANF"(%INTEGER resadd,stradd) !*********************************************************************** !* * !* Called to initiate sscanf * !* * !*********************************************************************** Convert Format String(stradd) resptr=0 restr=resadd ModeIO=SFScanf PtrIO=0 ChanIO=-1 Inchars=0 %END; {SSCANF} { (9.7) CHARACTER HANDLING INPUT/OUTPUT FUNCTIONS } %EXTERNAL %INTEGER %FN fgetc %ALIAS "ICL9CAFGETC"(%INTEGER chan) !*********************************************************************** !* * !* READS IN UNSIGNED CHAR AND CONVERTS IT TO AN INTEGER. * !* * !*********************************************************************** %INTEGER i,k,c ChanIO=Chan k=CHECKCHANI(Chan) RC(c) FFinfo(Chan)_lastop=OPREAD %IF CHCODE=EBCDIC %THEN %START %IF c#-1 %THEN c=ITOETAB(c) %FINISH %RESULT=c %END; {FGETC -- (9.7.1)} %EXTERNAL %INTEGER %FN fgets %ALIAS "ICL9CAFGETS"(%INTEGER adstr,n,chan) !*********************************************************************** !* * !* READS N CHARACTERS INTO ADSTR OFFSET FROM CHANNEL CHAN. * !* * !*********************************************************************** %INTEGER i,cc,c ChanIO=Chan i=CHECKCHANI(Chan) %IF i\=0 %THEN %RESULT=Nul i=0 %CYCLE RC(c) %IF c=-1 %THEN %START %IF i=0 %THEN %RESULT=Nul %FINISH %ELSE %IF c=nl %THEN %START %IF CHCODE=EBCDIC %THEN cc=21 %ELSE cc=nl byteinteger(adstr+i)=cc i=i+1 %FINISH %ELSE %START %IF CHCODE=EBCDIC %THEN c=ITOETAB(c) byteinteger(adstr+i)=c i=i+1 %FINISH %REPEAT %UNTIL i=n-1 %OR c=NL %OR c=-1 byteinteger(adstr+i)=Nul %RESULT=adstr %END; {FGETS -- (9.7.2)} %EXTERNAL %INTEGER %FN %SPEC puts %ALIAS "ICL9CAPUTS"(%INTEGER adstr) %EXTERNAL %INTEGER %FN %SPEC putchar %ALIAS "ICL9CAPUTCHAR"(%INTEGER c) %EXTERNAL %INTEGER %FN fputc %ALIAS "ICL9CAFPUTC"(%INTEGER c,chan) !*********************************************************************** !* * !* WRITES OUT THE CHARACTER SPECIFIED BY C. * !* * !*********************************************************************** %BYTE %INTEGER z %INTEGER k c=c&255 %IF Chan=StdOut %THEN %RESULT=putchar(c) k=CHECKCHANO(Chan) %IF k\=0 %THEN %RESULT=EOF z=c %IF CHCODE=EBCDIC %THEN z=ETOITAB(z) k=WRITE TEXT(Chan,addr(z),1) %IF k<0 %THEN %START ICL9CAERRNO=-k FFinfo(chan)_errmark=1 %RESULT=EOF %FINISH FFinfo(Chan)_lastop=OPWRITE %RESULT=z %END; {FPUTC -- (9.7.3)} %EXTERNAL %INTEGER %FN fputs %ALIAS "ICL9CAFPUTS"(%INTEGER adstr,chan) !*********************************************************************** !* * !* WRITES OUT THE STRING AT ADSTR TO CHAN. * !* * !*********************************************************************** %BYTE %INTEGER c %INTEGER i,len,k %IF Chan=StdOut %THEN %RESULT=puts(adstr) k=CHECKCHANO(Chan) %IF k\=0 %THEN %RESULT=k len=strlen(adstr) %FOR i=0,1,len-1 %CYCLE c=byteinteger(adstr+i) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) k=WRITE TEXT(Chan,addr(c),1) %IF k<0 %THEN %START ICL9CAERRNO=-k %RESULT=-k %FINISH %REPEAT FFinfo(Chan)_lastop=OPWRITE %RESULT=0 %END; {FPUTS -- (9.7.4)} %EXTERNAL %INTEGER %FN getc %ALIAS "ICL9CAGETC"(%INTEGER chan) !*********************************************************************** !* * !* SAME AS FGETC * !* * !*********************************************************************** %RESULT=fgetc(chan) %END; {GETC -- (9.7.5)} %EXTERNAL %INTEGER %FN getchar %ALIAS "ICL9CAGETCHAR" !*********************************************************************** !* * !* SAME AS GETC EXCEPT STANDARD CHANNEL * !* * !*********************************************************************** %INTEGER i ChanIO=Stdin RC(i) %IF CHCODE=EBCDIC %THEN %START %IF i#-1 %THEN i=ITOETAB(i) %FINISH %RESULT=i %END; {GETCHAR -- (9.7.6)} %EXTERNAL %INTEGER %FN gets %ALIAS "ICL9CAGETS"(%INTEGER adstr) !*********************************************************************** !* * !* READS FROM STANDARD CHANNEL UNTIL NEWLINE OR EOF OCCURS PUTTING * !* THEE CHARACTERS READ INTO THE ADDRESS OFFSET GIVEN. * !* * !*********************************************************************** %INTEGER i,j,c Chanio=Stdin i=0 %CYCLE RC(c) %IF c=-1 %OR c=nl %THEN %START %IF i=0 %THEN %RESULT=Nul byteinteger(adstr+i)=Nul %FINISH %ELSE %START %IF CHCODE=EBCDIC %THEN c=ITOETAB(c) byteinteger(adstr+i)=c i=i+1 %FINISH %REPEAT %UNTIL c=nl %OR c=-1 %RESULT=adstr %END; {GETS -- (9.7.7)} %EXTERNAL %INTEGER %FN putc %ALIAS "ICL9CAPUTC"(%INTEGER c,chan) !*********************************************************************** !* * !* SAME AS FPUTC. * !* * !*********************************************************************** %RESULT=fputc(c,chan) %END; {PUTC -- (9.7.8)} %EXTERNAL %INTEGER %FN putchar %ALIAS "ICL9CAPUTCHAR"(%INTEGER c) !*********************************************************************** !* * !* OUTPUTS C TO STANDARD CHANNEL * !* * !*********************************************************************** %INTEGER z z=c&255 %IF CHCODE=EBCDIC %THEN z=ETOITAB(z) SelectOutput(0) printch(z) %RESULT=z %END; {PUTCHAR -- (9.7.9)} %EXTERNAL %INTEGER %FN puts %ALIAS "ICL9CAPUTS"(%INTEGER adstr) !*********************************************************************** !* * !* SAME AS FPUTS EXCEPT CHANNEL ALWAYS STDOUT * !* * !*********************************************************************** %INTEGER i,len,c len=strlen(adstr) SelectOutput(0) %FOR i=0,1,len %CYCLE c=byteinteger(adstr+i) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) printch(c) %REPEAT %RESULT=0 %END; {PUTS -- (9.7.10)} %EXTERNAL %INTEGER %FN ungetc %ALIAS "ICL9CAUNGETC"(%INTEGER c,chan) !*********************************************************************** !* * !* PUSHES CHARACTER C BACK ONTO INPUT STREAM. * !* * !*********************************************************************** %INTEGER ch %IF FFinfo(Chan)_lastop#OPREAD %OR c=EOF %THEN %RESULT=EOF %IF Target=VME %THEN %START ch=CCUNGETC(c,chan) %FINISH %IF Target=EMAS %OR target=emasa %THEN %START %IF FFinfo(chan)_fptr=FFinfo(chan)_Conad %THEN %RESULT=EOF FFinfo(chan)_fptr=FFinfo(chan)_fptr-1 %FINISH %RESULT=ch %END; {UNGETC -- (9.7.11)} { GENERAL UTILITIES (10) } %ROUTINE Calc checksum(%RECORD (Allhead) %NAME Res) !*********************************************************************** !* * !* Calculate check-sum on header block for malloc, calloc * !* * !*********************************************************************** %IF target=emasa %START *L_1,Res *L_0,0(1) *AL_0,4(1) *AL_0,8(1) *ST_0,12(1) %ELSE *LXN_Res+4 *LSS_(%XNB ) *UAD_(%XNB +1) *UAD_(%XNB +2) *ST_(%XNB +3) %FINISH %END; {CALC CHECKSUM} %INTEGER %FN Valcheck(%RECORD (Allhead) %NAME Res) !*********************************************************************** !* * !* Test if checksum is correct for header block RES * !* * !*********************************************************************** %IF target=emasa %START *L_1,Res *L_0,0(1) *AL_0,4(1) *AL_0,8(1) *CL_0,12(1) *basr_2,0 *using_2 *BC_7, *DROP_2 %ELSE *LXN_Res+4 *LSS_(%XNB ) *UAD_(%XNB +1) *UAD_(%XNB +2) *UCP_(%XNB +3) *JCC_7, %FINISH %RESULT=Unset valfail: %RESULT=Set %END; {VALCHECK} %EXTERNAL %INTEGER %FN FREE %ALIAS "ICL9CAFREE"(%INTEGER ptr) !*********************************************************************** !* * !* Frees space allocated by malloc, * !* MALLOC and REALLOC * !* * !*********************************************************************** %INTEGER l,x,prevblock %RECORD (allhead) %NAME Res,Prev,Q %IF Tracing=Set %THEN %START printstring("FREE : Address is "); phex(ptr); newline printstring(" Dump of header : X") phex(integer(ptr-16)) spaces(2); phex(integer(ptr-12)) spaces(2); phex(integer(ptr-8)) newline %FINISH %IF %NOT (SpallSpace<=ptr<=(SpallSpace+Alloclimit)) %THEN %RESULT=0 l=ptr-Sizehead Res==record(l) %IF Res_form=X'FFFF' %AND Res_mode=Captured %AND Valcheck(Res)=Unset %THEN %START Res_mode=Spfree Prevblock=Startfreespace Prev==record(Prevblock) x=Prev_nextblock %WHILE xStartfreespace %THEN %START Prev_H0=Prev_H0+Res_H0+Sizehead Prev_nextblock=x Res==Prev l=Prevblock %FINISH %ELSE %START Prev_nextblock=l Res_nextblock=x %FINISH %IF Res_H0+l+Sizehead=x %THEN %START Res_H0=Res_H0+Q_H0+Sizehead Res_nextblock=Q_nextblock %FINISH Calc checksum(Res) Calc checksum(Prev) %RESULT=0 %FINISH %ELSE %START OPEH(310,0,11,0) %FINISH %END; {FREE -- (10.3.2)} %EXTERNAL %INTEGER %FN MALLOC %ALIAS "ICL9CAMALLOC"(%INTEGER elsize) !*********************************************************************** !* * !* Allocates space for object of size ELSIZE * !* * !*********************************************************************** %INTEGER size,len,x,y,nextblock,prevblock,conad,flag %RECORD (Allhead) %NAME Res,Prev %IF allocspac\=131 %THEN %START Outfile("t#cstall",alloclimit,0,0,conad,flag) %IF flag#0 %THEN OPEH(flag,0,11,0) Res==record(conad) Spallspace=conad Startfreespace=conad Res_mode=Spfree Res_form=X'FFFF' Res_H0=0 Res_nextblock=Spallspace+Sizehead Calc checksum(Res) Allocspac=131 Res==record(conad+Sizehead) Res_mode=Spfree Res_form=X'FFFF' Res_H0=Alloclimit-2*Sizehead Res_nextblock=Spallspace Calc checksum(Res) %FINISH len=(elsize+3)&X'FFFFFFFC' Res==record(Startfreespace) x=Res_nextblock Prevblock=Startfreespace %CYCLE Res==record(x) Prev==record(Prevblock) %IF Res_H0>=len %THEN %START y=x+Sizehead size=Res_H0-len Fill(len,y,0) Res_mode=Captured Res_form=X'FFFF' Res_H0=len nextblock=Res_nextblock Res_nextblock=0 Calc checksum(Res) %IF size>=Sizehead+4 %THEN %START Res==record(y+len) Prev_nextblock=y+len Res_mode=Spfree Res_form=X'FFFF' Res_H0=size-Sizehead Res_nextblock=nextblock Calc checksum(Res) Calc checksum(Prev) %FINISH %ELSE %START Prev_nextblock=nextblock Res_H0=len+size Calc checksum(Res) Calc checksum(Prev) %FINISH %IF Tracing=Set %THEN %START Printstring("MALLOC: Address of area is "); phex(y) Printstring(" Length of area is "); write(len,7); newline %FINISH %RESULT=y %FINISH Prevblock=x x=Res_nextblock %IF x=Startfreespace %THEN %START ICL9CAERRNO=311 %RESULT=Nul %FINISH %REPEAT %END; {MALLOC -- (10.3.3)} %EXTERNAL %INTEGER %FN CALLOC %ALIAS "ICL9CACALLOC"(%INTEGER nelem,elsize) !*********************************************************************** !* * !* Allocates space for object with nelem elements each of size elsize* !* * !*********************************************************************** %INTEGER len,ptr len=(nelem*elsize+3)&X'FFFFFFFC' ptr=MALLOC(len) %IF ptr\=Nul %THEN Fill(len,ptr,0) %RESULT=ptr %END; {CALLOC -- (10.3.1)} %EXTERNAL %INTEGER %FN REALLOC %ALIAS "ICL9CAREALLOC"(%INTEGER ptr,size) !*********************************************************************** !* * !* Changes the size of the object pointed to by ptr to the * !* size in bytes specified by size * !* * !*********************************************************************** %INTEGER i,oldsize,len,l,m %RECORD (Allhead) %NAME Res %IF %NOT (Spallspace<=ptr<=(Spallspace+Alloclimit)) %THEN %RESULT=Nul l=ptr-Sizehead Res==record(l) %IF Res_form=X'FFFF' %AND Res_mode=Captured %AND Valcheck(Res)=Unset %THEN %START len=(size+3)&X'FFFFFFFC' oldsize=Res_H0 %IF Res_H0=len %THEN %RESULT=ptr %IF Res_H0>len %THEN %START Res_H0=len %IF oldsize-len>=Sizehead+4 %THEN %START Res==record(ptr+len) Res_mode=Captured Res_form=X'FFFF' Calc checksum(Res) m=FREE(ptr+len+Sizehead) %FINISH %ELSE Res_H0=oldsize Calc checksum(Res) %RESULT=ptr %FINISH %ELSE %START m=malloc(len) %IF m\=Nul %THEN %START move(oldsize,ptr,m) l=free(ptr) %FINISH %RESULT=m %FINISH %FINISH %ELSE %START ICL9CAERRNO=310 %RESULT=Nul %FINISH %END; {REALLOC --(10.3.4)} %EXTERNAL %INTEGER %FN FREEHEAD %ALIAS "ICL9CAFREEHEAD" %RESULT=Startfreespace %END; {FREEHEAD} %IF TARGET=EMAS %OR target=emasa %THEN %START !**********************************************************************! !* * !* Support Procedures for Numeric Conversion * !* of Real Numbers * !* between Binary and Character Form * !* * !* (derived from vns_f77real6) * !**********************************************************************! ! ! ! ! DEFINE REAL CONSTANTS IN 'EXCESS 64' NOTATION ! ! %CONST %LONG %LONG %REAL %ARRAY TABLE OF POWERS(-78:75)= %C %C {10.0 ** -78} R'001DA48CE468E7C772026520247D3556' , {10.0 ** -77} R'011286D80EC190DC73617F3416CE4156' , {10.0 ** -76} R'01B94470938FA89B73CEF808E40E8D5B' , {10.0 ** -75} R'0273CAC65C39C96174615B058E891859' , {10.0 ** -74} R'03485EBBF9A41DDC75DCD8E37915AF38' , {10.0 ** -73} R'042D3B357C0692AA760A078E2BAD8D83' , {This } {10.0 ** -72} R'051C45016D841BAA774644B8DB4C7872' , {10.0 ** -71} R'0611AB20E472914A786BEAF3890FCB47' , {table } {10.0 ** -70} R'06B0AF48EC79ACE878372D835A9DF0C7' , {10.0 ** -69} R'076E6D8D93CC0C1179227C7218A2B67C' , {was } {10.0 ** -68} R'084504787C5F878A7AB58DC74F65B20E' , {10.0 ** -67} R'092B22CB4DBBB4B67BB1789C919F8F49' , {acquired } {10.0 ** -66} R'0A1AF5BF109550F27C2EEB61DB03B98D' , {10.0 ** -65} R'0B10D9976A5D52977D5D531D28E253F8' , {from } {10.0 ** -64} R'0BA87FEA27A539E97DA53F2398D747B3' , {10.0 ** -63} R'0C694FF258C744327E0747763F868CD0' , {PD Stephens} {10.0 ** -62} R'0D41D1F7777C8A9F7F448CA9E7B41802' , {10.0 ** -61} R'0E29233AAAADD6A3008AD7EA30D08F01' , {10.0 ** -60} R'0F19B604AAACA6260136C6F25E825961' , {10.0 ** -59} R'101011C2EAABE7D702E23C577B1177DD' , {via } {10.0 ** -58} R'10A0B19D2AB70E6E02D65B6ACEAEAE9D' , {10.0 ** -57} R'11646F023AB269050345F922C12D2D22' , {the } {10.0 ** -56} R'123EC56164AF81A3044BBBB5B8BC3C35' , {10.0 ** -55} R'13273B5CDEEDB106050F55519375A5A1' , {IBM } {10.0 ** -54} R'1418851A0B548EA306C99552FC298785' , {10.0 ** -53} R'14F53304714D926506DFD53DD99F4B30' , {Assembler. } {10.0 ** -52} R'15993FE2C6D07B7F07ABE546A8038EFE' , {10.0 ** -51} R'165FC7EDBC424D2F08CB6F4C2902395F' , {10.0 ** -50} R'173BDCF495A9703D09DF258F99A163DB' , {10.0 ** -49} R'18256A18DD89E6260AAB7779C004DE69' , {It } {10.0 ** -48} R'1917624F8A762FD80B2B2AAC18030B02' , {10.0 ** -47} R'19E9D71B689DDE710BAFAAB8F01E6E11' , {is } {10.0 ** -46} R'1A9226712162AB070C0DCAB3961304CA' , {10.0 ** -45} R'1B5B5806B4DDAAE40D689EB03DCBE2FF' , {claimed } {10.0 ** -44} R'1C391704310A8ACE0EC1632E269F6DDF' , {10.0 ** -43} R'1D23AE629EA696C10F38DDFCD823A4AB' , {to } {10.0 ** -42} R'1E164CFDA3281E3810C38ABE071646EB' , {10.0 ** -41} R'1EDF01E85F912E3710A36B6C46DEC52F' , {evaluate } {10.0 ** -40} R'1F8B61313BBABCE211C62323AC4B3B3E' , {10.0 ** -39} R'20571CBEC554B60D12BBD5F64BAF0507' , {exactly } {10.0 ** -38} R'213671F73B54F1C8139565B9EF4D6324' , {10.0 ** -37} R'2222073A8515171D145D5F9435905DF7' , {and } {10.0 ** -36} R'23154484932D2E72155A5BBCA17A3ABA' , {10.0 ** -35} R'23D4AD2DBFC3D0771587955E4EC64B45' , {round } {10.0 ** -34} R'2484EC3C97DA624A16B4BD5AF13BEF0B' , {10.0 ** -33} R'255313A5DEE87D6E17B0F658D6C57567' , {to } {10.0 ** -32} R'2633EC47AB514E65182E99F7863B6960' , {10.0 ** -31} R'272073ACCB12D0FF193D203AB3E521DC' , {128 } {10.0 ** -30} R'2814484BFEEBC29F1A863424B06F352A' , {10.0 ** -29} R'28CAD2F7F5359A3B1A3E096EE45813A0' , {bits. } {10.0 ** -28} R'297EC3DAF94180651B06C5E54EB70C44' , {10.0 ** -27} R'2A4F3A68DBC8F03F1C243BAF513267AB' , {10.0 ** -26} R'2B318481895D96271D76A54D92BF80CB' , {10.0 ** -25} R'2C1EF2D0F5DA7DD81EAA27507BB7B07F' , {It } {10.0 ** -24} R'2D1357C299A88EA71F6A58924D52CE4F' , {10.0 ** -23} R'2DC16D9A0095928A1F2775B7053C0F18' , {is } {10.0 ** -22} R'2E78E480405D7B962058A9926345896F' , {10.0 ** -21} R'2F4B8ED0283A6D3D21F769FB7E0B75E5' , {also } {10.0 ** -20} R'302F39421924844622BAA23D2EC729AF' , {10.0 ** -19} R'311D83C94FB6D2AC2334A5663D3C7A0E' , {claimed } {10.0 ** -18} R'3212725DD1D243AB24A0E75FE645CC48' , {10.0 ** -17} R'32B877AA3236A4B4244909BEFEB9FAD5' , {to } {10.0 ** -16} R'33734ACA5F6226F025ADA6175F343CC5' , {10.0 ** -15} R'34480EBE7B9D5856266C87CE9B80A5FB' , {be } {10.0 ** -14} R'352D09370D4257362703D4E1213067BD' , {10.0 ** -13} R'361C25C26849768128C2650CB4BE40D6' , {fully } {10.0 ** -12} R'37119799812DEA1129197F27F0F6E886' , {10.0 ** -11} R'37AFEBFF0BCB24AA29FEF78F69A5153A' , {validated. } {10.0 ** -10} R'386DF37F675EF6EA2ADF5AB9A2072D44' , {10.0 ** -9} R'3944B82FA09B5A522BCB98B405447C4B' , {10.0 ** -8} R'3A2AF31DC46118732CBF3F70834ACDAF' , {10.0 ** -7} R'3B1AD7F29ABCAF482D5787A6520EC08D' , {10.0 ** -6} R'3C10C6F7A0B5ED8D2E36B4C7F3493858' , {10.0 ** -5} R'3CA7C5AC471B47842E230FCF80DC3372' , {10.0 ** -4} R'3D68DB8BAC710CB22F95E9E1B089A027' , {10.0 ** -3} R'3E4189374BC6A7EF309DB22D0E560419' , {10.0 ** -2} R'3F28F5C28F5C28F531C28F5C28F5C28F' , {10.0 ** -1} R'4019999999999999329999999999999A' , {10.0 ** 0} R'41100000000000003300000000000000' , {10.0 ** 1} R'41A00000000000003300000000000000' , {10.0 ** 2} R'42640000000000003400000000000000' , {10.0 ** 3} R'433E8000000000003500000000000000' , {10.0 ** 4} R'44271000000000003600000000000000' , {10.0 ** 5} R'45186A00000000003700000000000000' , {10.0 ** 6} R'45F42400000000003700000000000000' , {10.0 ** 7} R'46989680000000003800000000000000' , {10.0 ** 8} R'475F5E10000000003900000000000000' , {10.0 ** 9} R'483B9ACA000000003A00000000000000' , {10.0 ** 10} R'492540BE400000003B00000000000000' , {10.0 ** 11} R'4A174876E80000003C00000000000000' , {10.0 ** 12} R'4AE8D4A5100000003C00000000000000' , {10.0 ** 13} R'4B9184E72A0000003D00000000000000' , {10.0 ** 14} R'4C5AF3107A4000003E00000000000000' , {10.0 ** 15} R'4D38D7EA4C6800003F00000000000000' , {10.0 ** 16} R'4E2386F26FC100004000000000000000' , {10.0 ** 17} R'4F16345785D8A0004100000000000000' , {10.0 ** 18} R'4FDE0B6B3A7640004100000000000000' , {10.0 ** 19} R'508AC7230489E8004200000000000000' , {10.0 ** 20} R'5156BC75E2D631004300000000000000' , {10.0 ** 21} R'523635C9ADC5DEA04400000000000000' , {10.0 ** 22} R'5321E19E0C9BAB244500000000000000' , {10.0 ** 23} R'54152D02C7E14AF64680000000000000' , {10.0 ** 24} R'54D3C21BCECCEDA14600000000000000' , {10.0 ** 25} R'558459516140148447A0000000000000' , {10.0 ** 26} R'5652B7D2DCC80CD248E4000000000000' , {10.0 ** 27} R'5733B2E3C9FD080349CE800000000000' , {10.0 ** 28} R'58204FCE5E3E25024A61100000000000' , {10.0 ** 29} R'591431E0FAE6D7214B7CAA0000000000' , {10.0 ** 30} R'59C9F2C9CD04674E4BDEA40000000000' , {10.0 ** 31} R'5A7E37BE2022C0914C4B268000000000' , {10.0 ** 32} R'5B4EE2D6D415B85A4DCEF81000000000' , {10.0 ** 33} R'5C314DC6448D93384EC15B0A00000000' , {10.0 ** 34} R'5D1ED09BEAD87C034F78D8E640000000' , {10.0 ** 35} R'5E13426172C74D82502B878FE8000000' , {10.0 ** 36} R'5EC097CE7BC9071550B34B9F10000000' , {10.0 ** 37} R'5F785EE10D5DA46D51900F436A000000' , {10.0 ** 38} R'604B3B4CA85A86C4527A098A22400000' , {10.0 ** 39} R'612F050FE938943A53CC45F655680000' , {10.0 ** 40} R'621D6329F1C35CA454BFABB9F5610000' , {10.0 ** 41} R'63125DFA371A19E655F7CB54395CA000' , {10.0 ** 42} R'63B7ABC62705030555ADF14A3D9E4000' , {10.0 ** 43} R'6472CB5BD86321E3568CB6CE6682E800' , {10.0 ** 44} R'6547BF19673DF52E5737F2410011D100' , {10.0 ** 45} R'662CD76FE086B93C58E2F768A00B22A0' , {10.0 ** 46} R'671C06A5EC5433C6590DDAA16406F5A4' , {10.0 ** 47} R'68118427B3B4A05B5AC8A8A4DE845987' , {10.0 ** 48} R'68AF298D050E43955AD69670B12B7F41' , {10.0 ** 49} R'696D79F82328EA3D5BA61E066EBB2F89' , {10.0 ** 50} R'6A446C3B15F992665C87D2C40534FDB5' , {10.0 ** 51} R'6B2AC3A4EDBBFB805D14E3BA83411E91' , {10.0 ** 52} R'6C1ABA4714957D305E0D0E549208B31B' , {10.0 ** 53} R'6D10B46C6CDD6E3E5F0828F4DB456FF1' , {10.0 ** 54} R'6DA70C3C40A64E6C5F51999090B65F68' , {10.0 ** 55} R'6E6867A5A867F10360B2FFFA5A71FBA1' , {10.0 ** 56} R'6F4140C78940F6A2614FDFFC78873D45' , {10.0 ** 57} R'7028C87CB5C89A256271EBFDCB54864B' , {10.0 ** 58} R'71197D4DF19D60576367337E9F14D3EF' , {10.0 ** 59} R'71FEE50B7025C36A630802F236D04754' , {10.0 ** 60} R'729F4F2726179A22644501D762422C94' , {10.0 ** 61} R'7363917877CEC055656B21269D695BDD' , {10.0 ** 62} R'743E3AEB4AE138356662F4B82261D96A' , {10.0 ** 63} R'7526E4D30ECCC321675DD8F3157D27E2' , {10.0 ** 64} R'76184F03E93FF9F468DAA797ED6E38ED' , {10.0 ** 65} R'76F316271C7FC390688A8BEF464E3946' , {10.0 ** 66} R'7797EDD871CFDA3A695697758BF0E3CC' , {10.0 ** 67} R'785EF4A74721E8646A761EA977768E5F' , {10.0 ** 68} R'793B58E88C75313E6BC9D329EAAA18FC' , {10.0 ** 69} R'7A25179157C93EC76C3E23FA32AA4F9D' , {10.0 ** 70} R'7B172EBAD6DDC73C6D86D67C5FAA71C2' , {10.0 ** 71} R'7BE7D34C64A9C85D6D4460DBBCA87197' , {10.0 ** 72} R'7C90E40FBEEA1D3A6E4ABC8955E946FE' , {10.0 ** 73} R'7D5A8E89D75252446F6EB5D5D5B1CC5F' , {10.0 ** 74} R'7E3899162693736A70C531A5A58F1FBB' , {10.0 ** 75} R'7F235FADD81C282271BB3F07877973D5' %CONST %LONG %LONG %REAL Ten to the 75= R'7F235FADD81C282271BB3F07877973D5' %CONST %LONG %LONG %REAL Ten to the %C Minus 74= R'03485EBBF9A41DDC75DCD8E37915AF38' ! Modified 6/November/86 18.00 !---Specifications of Procedures Defined---! %LONG %REAL %FN %SPEC ATOF(%INTEGER text ptr) %INTEGER %FN %SPEC ATOI(%INTEGER text ptr) %INTEGER %FN %SPEC ATOL(%INTEGER text ptr) %LONG %REAL %FN %SPEC STRTOD(%INTEGER text ptr,end ptr adr) %INTEGER %FN %SPEC STRTOL(%INTEGER text ptr,end ptr adr,base) !(Implementation based on DRAFT July 9 1986) !---External Data Referenced: ! ! %CONST %INTEGER ERANGE Const= 307; !=> Constant Out Of Range !-------------------------! ! ! ! ATOF ! ! ! !-------------------------! %EXTERNAL %LONG %REAL %FN ATOF %ALIAS "ICL9CAATOF"(%INTEGER text ptr) ! ! %OWN %INTEGER null= 0 %RESULT=STRTOD(text ptr,addr(null)) %END; !of ATOF !-------------------------! ! ! ! ATOI ! ! ! !-------------------------! %EXTERNAL %INTEGER %FN ATOI %ALIAS "ICL9CAATOI"(%INTEGER text ptr) ! ! %OWN %INTEGER null= 0 %RESULT=STRTOL(text ptr,addr(null),10) %END; !of ATOI !-------------------------! ! ! ! ATOL ! ! ! !-------------------------! %EXTERNAL %INTEGER %FN ATOL %ALIAS "ICL9CAATOL"(%INTEGER text ptr) ! ! %OWN %INTEGER null= 0 %RESULT=STRTOL(text ptr,addr(null),10) %END; !of ATOL !-------------------------! ! ! ! STRTOL ! ! ! !-------------------------! %EXTERNAL %INTEGER %FN STRTOL %ALIAS "ICL9CASTRTOL"(%INTEGER TEXT PTR, %INTEGER END PTR ADR,BASE) ! ! ! ! ! This Procedure Analyses the Number in the Input Buffer ! ! to determine (A) if the Syntax is correct, ! (B) the scale of the number ! ! ! It then Converts the Number into Binary. ! ! !The following table represents values assigned to each ! character in the ISO Character Set. The assignments ! are made on the following basis: ! %CONST %INTEGER Syntax Fault= 0 {for an invalid char}, A Blank = 1 {for a white space }, A Zero = 2 {for '0' }, A Digit = 3 {for '1' - '9' incl }, A Sign = 4 {for '+' , '-' }, A Letter = 5 {for 'A' - 'Z' incl }, Lower Case= 6 {for 'a' - 'z' incl } %CONST %BYTE %INTEGER %ARRAY TYPE(0:127)= %C Syntax Fault ( 8), A Blank { BS} , A Blank { HT} , A Blank { NL} , A Blank { VT} , A Blank { FF} , A Blank { CR} , Syntax Fault (18), A Blank { } , Syntax Fault (10), A Sign { + } , Syntax Fault , A Sign { - } , Syntax Fault ( 2), A Zero { 0 } , A Digit {1-9} ( 9) , Syntax Fault ( 7), A Letter {A-Z} (26) , Syntax Fault ( 6), Lower Case {a-z} (26) , Syntax Fault ( 5) ! ! %SWITCH HANDLE(Syntax Fault:Lower Case) ! !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONST %INTEGER Null= 0 %CONST %INTEGER Not Set= 0 %CONST %INTEGER Off= 0, On = 1 !Values taken by 'boolean' variables ! (ie. Integers used as flags) %CONST %INTEGER LONG MAX Const= X'7FFFFFFF' %CONST %INTEGER LONG MIN Const= X'80000000' ! !*********************************************************************** ! ! SPECIFICATIONS FOR LOCAL PROCEDURES ! !*********************************************************************** ! %INTEGER %FN %SPEC TO INTEGER(%INTEGER DATA AD,INT LEN,SIGN) ! ! Local Variables ! %INTEGER SIGN; !set zero if no numeric sign !set to specified sign otherwise %INTEGER C; !the current character being analysed %INTEGER I; !the scanning ptr through the local buffer %INTEGER X; !utility variable %INTEGER FAULT %INTEGER PTR; !%C PTR scans through the user supplied text ! ! Flag Variables ! %INTEGER B FLAG; !if zero then leading spaces are to be ignored %INTEGER HEX FLAG; !if zero then optional '0X' which may precede a ! hexadecimal (BASE=16) value has not been found ! ! Buffer and Buffer Related Variables ! %OWN %BYTE %INTEGER %ARRAY TEXT(0:255) %INTEGER LENGTH; !the number of significant digits specified ! ! Result Related Variables ! %INTEGER RESULT; !the integer value to be returned %INTEGER R PTR; !the value to be assigned to END PTR if it is not *NULL ! ! Initialise Variables ! RESULT=0 SIGN=Not Set; !=> no numeric sign found B FLAG=Not Set; !=> leading spaces are not significant HEX FLAG=Not Set; !=> '0X' preceding a hexadecimal value not found I=Not Set; !=> no significant digits found ! BASE=10 %IF BASE<=1 %OR BASE>36 {ignore specified number base} { if it is out of range } PTR=TEXT PTR %CYCLE ! ! ! ANALYSE THE NUMBER ! ! C=BYTEINTEGER(PTR); PTR=PTR+1 %IF C<=127 %THEN ->HANDLE(TYPE(C)) HANDLE(Syntax Fault): ! Handle an ILLEGAL Character ! ! ! ! ! %EXIT HANDLE(A Blank): ! Handle a WHITE SPACE Character ! ! ! ! ! %CONTINUE %IF B FLAG=Off {ignore insignificant blanks} %EXIT HANDLE(Lower Case): ! Handle a Lower Case Character ! ! ! ! ! C=C-' ' {convert to upper case} HANDLE(A Letter): ! Handle an Alphabetic ! ! ! ! ! C=C-'7' {convert into binary interpretation} ->SAVE HANDLE(A Zero): ! Handle a Nought ! ! ! ! ! %IF I=Not Set %AND BASE=16 %AND HEX FLAG=Off %THEN %START X=BYTEINTEGER(PTR) %IF X='X' %OR X='x' %THEN %START {Look } ! { for a } HEX FLAG=On { 0X or 0x } B FLAG=On { which may } PTR=PTR+1 { start a } %CONTINUE { hexadecimal} %FINISH { number} %FINISH {Fall through to handling a digit} HANDLE(A Digit): ! Handle a DIGIT ! ! ! ! ! C=C-'0' SAVE: %EXIT %IF C>=BASE I=I+1 TEXT(I)=C {save the digit} B FLAG=On %CONTINUE HANDLE(A Sign): ! Handle a SIGN ! ! ! ! ! %IF B FLAG=On %THEN %EXIT {an embedded sign} SIGN=C B FLAG=On %REPEAT; !for the next character ! ! ANALYSE THE ANALYSIS ! LENGTH=I %IF LENGTH=Null %THEN %START REPORT ERROR: R PTR=TEXT PTR {no significant digits} ->RETURN %FINISH R PTR=PTR-1 {the number is syntactically correct} ! ! ! NOW CONVERT TEXT INTO BINARY ! ! FAULT=TO INTEGER(ADDR(RESULT),LENGTH,SIGN) %IF FAULT\=0 %THEN ICL9CA ERRNO=ERANGE Const RETURN: INTEGER(END PTR ADR)=R PTR %UNLESS INTEGER(END PTR ADR)=Null %RESULT=RESULT %INTEGER %FN TO INTEGER(%INTEGER DATA AD,TEXT LEN,SIGN) ! ! ! ! ! THIS IS A PROCEDURE TO CONVERT A STRING OF CHARACTERS (which ! ! have been analysed syntactically) INTO AN INTEGER VALUE. ! ! !The character string is assumed to be in the area TEXT, and is !defined by the parameters TEXT LEN and SIGN which identify the length !and sign associated with the string respectively. At exit the result !is stored in the location defined by the parameter DATA AD which !is assumed to address an integer location. ! ! !NOTE1: It is assumed that there are no leading, embedded or trailing blanks !NOTE2: The string of digits is assumed to represent a valid integer ! ! ! At Exit: RESULT= 0 if the constant was within range ! RESULT= -1 if the constant was out of range ! ! ! %CONST %LONG %INTEGER Largest Integer= X'000000007FFFFFFF' ! !the value above represent the largest value ! that may be assigned to an INTEGER*4 ! ! Variables used to Address the Digits ! %INTEGER PTR {scanning ptr through TEXT } %INTEGER MAX PTR { maximum value PTR may have} ! ! Variables used to Convert the Digits to Binary ! %LONG %INTEGER MULT; !scaling to be applied to the next digit %LONG %INTEGER SUM; !the binary result ! ! Initialise Variables ! PTR=1; !initialise the scanning ptr MAX PTR=TEXT LEN; !initialise its maximum value PTR=PTR+1 %WHILE PTRPTR %CYCLE ! MAX PTR=MAX PTR-1 %IF MULT>Largest Integer %THEN ->INTEGER OVERFLOW SUM=SUM+(MULT*TEXT(MAX PTR)) MULT=MULT*BASE %REPEAT ! ! Assign the Value to an INTEGER*4 ! SUM=-SUM %IF SIGN='-' %IF INTEGER(ADDR(SUM))>0 %OR INTEGER(ADDR(SUM))<-1 %THEN ->INTEGER OVERFLOW INTEGER(DATA AD)=INTEGER(ADDR(SUM)+4) ! %RESULT=0 INTEGER OVERFLOW: ! %IF SIGN='-' %THEN SUM=LONG MIN Const %ELSE SUM=LONG MAX Const ! INTEGER(DATA AD)=SUM %RESULT=-1 %END; !of TO INTEGER %END; !of STRTOL !-------------------------! ! ! ! STRTOD ! ! ! !-------------------------! %EXTERNAL %LONG %REAL %FN STRTOD %ALIAS "ICL9CASTRTOD"(%INTEGER TEXT PTR, %INTEGER END PTR ADR) ! ! ! ! ! This Procedure Analyses a Floating Point Number in the Input Buffer ! ! to determine (A) if the Syntax is correct, ! (B) the scale of the number ! ! and to remove all instances of signs, exponents, and decimal points. ! ! ! This Procedure then Converts the Number into Binary. ! ! !The following table represents values assigned to each ! character in the ISO Character Set. The assignments ! are made on the following basis: ! %CONST %INTEGER Syntax Fault= 0 {for an invalid char}, A Blank = 1 {for a white space }, A Digit = 2 {for '0' - '9' incl }, A Sign = 3 {for '+' , '-' }, A Decimal Point = 4 {for '.' }, An Exponent = 5 {for 'e' , 'E' } %CONST %BYTE %INTEGER %ARRAY TYPE(0:127)= %C Syntax Fault ( 8), A Blank { BS} , A Blank { HT} , A Blank { NL} , A Blank { VT} , A Blank { FF} , A Blank { CR} , Syntax Fault (18), A Blank { } , Syntax Fault (10), A Sign { + } , Syntax Fault , A Sign { - } , A Decimal Point { . } , Syntax Fault , A Digit {0-9} (10) , Syntax Fault (11), An Exponent { E } , Syntax Fault (31), An Exponent { e } , Syntax Fault (25), A Blank {DEL} ! ! %SWITCH HANDLE(Syntax Fault:An Exponent) ! !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONST %INTEGER Null= 0 %CONST %INTEGER Not Set= 0 %CONST %INTEGER Off= 0, On = 1 !Values taken by 'boolean' variables ! (ie. Integers used as flags) %CONST %LONG %LONG %REAL HUGE VALUE Const= R'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' %CONST %LONG %LONG %REAL Largest Real= HUGE VALUE Const %CONST %INTEGER %ARRAY Integer Power Of Ten(0:9)= %C %C 1, 10, {by using this table } 100, {we overcome any problem} 1000, {we may have if integer } 10000, {exponentiation has not } 100000, {yet been implemented } 1000000, 10000000, 100000000, 1000000000 !---------------------------------------! ! ! ! CONDITIONAL COMPILATION CONSTANTS ! ! ! !---------------------------------------! ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL PROCEDURES ! !*********************************************************************** ! ! !*********************************************************************** ! ! SPECIFICATIONS FOR LOCAL PROCEDURES ! !*********************************************************************** ! %INTEGER %FN %SPEC TO REAL(%INTEGER DATA AD,INT LEN,SIGN) %INTEGER %FN %SPEC COMPARE(%INTEGER LENGTH,THIS,THAT) ! ! Local Variables ! %INTEGER SCALE FACTOR; !scaling to be applied to converted number %INTEGER DECS; !decimal places specified in number %INTEGER PTR; !pointer through the user supplied text %INTEGER FAULT ! ! Analysis Related Variables ! %INTEGER D PTR; !ptr to decimal digits in local buffer %INTEGER E PTR; !ptr to exponent digits in local buffer %INTEGER E LEN; !number of digits in the exponent %INTEGER E SIGN; !set zero of no exponent sign !set -ve if exponent sign='-' !set +ve if exponent sign='+' %INTEGER SIGN; !set zero if no numeric sign !set -ve if numeric sign='-' !set zero if numeric sign='+' %INTEGER B FLAG; ! if zero then leading spaces are to be ignored %INTEGER C; !the current character being analysed %INTEGER I; !the scanning ptr through TEXT (the local buffer) ! ! Buffer and Buffer Related Variables ! %OWN %BYTE %INTEGER %ARRAY TEXT(0:255) %INTEGER LENGTH; !%C LENGTH describes the length of the %C analysed text which has been placed in TEXT ! ! Result Related Variables ! %LONG %REAL RESULT; !the double precision value to be returned %INTEGER R PTR; !the value to be assigned to END PTR if it is not *NULL ! ! Exponent Related Variables ! %INTEGER EXP; !the exponent converted into binary %INTEGER MULT; ! a multiplier used while converting the exponent !---Initialise Variables: ! ! RESULT=0.0 PTR=TEXT PTR SCALE FACTOR=0 DECS=0 !---Initialise Analysis Variables: ! ! D PTR=Not Set; !=> no decimal point found E PTR=Not Set; !=> no exponent found E SIGN=Not Set; !=> no exponent sign found SIGN=Not Set; !=> no numeric sign found B FLAG=Not Set; !=> leading spaces are not significant I=Not Set; !=> no significant digits found %CYCLE ! ! ! ANALYSE THE NUMBER ! ! C=BYTEINTEGER(PTR); PTR=PTR+1 %IF C<=127 %THEN ->HANDLE(TYPE(C)) HANDLE(Syntax Fault): ! Handle an ILLEGAL Character ! ! ! ! ! %EXIT %UNLESS I=0 ->REPORT ERROR HANDLE(A Blank): ! Handle a WHITE SPACE Character ! ! ! ! ! %CONTINUE %IF B FLAG=Off {ignore insignificant blanks} %EXIT HANDLE(A Digit): ! Handle a DIGIT ! ! ! ! ! I=I+1; TEXT(I)=C-'0' {save the digit} B FLAG=On %CONTINUE HANDLE(A Sign): ! Handle a SIGN ! ! ! ! ! %IF B FLAG=On %THEN %EXIT {an embedded sign} SIGN=C B FLAG=On %CONTINUE HANDLE(A Decimal Point): ! Handle a DECIMAL part ! ! ! ! ! %EXIT %IF D PTR\=0 %OR E PTR\=0 B FLAG=On {stop on any embedded blanks} D PTR=I+1 {note the decimal point } %CONTINUE HANDLE(An Exponent): ! Handle an EXPONENT ! ! ! ! ! %EXIT %UNLESS B FLAG=On {exponent is first character } %EXIT %UNLESS E PTR=Not Set {more than one exponent given} ! E PTR=I+1 C=BYTEINTEGER(PTR) {Examine } %IF C='-' %THEN E SIGN=C { the next } %ELSE %IF C\='+' %THEN %CONTINUE { character} { for a } PTR=PTR+1 { sign } %REPEAT; !for the next character LENGTH=I ! ! ANALYSE THE ANALYSIS ! %IF E PTR\=Not Set %THEN %START ! ! Analyse the given Exponent ! %IF E PTR>LENGTH %THEN ->REPORT ERROR {no exponent supplied} E LEN=LENGTH-(E PTR-1) LENGTH=E PTR-1 ! ! Convert the given Exponent into Binary ! %IF E LEN>9 %THEN %START ! ! Skip any Leading Zeros ! %WHILE E LEN>0 %CYCLE %IF BYTEINTEGER(E PTR)\=0 %THEN %EXIT E PTR=E PTR+1 E LEN=E LEN-1 %REPEAT EXP=32678 %AND ->A %IF E LEN>9 {exponent too large} %FINISH EXP=0 %IF E LEN>0 %THEN %START ! MULT=Integer Power Of Ten(E LEN-1) %WHILE MULT>0 %CYCLE EXP=EXP+(MULT*TEXT(E PTR)) E PTR=E PTR+1 MULT=MULT//10 %REPEAT %FINISH ! A: %IF EXP>32767 %THEN EXP=32767 %IF E SIGN='-' %THEN EXP=-EXP ! SCALE FACTOR=-EXP %FINISH !Handling an Exponent ! ! Analyse the (rest of the) Number ! %IF LENGTH=Null %THEN ->REPORT ERROR {no significant digits} %IF D PTR\=Null %THEN DECS=LENGTH-(D PTR-1) ! R PTR=PTR-1 {the number is syntacically correct} ! ! ! NOW CONVERT TEXT INTO BINARY ! ! FAULT=TO REAL(ADDR(RESULT),LENGTH,SIGN) %IF FAULT\=0 %THEN ICL9CA ERRNO=ERANGE Const RETURN: INTEGER(END PTR ADR)=R PTR %UNLESS INTEGER(END PTR ADR)=Null %RESULT=RESULT REPORT ERROR: R PTR=TEXT PTR ->RETURN %INTEGER %FN TO REAL(%INTEGER DATA AD,INT LEN,SIGN) ! ! ! ! ! THIS PROCEDURE CONVERTS A STRING OF CHARACTERS (which have been ! ! analysed syntactically) INTO A FLOATING POINT NUMBER. ! ! !The character string is assumed to be in an area TEXT and is defined !by the parameters INT LEN, and SIGN which identifies the length of !the characters and their associated sign. The global integer DECS !defines the implied positioning of the decimal point: while the global !variable SCALE FACTOR defines the exponentiation to be applied to the !result. The result is saved in the location defined by DATA AD which !is assumed to be a longreal. ! ! !NOTE1: There are no embedded or trailing blanks !NOTE2: It is assumed that there are no leading spaces !NOTE3: The character string is assumed to represent a ! valid floating point number ! ! ! At Exit: RESULT= 0 if the constant was within range ! RESULT= -1 if the constant was out of range ! ! ! ! ! ! Declare IBM type specific Floating Point Constants ! ! %CONST %LONG %LONG %REAL Maximum Double= R'7FFFFFFFFFFFFFFF0000000000000000' %IF TARGET=EMAS %THEN %START ! %OWN %LONG %LONG %REAL Real8 Rounding= R'00000000000000000080000000000000' ! !Note that on IBM style architectures, assignments to ! a shorter precision is rounded up, but not on 2900 ! style architectures. %FINISH %CONST %INTEGER Max Power= 75 %CONST %INTEGER Min Power= -78 %OWN %STRING (40) LARGEST POSSIBLE= "7237005577332262213973186563043052414499" !LARGEST POSSIBLE is a representation, in characters, of ! the 40 most significant digits of the largest possible ! real in 'Excess 64' notation. ! ! Variables used to Address the Digits ! %INTEGER PTR {scanning ptr through TEXT } %INTEGER MAX PTR { maximum value PTR may have} %INTEGER LEN; !%C LEN is the actual number %C of significant digits in the TEXT ! ! Variables associated with the Scale of the Number ! %INTEGER MAX DIGITS; !maximum significant digits available at reqd precision %INTEGER VAL SIZE; !scale of the leftmost significant digit %INTEGER EXP; !scale of the rightmost significant digit ! ! Variables used in Numeric Conversion ! %INTEGER MULT; !scaling to be applied to the next digit %INTEGER SUM; ! binary integer value of the digits bar scaling %LONG %LONG %REAL X; ! actual Real result %INTEGER RESULT RESULT=0 {=> everything went okay} EXP=-(SCALE FACTOR+DECS) ! !Initialise the exponentiation to be applied PTR=1; MAX PTR=INT LEN ! ! Ignore Leading and Trailing Zeros ! PTR=PTR+1 %WHILE PTR=PTR %AND TEXT(MAX PTR)=0 !ignore any trailing zeros ! ! Determine the Magnitude of the Value ! LEN=MAX PTR-(PTR-1) %AND MAX DIGITS=16 %IF LEN>MAX DIGITS %THEN %START ! ! Ignore any digits which have no bearing on the result ! EXP=EXP+(LEN-MAX DIGITS) LEN=MAX DIGITS %FINISH VAL SIZE=EXP+(LEN-1); !NOTE: LEN=number of significant digits ! ! EXP= scale of rightmost digit ! ! VAL SIZE= scale of leftmost digit %IF VAL SIZE>Max Power %OR EXPFURTHER EXAMINATION !Jump if ! the value is around or beyond ! the capabilities of the code below FORM RESULT: X=0.0 ! ! Test for a Zero ! %IF LEN<=0 %THEN %START ! ->ASSIGN A REAL8 %FINISH ! ! ! Perform the Conversion ! ! %IF LEN>9 %THEN %START %CYCLE; MULT=100000000 {10 ** ** 8} SUM=0 %CYCLE; SUM=SUM+(MULT*TEXT(PTR)) PTR=PTR+1 MULT=MULT//10 %REPEAT %UNTIL MULT<=0 LEN=LEN-9 X=X+(SUM*TABLE OF POWERS(EXP+LEN)) %REPEAT %UNTIL LEN<10 %FINISH ! !The loop above is used when more than 9 digits are to be converted ! into a floating point number. Each set of nine digits (from ! left to right) are converted into an integer, then scaled as ! appropriate, and then added to the result of the previous ! loop (if any). Note if 10 or more digits were processed as a ! time then overflow would/could occur. !The code below operates similarly as above but uses the final !N digits (N<=9), and incorporates the result into the running !total if any: MULT=Integer Power Of Ten(LEN-1) SUM=0 %CYCLE; SUM=SUM+(MULT*TEXT(PTR)) PTR=PTR+1 MULT=MULT//10 %REPEAT %UNTIL MULT<=0 X=X+(SUM*TABLE OF POWERS(EXP)) RETURN RESULT: ! ! ! Assign the Value to the I/O Item ! ! %IF X>=Maximum Double %THEN X=Maximum Double %ELSE %START %IF TARGET=EMAS %THEN BYTEINTEGER(ADDR(Real8 Rounding))=BYTEINTEGER(ADDR(X)) %AND X=X+Real8 Rounding %FINISH ASSIGN A REAL8: X=-X %IF SIGN='-' LONGREAL(DATA AD)=X RETURN: %RESULT=RESULT FURTHER EXAMINATION: !required for very large or for very small ! values before conversion can be ! attempted ! %IF VAL SIZEVALUE TOO SMALL %IF VAL SIZE>=Max Power %THEN %START %IF VAL SIZE=Max Power %THEN %START ! ! Compare Digits with the Largest Possible Real ! ->VALUE TOO LARGE %IF COMPARE(LEN,ADDR(TEXT(0))+PTR,ADDR(LARGEST POSSIBLE)+1)>0 %FINISH %ELSE {!} %IF LEN=0 %THEN ->VALUE TOO SMALL %ELSE ->VALUE TOO LARGE %FINISH %IF EXPFORM RESULT ! ! HANDLE NUMBERS OUT OF THE PERMITTED RANGE ! VALUE TOO SMALL: X=0.0; ->SET RESULT VALUE TOO LARGE: X=LARGEST REAL; SET RESULT: RESULT=-1 {=> Constant Out Of Range} ->RETURN RESULT ! ! ! %END; !of TO REAL ! !*********************************************************************** ! ! UTILITY PROCEDURES ! !*********************************************************************** ! %INTEGER %FN COMPARE(%INTEGER LENGTH,THIS,THAT) ! ! ! ! ! A Utility Procedure to lexographically compare two texts ! ! of equal length and to return a value which ! ! represents the result of the comparision. ! ! ! At Exit: RESULT= 0 if Text(THIS)=Text(THAT) or LENGTH<=0 ! RESULT= -1 if Text(THIS)Text(THAT) ! ! ! %WHILE LENGTH>0 %CYCLE ! %RESULT=1 {greater than} %IF BYTEINTEGER(THIS)>BYTEINTEGER(THAT) %RESULT=-1 { less than} %IF BYTEINTEGER(THIS)>16)&X'7FFF' %END; {RAND} %EXTERNAL %ROUTINE SRAND %ALIAS "ICL9CASRAND"(%INTEGER SD) !*********************************************************************** !* * !* Uses the parameter as the seed for the new sequence of random nos * !* * !*********************************************************************** Seed=SD %END; {SRAND} { 10.4 -- Communication with the Environment } %EXTERNAL %ROUTINE termincc %ALIAS "ICL9CATERMINCC" !******************************************************************** !* !* CAUSES ALL PROGRAM STREAMS TO BE FLUSHED !* !********************************************************************* %INTEGER i,k %FOR i=80,-1,3 %CYCLE k=FCLOSE(i) %REPEAT %STOP %END; {TERMINCC} %EXTERNAL %INTEGER %FN onexit %ALIAS "ICL9CAONEXIT"(%INTEGER func) !*********************************************************************** !* * !* Sets up function calls to be executed on exit * !* * !*********************************************************************** Onexitcount=Onexitcount+1 %IF Onexitcount>32 %THEN ICL9CAERRNO=323 %AND %RESULT=323 Onex(Onexitcount)=func %RESULT=0 %END; {ONEXIT -- (10.4.4)} %EXTERNAL %INTEGER %FN exit %ALIAS "ICL9CAEXIT"(%INTEGER status) !*********************************************************************** !* * !* CAUSES ALL FUNCTIONS WITH ONEXIT TO BE CALLED,THEN CAUSES PROGRAM * !* TERMINATION CLOSING ALL FILES * !* * !*********************************************************************** %INTEGER i,l %IF Onexitcount>0 %THEN %START %FOR i=Onexitcount,-1,1 %CYCLE l=Onex(i) %IF target=emasa %START *L_1,L *STM_4,14,16(11) *LM_12,14,0(1) *basr_15,14 %ELSE *LXN_l *PRCL_4 *RALN_5 *LD_(%XNB +0) *CALL_(%DR ) %FINISH %REPEAT %FINISH termincc %RESULT=0 %END; {EXIT -- (10.4.2)} %INTEGER %FN %SPEC kill(%INTEGER pid,sig) %EXTERNAL %INTEGER %FN abort %ALIAS "ICL9CAABORT" !*********************************************************************** !* * !* causes abnormal termination to program to occur * !* * !*********************************************************************** %INTEGER l l=sg(6) %IF l\=-3 %AND l\=-2 %THEN %START l=kill(0,6) %IF l=0 %THEN %RESULT=0 %FINISH ICL9CAERRNO=325 OPEH(325,0,11,0) %END; {ABORT -- (10.4.1)} { CHARACTER HANDLING FUNCTIONS } %EXTERNAL %INTEGER %FN isalnum %ALIAS "ICL9CAISALNUM"(%INTEGER z) !*********************************************************************** !* * !* RETURNS NON ZERO IF C IS ANY LETTER OR DIGIT. * !* * !*********************************************************************** %INTEGER c c=z %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %IF ('0'<=c<='9') %OR ('a'<=c<='z') %OR ('A'<=c<='Z') %THEN %RESULT=1 %ELSE %RESULT=0 %END; {ISALNUM} %EXTERNAL %INTEGER %FN isalpha %ALIAS "ICL9CAISALPHA"(%INTEGER z) !*********************************************************************** !* * !* RETURNS NON ZERO IF C IS LETTER. * !* * !*********************************************************************** %INTEGER c c=z %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %IF ('a'<=c<='z') %OR ('A'<=c<='Z') %THEN %RESULT=1 %ELSE %RESULT=0 %END; {ISALPHA} %EXTERNAL %INTEGER %FN iscntrl %ALIAS "ICL9CAISCNTRL"(%INTEGER z) !*********************************************************************** !* * !* RETURNS NON ZERO IF C A NON PRINTABLE VALUE OTHER THAN SPACE * !* * !*********************************************************************** %INTEGER c c=z %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %IF (0<=c<=' ') %THEN %RESULT=1 %ELSE %RESULT=0 %END; {ISCNTRL} %EXTERNAL %INTEGER %FN isdigit %ALIAS "ICL9CAISDIGIT"(%INTEGER z) !*********************************************************************** !* * !* RETURNS NON ZERO IF C IS ANY DECIMAL DIGIT. * !* * !*********************************************************************** %INTEGER c c=z %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %IF ('0'<=c<='9') %THEN %RESULT=1 %ELSE %RESULT=0 %END; {ISDIGIT} %EXTERNAL %INTEGER %FN isgraph %ALIAS "ICL9CAISGRAPH"(%INTEGER z) !*********************************************************************** !* * !* RETURNS NON ZERO FOR ANY PRINTING CHAR EXCEPT SPACE * !* * !*********************************************************************** %INTEGER c c=z %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) %IF (' '0 %THEN %START *LDTB_x'18000000' *LDB_size *LDA_ads2 *CYD_0 *LDA_ads1 *MV_ %L = %DR %FINISH %FINISH %RESULT=ads1 %END; {MEMCPY --(11.2.1)} %EXTERNAL %INTEGER %FN memset %ALIAS "ICL9CAMEMSET"(%INTEGER s,c,n) !*********************************************************************** !* * !* COPIES C INTO THE FIRST N BYTES STARTING AT S. * !* * !*********************************************************************** %INTEGER i %IF target=emasa %THEN fill(n,s,c) %ELSE %START %IF n>0 %THEN %START *LDTB_x'18000000' *LDB_n *LDA_s *LB_c *MVL_ %L = %DR %FINISH %FINISH %RESULT=s %END; {MEMSET --(11.2.2)} %EXTERNAL %INTEGER %FN strcpy %ALIAS "ICL9CASTRCPY"(%INTEGER s1,s2) !*********************************************************************** !* * !* COPIES THE STRING POINTED TO BY S2 INTO OBJECT AT ADDRESS S1. * !* * !*********************************************************************** %INTEGER dr0,dr1 %INTEGER n,i %IF target=emasa %START move(n+1,s2,s1) %ELSE *LDTB_x'18ffffff'; !locate null character in s2 *LDA_s2 *SWNE_ %L = %DR,0,0 *STD_dr0 dr0=(dr1+1)-s2; !calculate length of s2 *LDB_dr0; !copy s2 into s1 *LDA_s2 *CYD_0 *LDA_s1 *MV_ %L = %DR %FINISH %RESULT=s1 %END; {STRCPY --(11.2.3)} %EXTERNAL %INTEGER %FN strncpy %ALIAS "ICL9CASTRNCPY"(%INTEGER s1,s2,n) !*********************************************************************** !* * !* COPIES NOT MORE THAN N CHARACTERS FROM STRING AT S2 TO OBJECT AT S*1. !* * !*********************************************************************** %INTEGER dr0,dr1 %INTEGER size,i %IF target=emasa %START size=strlen(s2) %IF size>=n-1 %THEN %START move(n,s2,s1) %FINISH %ELSE %START move(size+1,s2,s1) fill(n-(size+1),s1+(size+1),Nul) %FINISH %ELSE %IF n>0 %THEN %START *LDTB_x'18ffffff'; !find null character in s2 *LDA_s2 *SWNE_ %L = %DR,0,0 *STD_dr0 dr0=(dr1-s2)!x'18000000'; !work out strlen(s2) *LSS_s2; !copy *LUH_dr0; ! N characters *LDTB_x'18000000'; ! from S2 and *LDB_n; ! fill with trailing *LDA_s1; ! null characters if *MV_ %L = %DR,0,0; ! strlen(S2)< N %FINISH %FINISH %RESULT=s1 %END; {STRNCPY --(11.2.4)} { 11.3 -- Concatenation Functions } %EXTERNAL %INTEGER %FN strcat %ALIAS "ICL9CASTRCAT"(%INTEGER s1,s2) !*********************************************************************** !* * !* APPENDS S2 TO S1 OVERWRITING NUL CHARACTER OF S1. * !* * !*********************************************************************** %INTEGER dr0,dr1 %INTEGER ptr,n,i %IF target=emasa %START ptr=strlen(s1)+s1 n=strlen(s2) move(n+1,s2,ptr) %ELSE *LDTB_x'18ffffff'; !find null character in s2 *LDA_s2 *SWNE_ %L = %DR,0,0 *STD_dr0 dr0=((dr1+1)-s2)!x'18000000'; !work out length of s2 *LSS_s2 *LUH_dr0 *LDTB_x'18ffffff'; !find null character in s1 *LDA_s1 *SWNE_ %L = %DR,0,0 *LDTB_dr0; !copy s2 onto the end of s1 *MV_ %L = %DR %FINISH %RESULT=s1 %END; {STRCAT --(11.3.1)} %EXTERNAL %INTEGER %FN strncat %ALIAS "ICL9CASTRNCAT"(%INTEGER s1,s2,n) !*********************************************************************** !* * !* APPENDS N CHARACTERS OF S2 TO S1 * !* * !*********************************************************************** %INTEGER dr0,dr1 %INTEGER ptr,i %IF target=emasa %START ptr=strlen(s1)+s1 move(n,s2,ptr) byteinteger(ptr+n)=Nul %ELSE %IF n>0 %THEN %START *LDTB_x'18ffffff'; !find null character in s2 *LDA_s2 *SWNE_ %L = %DR,0,0 *STD_dr0 dr0=dr1-s1; !select smaller of strlen(s2) and n dr0=n %IF nb %THEN %START %RESULT=1 %FINISH %ELSE %IF a0 %THEN %START *LDTB_x'18ffffff' *LDB_n *LDA_s2 *CYD_0 *LDA_s1 *CPS_ %L = %DR *JCC_8, *JCC_2, lt: %RESULT=-1 gt: %RESULT=1 %FINISH %FINISH eq: %RESULT=0 %END; {MEMCMP --(11.4.1)} %EXTERNAL %INTEGER %FN memicmp %ALIAS "ICL9CAMEMICMP"(%INTEGER s1,s2,n) !*********************************************************************** !* * !* Compares first n bytes of s1 and s2 treating lower case as upper ca*se !* * !*********************************************************************** %INTEGER i,a,b %FOR i=0,1,n-1 %CYCLE a=toupper(byteinteger(s1+i)) b=toupper(byteinteger(s2+i)) %IF a>b %THEN %START %RESULT=1 %FINISH %ELSE %IF ab %THEN %START %RESULT=1 %FINISH %ELSE %IF a *JCC_2, lt: %RESULT=-1 gt: %RESULT=1 eq: %RESULT=0 %FINISH %END; {STRCMP --(11.4.3)} %EXTERNAL %INTEGER %FN stricmp %ALIAS "ICL9CASTRICMP"(%INTEGER s1,s2) !*********************************************************************** !* * !* Compares strings s1 and s2 treating lower case as upper case * !* * !*********************************************************************** %INTEGER i,a,b i=0 %CYCLE a=toupper(byteinteger(s1+i)) b=toupper(byteinteger(s2+i)) %IF a>b %THEN %START %RESULT=1 %FINISH %ELSE %IF ab %THEN %START %RESULT=1 %FINISH %ELSE %IF a0 %THEN %START *LDTB_x'18ffffff'; !find null character in s1 *LDA_s1 *SWNE_ %L = %DR,0,0 *STD_dr0 dr0=(dr1+1)-s1; !calculate strlen(s1)+1 %IF dr0>n %THEN dr0=n; !select the lesser of n or complete string length *LDB_dr0; !perform comparision *LDA_s2 *CYD_0 *LDA_s1 *CPS_ %L = %DR *JCC_8, *JCC_2, lt: %RESULT=-1 gt: %RESULT=1 %FINISH %FINISH eq: %RESULT=0 %END; {STRNCMP --(11.4.5)} %EXTERNAL %INTEGER %FN strnicmp %ALIAS "ICL9CASTRNICMP"(%INTEGER s1,s2,n) !*********************************************************************** !* * !* Compares not more than n chars of s1 with s2 treating lower case as *upper !* * !*********************************************************************** %INTEGER i,a,b i=0 %IF n=0 %THEN %RESULT=0 %FOR i=0,1,n-1 %CYCLE a=toupper(byteinteger(s1+i)) b=toupper(byteinteger(s2+i)) %IF a>b %THEN %START %RESULT=1 %FINISH %ELSE %IF a0 %AND c>=0 %AND c<=255 %THEN %START *LDTB_x'18ffffff' *LDA_s *LDB_n *LB_c *SWNE_ %L = %DR *JCC_8, *STD_dr0 %RESULT=dr1 %FINISH %FINISH not found: %RESULT=Nul %END; {MEMCHR --(11.5.1)} %EXTERNAL %INTEGER %FN strchr %ALIAS "ICL9CASTRCHR"(%INTEGER s,c) !*********************************************************************** !* * !* LOCATES THE FIRST OCCURRENCE OF C IN THE STRING AT S. * !* * !*********************************************************************** %INTEGER i,len %INTEGER dr0,dr1 %IF target=emasa %START len=strlen(s) %FOR i=0,1,len %CYCLE %IF byteinteger(s+i)=c %THEN %RESULT=s+i %REPEAT %RESULT=Nul %ELSE %IF c>=0 %AND c<=255 %THEN %START *LDTB_x'18ffffff' *LDA_s *SWNE_ %L = %DR,0,0 *STD_dr0 %IF c>0 %THEN %START dr0=(dr1+1)-s *LDB_dr0 *LDA_s *LB_c *SWNE_ %L = %DR *JCC_8, *STD_dr0 %FINISH %RESULT=dr1 %FINISH not found: %RESULT=Nul %FINISH %END; {STRCHR --(11.5.2)} %EXTERNAL %INTEGER %FN strcspn %ALIAS "ICL9CASTRCSPN"(%INTEGER s1,s2) !*********************************************************************** !* * !* COMPUTES THE LENGTH OF THE INITIAL SEGMENT OF THE STRING AT S1 * !* WHICH CONSISTS ENTIRELY OF CHARACTERS NOT FROM THE STRING AT S2. * !* * !*********************************************************************** %INTEGER len1,len2,i,j,a len1=strlen(s1) len2=strlen(s2) %FOR i=0,1,len1-1 %CYCLE a=byteinteger(s1+i) %FOR j=0,1,len2-1 %CYCLE %IF byteinteger(s2+j)=a %THEN %RESULT=i %REPEAT %REPEAT %RESULT=i+1 %END; {STRCSPN --(11.5.3)} %EXTERNAL %INTEGER %FN strpbrk %ALIAS "ICL9CASTRPBRK"(%INTEGER s1,s2) !*********************************************************************** !* * !* LOCATES FIRST OCCURRENCE OF ANY CHARACTER OF STRING AT S2 WITH * !* THE STRING AT S1 * !* * !*********************************************************************** %INTEGER len1,len2,i,j,a len1=strlen(s1) len2=strlen(s2) %FOR i=0,1,len1-1 %CYCLE a=byteinteger(s1+i) %FOR j=0,1,len2-1 %CYCLE %IF byteinteger(s2+j)=a %THEN %RESULT=s1+i %REPEAT %REPEAT %RESULT=Nul %END; {STRPBRK --(11.5.4)} %EXTERNAL %INTEGER %FN strrchr %ALIAS "ICL9CASTRRCHR"(%INTEGER s,c) !*********************************************************************** !* * !* LOCATES THE LAST OCCURRENCE OF C IN STRING AT S * !* * !*********************************************************************** %INTEGER len,i len=strlen(s) %FOR i=len,-1,0 %CYCLE %IF byteinteger(s+i)=c %THEN %RESULT=s+i %REPEAT %RESULT=Nul %END; {STRRCHR --(11.5.5)} %EXTERNAL %INTEGER %FN strspn %ALIAS "ICL9CASTRSPN"(%INTEGER s1,s2) !*********************************************************************** !* * !* COMPUTES THE LENGTH OF THE INITIAL SEGMENT OF STRING AT S1 WHICH * !* CONSISTS ENTIRELY OF CHARACTERS CONTAINED IN THE STRING AT S2 * !* * !*********************************************************************** %INTEGER len1,len2,i,j,a len1=strlen(s1) len2=strlen(s2) %FOR i=0,1,len1-1 %CYCLE a=byteinteger(s1+i) j=-1 %CYCLE j=j+1 %REPEAT %UNTIL j=len2 %OR byteinteger(s2+j)=a %IF j=len2 %THEN %RESULT=i %REPEAT %RESULT=i+1 %END; {STRSPN --(11.5.6)} %EXTERNAL %INTEGER %FN strstr %ALIAS "ICL9CASTRSTR"(%INTEGER s1,s2) %INTEGER len1,len2,i,j,k,l len1=strlen(s1) len2=strlen(s2) %IF len2>len1 %THEN %RESULT=Nul %FOR i=0,1,len1-len2 %CYCLE k=0 l=i %FOR j=0,1,len2-1 %CYCLE %IF byteinteger(s1+l)=byteinteger(s2+j) %THEN l=l+1 %ELSE k=1 %REPEAT %IF k=0 %THEN %RESULT=s1+i %REPEAT %RESULT=Nul %END; {STRSTR --(11.5.7)} %EXTERNAL %INTEGER %FN strtok %ALIAS "ICL9CASTRTOK"(%INTEGER s1,s2) !*********************************************************************** !* * !* Repeated token string search * !* * !*********************************************************************** %INTEGER ptr,nextptr %IF s1#Nul %THEN strtoken=s1 %IF strtoken=Nul %OR byteinteger(strtoken)=Nul %THEN %RESULT=Nul ptr=strstr(strtoken,s2) %IF ptr=Nul %THEN %START nextptr=strtoken strtoken=Nul %RESULT=nextptr %FINISH %ELSE %START byteinteger(ptr)=Nul nextptr=strtoken strtoken=ptr+strlen(s2) %RESULT=nextptr %FINISH %END; {STRTOK --(11.5.8)} %EXTERNAL %INTEGER %FN strerror %ALIAS "ICL9CASTRERROR"(%INTEGER s) !*********************************************************************** !* * !* Maps error number to an error message * !* * !*********************************************************************** %STRING (255) text %INTEGER i,len,k %if TARGET=Emas %or TARGET=EMASA %Start select output(0) printstring("Strerr not available on EMAS") %monitor; %stop %else %IF s=Nul %OR byteinteger(s)=Nul %THEN text="" %ELSE %START len=strlen(s) byteinteger(addr(text))=len %IF chcode=ebcdic %THEN %START %FOR i=1,1,len %CYCLE byteinteger(addr(text)+i)=ETOITAB(byteinteger(s+i-1)) %REPEAT %FINISH %FINISH k=CC STRERROR(text) len=byteinteger(k) %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,len %CYCLE byteinteger(k+i)=ITOETAB(byteinteger(k+i)) %REPEAT %FINISH byteinteger(k+len+1)=0 %RESULT=k+1 %finish %END; {STRERROR -- (11.6.1)} %EXTERNAL %INTEGER %FN GETENV %ALIAS "ICL9CAGETENV"(%INTEGER name) !*********************************************************************** !* * !* Search environment list * !* * !*********************************************************************** %INTEGER c,i,k,len,restr,adres %STRING (32) jstr %if TARGET=emas %or TARGET=Emasa %Start %result=0 %else restr=addr(jstr) adres=addr(jsvarstr) len=strlen(name) %IF len>32 %THEN ICL9CAERRNO=322 %AND OPEH(322,0,11,0) %FOR i=0,1,len-1 %CYCLE c=byteinteger(name+i) %IF CHCODE=EBCDIC %THEN c=ETOITAB(c) byteinteger(restr+i+1)=c %REPEAT byteinteger(restr)=len k=READ JS VAR(jstr,2,adres) %IF k#0 %THEN %RESULT=0 len=length(jsvarstr) %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,len %CYCLE byteinteger(adres+i)=ITOETAB(byteinteger(adres+i)) %REPEAT %FINISH byteinteger(adres+len)=0 %RESULT=adres+1 %Finish %END; {GETENV -(10.4.3)} %EXTERNAL %INTEGER %FN SETJMP %ALIAS "ICL9CASETJMP"(%INTEGER ad) !*********************************************************************** !* * !* Saves the call ing environment for later use by Longjmp * !* * !*********************************************************************** %IF target=emasa %START *L_1,AD *MVC_0(48,1),16(10) %ELSE *LXN_ad *LSQ_(%LNB +0) *ST_(%XNB +0) *STLN_(%XNB +3) %FINISH %RESULT=0 %END; {SETJMP -(6.1.1)} %EXTERNAL %ROUTINE LONGJMP %ALIAS "ICL9CALONGJMP"(%INTEGER ad,Val) !*********************************************************************** !* * !* Restores environment saved by most recent call to SETJMP * !* * !*********************************************************************** %IF Val=0 %THEN Val=1 %IF target=emasa %START *L_2,AD *mvc_16(48,10),0(2) *L_1,VAL %ELSE *LXN_ad *LSQ_(%XNB +0) *LCT_(%XNB +3) *ST_(%CTB +0) *LSS_Val *LLN_(%XNB +3) %FINISH %END; {LONGJMP -(6.2.1)} %EXTERNAL %INTEGER %FN SIGNAL %ALIAS "ICL9CASIGNAL"(%INTEGER sig,func) !*********************************************************************** !* * !* Signal handling * !* * !*********************************************************************** %INTEGER k %UNLESS 1<=sig<=6 %THEN ICL9CAERRNO=320 %AND %RESULT=-3 k=sg(sig) sg(sig)=func %RESULT=k %END; {SIGNAL -(7.1.1)} %EXTERNAL %INTEGER %FN KILL %ALIAS "ICL9CAKILL"(%INTEGER pid,sig) !*********************************************************************** !* * !* Sends the signal sig to the execution of the program * !* * !*********************************************************************** %INTEGER l %UNLESS 1<=sig<=6 %THEN ICL9CAERRNO=320 %AND %RESULT=320 l=sg(sig) sg(sig)=-2 {reset to SIG_DFL} %IF l=-1 %THEN %RESULT=0 %IF l=-2 %THEN OPEH(313+sig,0,11,0) %IF l=-3 %THEN OPEH(321,0,11,0) %IF target=emasa %START *MVC_64(4,11),SIG *L_1,L *stm_4,14,16(11) *LM_12,14,0(1) *BASR_15,14 %ELSE *LXN_l *PRCL_4 *LSS_sig *ST_ %TOS *RALN_6 *LD_(%XNB +0) *CALL_(%DR ) %FINISH %RESULT=0 %END; {KILL -(7.2.1)} { DATE AND TIME FUNTIONS D12 } %EXTERNAL %LONG %REAL %FN CLOCK %ALIAS "ICL9CACLOCK" !*********************************************************************** !* * !* Returns 0 if first call, otherwise the elapsed time in seconds * !* since the first call * !* * !*********************************************************************** %RESULT=CPUTIME %END; {CLOCK --(12.2.1)} %EXTERNAL %LONG %REAL %FN TIME %ALIAS "ICL9CATIME"(%INTEGER adtime) !*********************************************************************** !* * !* Returns the number of microseconds which have elapsed since * !* 1/1/1900 on VME and the number of seconds since 1/1/1970 on EMAS * !* * !*********************************************************************** %LONG %INTEGER l %INTEGER t %LONG %REAL r %IF Target=VME %THEN %START l=READ CPU CLOCK longinteger(addr(r))=l %IF adtime#Nul %THEN longinteger(adtime)=l %RESULT=r %FINISH %IF Target=EMAS %OR target=emasa %THEN %START t=Current Packed DT&X'7FFFFFFF' integer(addr(r))=0 integer(addr(r)+4)=t %IF adtime#Nul %THEN longinteger(adtime)=longinteger(addr(r)) %RESULT=longreal(addr(r)) %FINISH %END; {TIME --(12.2.2)} %EXTERNAL %INTEGER %FN ASCTIME %ALIAS "ICL9CAASCTIME"(%INTEGER adtime) !*********************************************************************** !* * !* Convert broken time in structure into a standard 26 byte string * !* * !*********************************************************************** %RECORD (timestruct) %NAME V %STRING (3) ts %INTEGER i V==record(adtime) strtime=wdayname(V_wday)." ".monname(V_mon)." " ts=ITOS(V_mday) %IF length(ts)=1 %THEN ts=" ".ts strtime=strtime.ts." " ts=ITOS(V_hour) %IF length(ts)=1 %THEN ts="0".ts strtime=strtime.ts.":" ts=ITOS(V_min) %IF length(ts)=1 %THEN ts="0".ts strtime=strtime.ts.":" ts=ITOS(V_sec) %IF length(ts)=1 %THEN ts="0".ts strtime=strtime.ts." 19" ts=ITOS(V_year) %IF length(ts)=1 %THEN ts="0".ts strtime=strtime.ts byteinteger(addr(strtime)+25)=nl byteinteger(addr(strtime)+26)=Nul %IF CHCODE=EBCDIC %THEN %START %FOR i=1,1,25 %CYCLE byteinteger(addr(strtime)+i)=ITOETAB(byteinteger(addr(strtime)+i)) %REPEAT %FINISH %RESULT=addr(strtime)+1 %END; {ASCTIME --(12.3.1)} %EXTERNAL %INTEGER %FN LOCALTIME %ALIAS "ICL9CALOCALTIME"(%INTEGER adtime) !*********************************************************************** !* * !* Converts calendar time pointed at by adtime into broken-down time * !* * !*********************************************************************** %LONG %INTEGER l %STRING (8) ldate,ltime %INTEGER k,ld,rem,t %IF Target=VME %THEN %START l=longinteger(adtime) DATE and TIME(l,ldate,ltime) %FINISH %IF Target=EMAS %OR target=emasa %THEN %START t=integer(adtime+4)!X'80000000' ldate=Unpack Date(t) ltime=Unpack Time(t) %FINISH TM_sec=STOI(Substring(ltime,7,8)) TM_min=STOI(Substring(ltime,4,5)) TM_hour=STOI(Substring(ltime,1,2)) TM_mday=STOI(Substring(ldate,1,2)) TM_mon=STOI(Substring(ldate,4,5))-1 TM_year=STOI(Substring(ldate,7,8)) TM_isdst=0 k=yday(TM_mon)+TM_mday %IF TM_mon>1 %AND TM_year&X'FFFFFF00'=TM_year %THEN k=k+1 TM_yday=k ld=k//7 rem=k-7*ld rem=dayone(TM_year)+rem %IF rem>6 %THEN rem=rem-7 TM_wday=rem %RESULT=addr(TM) %END; {LOCALTIME --(12.3.5)} %EXTERNAL %INTEGER %FN GMTIME %ALIAS "ICL9CAGMTIME"(%INTEGER adtime) !*********************************************************************** !* * !* Same as LOCAL TIME * !* * !*********************************************************************** %RESULT=LOCALTIME(adtime) %END; {GMTIME --(12.3.4)} %EXTERNAL %LONG %REAL %FN DIFFTIME %ALIAS "ICL9CADIFFTIME"(%LONG %REAL T2,T1) !*********************************************************************** !* * !* Computes the difference between T2 and T1 * !* * !*********************************************************************** %INTEGER it1,it2,d %IF Target=VME %THEN %RESULT=TIME DIFF(T2,T1) %IF Target=EMAS %OR target=emasa %THEN %START it1=integer(addr(T1)+4) it2=integer(addr(T2)+4) d=it2-it1 %RESULT=d %FINISH %END; {DIFFTIME --(12.3.3)} %EXTERNAL %INTEGER %FN CTIME %ALIAS "ICL9CACTIME"(%INTEGER adtime) !*********************************************************************** !* * !* Converts calendar time pointed at by adtime to standard string * !* * !*********************************************************************** %RESULT=ASCTIME(LOCALTIME(adtime)) %END; {CTIME --(12.3.2)} %ROUTINE OPEH(%INTEGER a,b,c,d) %EXTERNAL %ROUTINE %SPEC OPEH USER ERROR %ALIAS "S#OPEHUSERERROR"(%INTEGER err,info,lang,levels) OPEH USER ERROR(a,b,c,d) %END; {OPEH} %END %OF %FILE