!***********************************************************************
!* *
!* 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,<L2>
*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 %AND m=0 %AND i<nchs %CYCLE
c=byteinteger(add+i)
byteinteger(k)=c
n=n+1
k=k+1
i=i+1
%IF c=NL %OR c=FF %THEN m=1
%REPEAT
%IF m=1 %OR k=l %THEN %START
Buff to File(chan,FFinfo(chan)_Bufadd,k-FFinfo(chan)_Bufadd)
%FINISH %ELSE %START
FFinfo(chan)_Bufptr=FFinfo(chan)_Bufptr+n
%RESULT=nchs
%FINISH
%REPEAT
Btype(NoBuffType): {No buffer used at all}
Buff to File(chan,add,nchs)
%RESULT=nchs
Btype(FullBuffType): {Used for binary I/O}
k=nchs
i=0
%CYCLE
%IF k+Ffinfo(chan)_Bufptr<=FFinfo(chan)_Bufsize %THEN %START
Move(k,add+i,FFinfo(chan)_Bufadd+Ffinfo(chan)_Bufptr)
FFinfo(chan)_Bufptr=FFinfo(chan)_Bufptr+k
%RESULT=nchs
%FINISH %ELSE %START
m=FFinfo(chan)_Bufsize-FFinfo(chan)_Bufptr
Move(m,add+i,FFinfo(chan)_Bufadd+FFinfo(chan)_Bufptr)
i=i+m
Buff to File(chan,FFinfo(chan)_Bufadd,Bufsize)
FFinfo(chan)_Bufptr=0
k=k-m
%FINISH
%REPEAT
%END; {WRITE TEXT}
%INTEGER %FN READ TEXT(%INTEGER chan,add,nchs)
!***********************************************************************
!* *
!* Transfer data from specified channel to user's address space *
!* *
!***********************************************************************
%INTEGER Flag,c,i,j,k,l,m,n
%INTEGER %FN File to Buff(%INTEGER chan,add,nchs)
!***********************************************************************
!* *
!* Transfer data from file to buffer *
!* *
!***********************************************************************
%INTEGER l,m
l=FFinfo(chan)_Initcon+integer(FFinfo(chan)_Initcon)
%IF FFinfo(chan)_fptr+nchs>=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<Lb %OR 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 Strsize<len %THEN len=Strsize %AND Strsize=Default
l=len//255
m=len-255*l
Cfield=Field
Cstrsize=Strsize
Cljst=Ljst
%FOR n=0,1,l %CYCLE
%IF n=l %THEN b=m %ELSE b=255
Move(b,adstr+255*n,addr(strnum)+1)
byteinteger(addr(strnum))=b
%IF l=0 %THEN Integerf(Unset) %ELSE %START
%IF n=0 %THEN %START
Ljst=Unset
%IF Cfield#Default %THEN Field=Cfield-len+255
Integerf(Unset)
%FINISH %ELSE %IF 0<n<l %THEN %START
Ljst=Unset
Field=Default
Integerf(Unset)
%FINISH %ELSE %START
Ljst=Cljst
%IF Ljst=Set %AND Cfield#Default %THEN Field=Cfield-len+b
Integerf(Unset)
%FINISH
%FINISH
%IF CHCODE=EBCDIC %THEN %START
%FOR i=0,1,Inptr-1 %CYCLE
byteinteger(Ares+i)=ETOITAB(byteinteger(Ares+i))
%REPEAT
%FINISH
WRITE OUT(ChanIO,Ares,Inptr)
%REPEAT
%END; {PRINTs}
%ROUTINE printp(%INTEGER adstr,value)
!***********************************************************************
!* *
!* PRINTS VALUE *
!* *
!***********************************************************************
printx(adstr,value,'X')
%END; {PRINTp}
%ROUTINE printn(%INTEGER value)
!***********************************************************************
!* *
!* PRINTS VALUE *
!* *
!***********************************************************************
integer(value)=Outchars
%END; {PRINTn}
%ROUTINE RC(%INTEGER %NAME p)
!***********************************************************************
!* *
!* Read a character from current input stream *
!* *
!***********************************************************************
%INTEGER add,k
%IF ChanIO#-1 %THEN %START
%IF FFinfo(ChanIO)_eofmark=1 %THEN p=-1 %AND %RETURN
%IF ChanIO#Stdin %THEN %START
add=addr(p)+3
p=0
k=READ TEXT(ChanIO,add,1)
%IF k<0 %THEN OPEH(-k,0,11,0)
%IF k=0 %THEN FFinfo(ChanIO)_eofmark=1 %AND p=-1
FFinfo(ChanIO)_lastop=OPREAD
%RETURN
%FINISH %ELSE %START
Select Input(0)
Readch(p)
%IF p=EM %THEN %START
FFinfo(Stdin)_eofmark=1
p=-1
%FINISH
%FINISH
%FINISH %ELSE %START
p=byteinteger(restr+resptr)
%IF p=Nul %THEN p=-1 %AND %RETURN
%IF CHCODE=EBCDIC %THEN p=ETOITAB(p)
resptr=resptr+1
%FINISH
%END; {RC}
%INTEGER %FN iswspace(%INTEGER z)
!***********************************************************************
!* *
!* tests if character is white space character *
!* ISO character only *
!* *
!***********************************************************************
%IF z=' ' %OR z=HT %OR z=NL %OR z=-1 %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISWSPACE}
%ROUTINE Instring
!***********************************************************************
!* *
!* Process the format string for SCANF *
!* *
!***********************************************************************
%INTEGER p,q
p=byteinteger(ConadIO+PtrIO)
%IF p=Nul %THEN %RETURN
%WHILE p#Nul %CYCLE
%IF p='%' %THEN %START
PtrIO=PtrIO+1
%IF byteinteger(ConadIO+PtrIO)#'%' %THEN %RETURN
%FINISH
RC(q)
%IF iswspace(q)=1 %THEN %START
%WHILE iswspace(q)#0 %CYCLE
RC(q)
%REPEAT
%FINISH %ELSE %START
%IF p#q %THEN %START
Select Output(0)
Printstring("No matching ")
printch(p)
printstring(" on input channel")
write(ChanIO,4)
newline
%FINISH
%FINISH
PtrIO=PtrIO+1
p=byteinteger(ConadIO+PtrIO)
%REPEAT
%END; {INSTRING}
%ROUTINE DECODE S FORMAT(%INTEGER adstr)
!***********************************************************************
!* *
!* Decode input format string *
!* *
!***********************************************************************
%SWITCH sflag(0:255)
%INTEGER ptr,nch,flag,nval
Noassign=Unset
Infield=255
flag=0
ptr=1
%WHILE flag=0 %CYCLE
nch=byteinteger(adstr+ptr)
->sflag(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 cnt<Infield %AND '0'<=p<='9' %CYCLE
cnt=cnt+1
DBuff(cnt)=p
RC(p) %UNLESS cnt=Infield
%REPEAT
val=CCToInteger(ResAdd,4,cnt,addr(DBuff(1)),0)
Inchars=Inchars+1
%END; {SCAND}
%ROUTINE scani(%INTEGER stradd,resadd)
!***********************************************************************
!* *
!* READS IN AN INTEGER *
!* *
!***********************************************************************
%BYTE %INTEGER %ARRAY DBuff(0:15)
%INTEGER i,p,val,cnt
%STRING (63) strval
DECODE S FORMAT(stradd)
cnt=0
strval=""
%CYCLE
RC(p)
%REPEAT %UNTIL iswspace(p)=0
%IF p='0' %THEN %START
RC(p)
cnt=cnt+1
%IF p='x' %OR p='X' %THEN %START
RC(p)
cnt=cnt+1
%WHILE cnt<Infield %AND (('0'<=p<='9') %OR ('a'<=p<='f') %OR ('A'<=p<='F')) %CYCLE
cnt=cnt+1
strval=strval.To String(p)
RC(p) %UNLESS cnt=Infield
%REPEAT
strval=HtoI(strval)
%FINISH %ELSE %START
%WHILE cnt<Infield %AND '0'<=p<='7' %CYCLE
cnt=cnt+1
strval=strval.To String(p)
RC(p) %UNLESS cnt=Infield
%REPEAT
strval=OtoI(strval)
%FINISH
%FINISH %ELSE %START
%IF p='-' %OR p='+' %THEN %START
strval=strval.Tostring(p)
RC(p)
cnt=cnt+1
%FINISH
%WHILE cnt<Infield %AND ('0'<=p<='9') %CYCLE
cnt=cnt+1
strval=strval.To String(p)
RC(p) %UNLESS cnt=Infield
%REPEAT
%FINISH
String(addr(DBuff(0)))=strval
val=CCTo Integer(resadd,4,DBuff(0),addr(DBuff(1)),0)
Inchars=Inchars+1
%END; {SCANI}
%ROUTINE scano(%INTEGER stradd,resadd)
!***********************************************************************
!* *
!* READS IN OCTAL NUMBER *
!* *
!***********************************************************************
%BYTE %INTEGER %ARRAY DBuff(0:15)
%INTEGER i,p,val,cnt
%STRING (15) strval
DECODE S FORMAT(stradd)
cnt=0
strval=""
%CYCLE
RC(p)
%REPEAT %UNTIL iswspace(p)=0
%WHILE cnt<Infield %AND '0'<=p<='7' %CYCLE
strval=strval.To String(p)
cnt=cnt+1
RC(p) %UNLESS cnt=Infield
%REPEAT
strval=OtoI(strval)
String(addr(DBuff(0)))=strval
val=CCTo Integer(ResAdd,4,DBuff(0),addr(DBuff(1)),0)
Inchars=Inchars+1
%END; {SCANO}
%ROUTINE scanx(%INTEGER stradd,resadd)
!***********************************************************************
!* *
!* READS IN A HEXIDECIMAL NUMBER. *
!* *
!***********************************************************************
%BYTE %INTEGER %ARRAY DBuff(0:15)
%STRING (15) strval
%INTEGER val,i,p,cnt
DECODE S FORMAT(stradd)
cnt=0
strval=""
%CYCLE
RC(p)
%REPEAT %UNTIL iswspace(p)=0
%WHILE (cnt<Infield) %AND (('0'<=p<='9') %OR ('a'<=p<='f') %OR ('A'<=p<='F')) %CYCLE
strval=strval.To String(p)
cnt=cnt+1
RC(p) %UNLESS cnt=Infield
%REPEAT
strval=HtoI(strval)
String(addr(DBuff(0)))=strval
val=CCTo Integer(ResAdd,4,DBuff(0),addr(DBuff(1)),0)
Inchars=Inchars+1
%END; {SCANX}
%ROUTINE scanefg(%INTEGER stradd,ResAdd)
!***********************************************************************
!* *
!* READ IN FLOATING POINT NUMBER. *
!* *
!***********************************************************************
%INTEGER val,AdBef,AdAft,AdExp,i,p,cnt
%STRING (255) straft,strbef,strexp
%BYTE %INTEGER %ARRAY BefVal(0:255),AftVal(0:255),ExpVal(0:255)
%ROUTINE Nextp
cnt=cnt+1
RC(p) %UNLESS cnt=Infield
%END;
DECODE S FORMAT(stradd)
cnt=0
straft=""; strbef=""; strexp=""
%CYCLE
RC(p)
%REPEAT %UNTIL iswspace(p)=0
%IF p='+' %OR p='-' %THEN %START
strbef=To String(p).strbef
Nextp
%WHILE cnt<Infield %AND p=' ' %CYCLE
Nextp
%REPEAT
%FINISH
%WHILE cnt<Infield %AND ('0'<=p<='9') %CYCLE
strbef=strbef.To String(p)
Nextp
%REPEAT
%IF strbef="+" %OR strbef="-" %THEN strbef=strbef."0"
%IF p='.' %THEN %START
Nextp
%WHILE cnt<Infield %AND ('0'<=p<='9') %CYCLE
straft=straft.To String(p)
Nextp
%REPEAT
%FINISH
%IF p='E' %OR p='e' %THEN %START
Nextp
%WHILE cnt<Infield %AND p=' ' %CYCLE
Nextp
%REPEAT
%IF p='-' %OR p='+' %THEN %START
strexp=strexp.To String(p)
Nextp
%WHILE cnt<Infield %AND p=' ' %CYCLE
Nextp
%REPEAT
%FINISH
%WHILE cnt<Infield %AND ('0'<=p<='9') %CYCLE
strexp=strexp.To String(p)
Nextp
%REPEAT
%IF strexp="+" %OR strexp="-" %THEN strexp=strexp."0"
%FINISH
String(addr(BefVal(0)))=strbef
String(addr(AftVal(0)))=straft
String(addr(ExpVal(0)))=strexp
%IF BefVal(0)=0 %THEN AdBef=0 %ELSE AdBef=addr(BefVal(1))
%IF AftVal(0)=0 %THEN AdAft=0 %ELSE AdAft=addr(AftVal(1))
%IF ExpVal(0)=0 %THEN AdExp=0 %ELSE AdExp=addr(ExpVal(1))
val=CCTo Real(ResAdd,4,BefVal(0),AdBef,AftVal(0),AdAft,ExpVal(0),AdExp,0,0,0)
Inchars=Inchars+1
%END; {SCANEFG}
%ROUTINE scans(%INTEGER stradd,resadd)
!***********************************************************************
!* *
!* READS IN A STRING *
!* *
!***********************************************************************
%INTEGER ptr,i,p
DECODE S FORMAT(stradd)
ptr=0
%CYCLE
RC(p)
%REPEAT %UNTIL iswspace(p)=0
%WHILE iswspace(p)=0 %AND ptr<Infield %CYCLE
byteinteger(resadd+ptr)=p
ptr=ptr+1
RC(p) %UNLESS ptr=Infield
%REPEAT
byteinteger(resadd+ptr)=Nul
%IF CHCODE=EBCDIC %THEN %START
%FOR i=0,1,ptr-1 %CYCLE
byteinteger(resadd+i)=ITOETAB(byteinteger(resadd+i))
%REPEAT
%FINISH
Inchars=Inchars+1
%END; {SCANS}
%ROUTINE scanc(%INTEGER adstr,resadd)
!***********************************************************************
!* *
!* Read a character from input stream *
!* *
!***********************************************************************
%INTEGER k,p
RC(p)
%IF CHCODE=EBCDIC %THEN p=ITOETAB(p)
integer(resadd)=p
Inchars=Inchars+1
%END; {SCANC}
%ROUTINE scanp(%INTEGER adstr,value)
!***********************************************************************
!* *
!* Read a pointer *
!* *
!***********************************************************************
scanx(adstr,value)
%END; {SCANP}
%ROUTINE scann(%INTEGER resadd)
!***********************************************************************
!* *
!* Return number of character read so far on current SCAN *
!* *
!***********************************************************************
integer(resadd)=Inchars
%END; {SCANN}
%ROUTINE scanu(%INTEGER adstr,value)
!***********************************************************************
!* *
!* Read unsigned decimal number *
!* *
!***********************************************************************
scand(adstr,value)
%END; {SCANU}
%ROUTINE scansb(%INTEGER adstr,resadd)
!***********************************************************************
!* *
!* Square bracket in input format *
!* *
!***********************************************************************
%INTEGER i,j,p,endmark
i=2
j=0
p=byteinteger(adstr+i)
%IF p='^' %THEN %START
endmark=0
i=i+1
%FINISH %ELSE endmark=1
%CYCLE
p=byteinteger(adstr+i)
%IF p=']' %THEN %START
%IF endmark=1 %THEN %START
byteinteger(resadd+j)=p
j=j+1
%FINISH
%FINISH %ELSE %START
byteinteger(resadd+j)=p
j=j+1
i=i+1
%FINISH
%REPEAT %UNTIL p=']'
byteinteger(resadd+j)=Nul
%IF CHCODE=EBCDIC %THEN %START
%FOR i=0,1,j-1 %CYCLE
byteinteger(resadd+i)=ITOETAB(byteinteger(resadd+i))
%REPEAT
%FINISH
Inchars=Inchars+1
%END; {SCANSB}
%EXTERNAL %ROUTINE givdoub %ALIAS "ICL9CAGIVDOUB"(%LONG %REAL value)
!***********************************************************************
!* *
!* DOUBLE PASSED TO PRINTF FUNCTIONS. *
!* *
!***********************************************************************
%SWITCH CallPrint(0:255)
%STRING (255) str
%INTEGER d,ival
d=' '
%IF byteinteger(ConAdIO+PtrIO)=Nul %THEN %RETURN
str=Getform(d)
str=str.To String(Nul)
->CallPrint(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,<prstring>
%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,<valfail>
*DROP_2
%ELSE
*LXN_Res+4
*LSS_(%XNB )
*UAD_(%XNB +1)
*UAD_(%XNB +2)
*UCP_(%XNB +3)
*JCC_7,<valfail>
%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 x<l %AND x\=Startfreespace %CYCLE
Q==record(x)
Prevblock=x
x=Q_nextblock
%REPEAT
Prev==record(Prevblock)
Q==record(x)
%IF Prev_H0+Sizehead+Prevblock=l %AND Prevblock>Startfreespace %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 PTR<MAX PTR %AND TEXT(PTR)=0
!skip any leading zeros
!
! Now Convert Text into Binary
!
SUM=TEXT(MAX PTR)
MULT=BASE
%WHILE MAX PTR>PTR %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<MAX PTR %AND TEXT(PTR)=0
!ignore any leading zeros
MAX PTR=MAX PTR-1 %AND EXP=EXP+1 %WHILE MAX 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 EXP<Min Power %THEN ->FURTHER 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 SIZE<Min Power %THEN ->VALUE 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 EXP<Min Power %THEN %START
!
! Ignore digit which will have no effect on the Result
!
LEN=LEN+(EXP-Min Power)
EXP=Min Power
%FINISH
->FORM 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)
! 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)<BYTEINTEGER(THAT)
!
THIS=THIS+1
THAT=THAT+1
LENGTH=LENGTH-1
%REPEAT
! !
%RESULT=0 { equal to }
!
%END; !of COMPARE
%END; !of STRTOD
%FINISH {conditional compilation}
%EXTERNAL %INTEGER %FN RAND %ALIAS "ICL9CARAND"
!***********************************************************************
!* *
!* Compute next random number in pseudo-randon sequence *
!* *
!***********************************************************************
%IF target=emasa %START
*L_1,seed
*LM_2,3,Randmpy; ! is a long const
*MR_0,3
*AL_1,randadd
*ST_1,seed
%ELSE
*LSS_seed
*LUH_0
*IMY_randmpy
*ST_ %TOS
*LSS_randadd
*LUH_0
*IAD_ %TOS
*STUH_ %B
*ST_Seed
%FINISH
%RESULT=(Seed>>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 (' '<c<='~') %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISGRAPH}
%EXTERNAL %INTEGER %FN islower %ALIAS "ICL9CAISLOWER"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR LOWER CASE CHAR. *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN c=ETOITAB(c)
%IF ('a'<=c<='z') %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISLOWER}
%EXTERNAL %INTEGER %FN isprint %ALIAS "ICL9CAISPRINT"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR ANY PRINTING CHARACTER INCLUDING SPACE. *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN c=ETOITAB(c)
%IF (' '<=c<='~') %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISPRINT}
%EXTERNAL %INTEGER %FN ispunct %ALIAS "ICL9CAISPUNCT"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR ANY PRINTING CHARACTER EXCEPT *
!* SPACE DIGIT OR LETTER. *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN c=ETOITAB(c)
%IF (c=' ') %OR ('0'<=c<='9') %OR ('a'<=c<='z') %OR ('A'<=c<='Z') %THEN %RESULT=0 %ELSE %RESULT=1
%END; {ISPUNCT}
%EXTERNAL %INTEGER %FN isspace %ALIAS "ICL9CAISSPACE"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR SPACE,FORM FEED,HORIZONTAL TAB,NEWLINE, *
!* CARRIAGE RETURN OR VERTICAL TAB. *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN c=ETOITAB(c)
%IF c=' ' %OR c=FF %OR c=HT %OR c=nl %OR c=CR %OR c=VT %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISSPACE}
%EXTERNAL %INTEGER %FN isupper %ALIAS "ICL9CAISUPPER"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR UPPER CASE LETTER. *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN c=ETOITAB(c)
%IF ('A'<=c<='Z') %THEN %RESULT=1 %ELSE %RESULT=0
%END; {ISUPPER}
%EXTERNAL %INTEGER %FN isxdigit %ALIAS "ICL9CAISXDIGIT"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS NON ZERO FOR ANY HEX 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; {ISXDIGIT}
%EXTERNAL %INTEGER %FN tolower %ALIAS "ICL9CATOLOWER"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS CORRESPONDING LOWER CASE VALUE OF UPPER CASE CHAR *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN %START
c=ETOITAB(c)
%IF ('A'<=c<='Z') %THEN %RESULT=ITOETAB(c-'A'+'a') %ELSE %RESULT=ITOETAB(c)
%FINISH %ELSE %START
%IF ('A'<=c<='Z') %THEN %RESULT=c-'A'+'a' %ELSE %RESULT=c
%FINISH
%END; {TOLOWER}
%EXTERNAL %INTEGER %FN toupper %ALIAS "ICL9CATOUPPER"(%INTEGER z)
!***********************************************************************
!* *
!* RETURNS CORRESPONDING UPPER CASE VALUE OF LOWER CASE CHAR *
!* *
!***********************************************************************
%INTEGER c
c=z
%IF CHCODE=EBCDIC %THEN %START
c=ETOITAB(c)
%IF ('a'<=c<='z') %THEN %RESULT=ITOETAB(c-'a'+'A') %ELSE %RESULT=ITOETAB(c)
%FINISH %ELSE %START
%IF ('a'<=c<='z') %THEN %RESULT=c-'a'+'A' %ELSE %RESULT=c
%FINISH
%END; {TOUPPER}
{ (11.) STRING HANDLING }
{ (11.2) Copying Functions }
%EXTERNAL %INTEGER %FN memcpy %ALIAS "ICL9CAMEMCPY"(%INTEGER ads1,ads2,size)
!***********************************************************************
!* *
!* COPIES N CHARACTERS FROM ARRAY AT ADS2 INTO ADS1 *
!* *
!***********************************************************************
%INTEGER i
%IF target=emasa %THEN move(size,ads2,ads1) %ELSE %START
%IF size>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 n<dr0
dr0=dr0!x'18000000'
*LDTB_x'18ffffff'; !find null character in s1
*LDA_s1
*SWNE_ %L = %DR,0,0
*LSS_s2; !copy min(strlen(s2),n) onto end of s1
*LUH_dr0
*LDTB_dr0
*MV_ %L = %DR
*LDB_1; !append trailing null character
*MVL_ %L = %DR,0,0
%FINISH
%FINISH
%RESULT=s1
%END; {STRNCAT --(11.3.2)}
{ (11.4) Length and Comparison Functions }
%EXTERNAL %INTEGER %FN memcmp %ALIAS "ICL9CAMEMCMP"(%INTEGER s1,s2,n)
!***********************************************************************
!* *
!* COMPARES THE FIRST N BYTES OF ARRAY AT S2 WITH ARRAY AT S1. *
!* *
!***********************************************************************
%INTEGER i,a,b
%IF target=emasa %START
%FOR i=0,1,n-1 %CYCLE
a=byteinteger(s1+i)
b=byteinteger(s2+i)
%IF a>b %THEN %START
%RESULT=1
%FINISH %ELSE %IF a<b %THEN %START
%RESULT=-1
%FINISH
%REPEAT
%ELSE
%IF n>0 %THEN %START
*LDTB_x'18ffffff'
*LDB_n
*LDA_s2
*CYD_0
*LDA_s1
*CPS_ %L = %DR
*JCC_8,<eq>
*JCC_2,<gt>
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 a<b %THEN %START
%RESULT=-1
%FINISH
%REPEAT
%RESULT=0
%END; {MEMICMP --(11.4.2)}
%EXTERNAL %INTEGER %FN strcmp %ALIAS "ICL9CASTRCMP"(%INTEGER s1,s2)
!***********************************************************************
!* *
!* COMPARES THE STRING AT ADDRESS OF S1 WITH THAT OF S2. *
!* *
!***********************************************************************
%INTEGER dr0,dr1
%INTEGER i,a,b
%IF target=emasa %START
i=0
%CYCLE
a=byteinteger(s1+i)
b=byteinteger(s2+i)
%IF a>b %THEN %START
%RESULT=1
%FINISH %ELSE %IF a<b %THEN %START
%RESULT=-1
%FINISH
i=i+1
%REPEAT %UNTIL a=Nul
%RESULT=0
%ELSE
*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
*LDB_dr0; !compare s1 with s2
*LDA_s2
*CYD_0
*LDA_s1
*CPS_ %L = %DR
*JCC_8,<eq>
*JCC_2,<gt>
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 a<b %THEN %START
%RESULT=-1
%FINISH
i=i+1
%REPEAT %UNTIL a=Nul
%RESULT=0
%END; {STRICMP --(11.4.4)}
%EXTERNAL %INTEGER %FN strlen %ALIAS "ICL9CASTRLEN"(%INTEGER stradd)
!***********************************************************************
!* *
!* DELIVERS LENGTH OF STRING UP TO AND NOT INCLUDING NUL. *
!* *
!***********************************************************************
%INTEGER dr0,dr1
%INTEGER cnt
%IF target=emasa %START
cnt=-1
%CYCLE
cnt=cnt+1
%REPEAT %UNTIL byteinteger(stradd+cnt)=Nul
%RESULT=cnt
%ELSE
*LDTB_x'18ffffff'
*LDA_stradd
*SWNE_ %L = %DR,0,0
*STD_dr0
%RESULT=dr1-stradd
%FINISH
%END; {STRLEN --(11.6.2)}
%EXTERNAL %INTEGER %FN strncmp %ALIAS "ICL9CASTRNCMP"(%INTEGER s1,s2,n)
!***********************************************************************
!* *
!* COMPARES N CHARACTERS FROM THE STRING POINTED BY S1 AND THAT AT S2*.
!* *
!***********************************************************************
%INTEGER dr0,dr1
%INTEGER i,a,b
%IF target=emasa %START
i=0
%IF n=0 %THEN %RESULT=0
%FOR i=0,1,n-1 %CYCLE
a=byteinteger(s1+i)
b=byteinteger(s2+i)
%IF a>b %THEN %START
%RESULT=1
%FINISH %ELSE %IF a<b %THEN %START
%RESULT=-1
%FINISH
%IF a=Nul %THEN %RESULT=0
%REPEAT
%ELSE
%IF n>0 %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,<eq>
*JCC_2,<gt>
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 a<b %THEN %START
%RESULT=-1
%FINISH
%IF a=Nul %THEN %RESULT=0
%REPEAT
%RESULT=0
%END; {STRNICMP --(11.4.6)}
{ (11.5) Search Functions. }
%EXTERNAL %INTEGER %FN memchr %ALIAS "ICL9CAMEMCHR"(%INTEGER s,c,n)
!***********************************************************************
!* *
!* LOCATES THE FIRST OCCURRENCE OF C IN THE FIRST N CHARACTERS OF THE*
!* STRING STARTING AT S. *
!* *
!***********************************************************************
%INTEGER i
%INTEGER dr0,dr1
%IF target=emasa %START
%FOR i=0,1,n-1 %CYCLE
%IF byteinteger(s+i)=c %THEN %RESULT=s+i
%REPEAT
%RESULT=Nul
%ELSE
%IF n>0 %AND c>=0 %AND c<=255 %THEN %START
*LDTB_x'18ffffff'
*LDA_s
*LDB_n
*LB_c
*SWNE_ %L = %DR
*JCC_8,<not found>
*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,<not found>
*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