! ! m88p205f.3.i Sep93 pds Change in CRNAME to return correct size ! when recordarrayelement in a record has a record as a subname ! ! m88p205f.i 3Mar 92 PDS ! changes to allow record alignment to go to pass4 on record assignment %externalroutine ICL9CEZRS6IMP %constinteger RELEASE=4 %include "hostcodes.inc" ! %CONSTINTEGER HOST=mips %CONSTINTEGER TARGET=MIPS %CONSTINTEGER STANDARDPT=X'51' %CONSTINTEGER MINAPT=X'51'; ! MINIMUM PTYPE FOR WHICH ARITHMETIC ! OPERATORS ARE AVAILABLE %CONSTINTEGER MINAPREC=MINAPT>>4 %CONSTHALFINTEGERARRAY TYPEFLAG(0:12)=0, X'51'{%INTEGER}, X'52'{%REAL}, X'8009'{%LONG SOMETHING}, X'4031'{%BYTE}, X'35'{%STRING}, X'6051'{%HALF->%INTEGER+WARNING}, X'4041'{%SHORT}, X'33'{%RECORD}, 0, X'61'{%LONG INTEGER FAULT}, X'62'{%LONG REAL}, X'72'{%LONGLONGREAL WARN}; ! ! 2****15 SET FOR RELAY TO LOWER PART OF TYPEFLAGS ! 2****14 SET TO SKIP NEXT AR ENTRY FOR BYTE(INTEGER?) ETC ! 2****13 SET IF A DIFFERENT PRECISION USED GIVES WARNING ! 2****12 SET FOR COMBINATION WE CANT SUPPORT GIVES FAULT99 ! %CONSTBYTEINTEGERARRAY PTRSIZE(0:127)= %C 8,0(15) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 8,4,0,4,0,8,0,4,0(8) {PREC=3}, 8,4,0(14) {PREC=4}, 8,4,4,0(13) {PREC=5}, 8,0,4,0(13) {PREC=6}, 8,0(15) {PREC=7}; %CONSTBYTEINTEGERARRAY PTRROUNDING(0:3*128-1)=%C 3(128) {ALL PTRS IN RECORDS}, 3(128) {ALL PTRS IN STACK FRAMES}, 3(128) {ALL PTRS IN PARAMETERS}; %CONSTINTEGER SFRAMEMISALIGN=0; ! NEEDED ONLY FOR 2900 WHERE PRECALL ! MISALIGNS STACK FRAMES ! %CONSTINTEGER AHEADPT=X'61'; ! PTYPE OF ARRAYHEAD WHEN USED AS SCALAR %CONSTINTEGER AHEADSIZE=8; ! SIZE OF ARRAY HEAD(BYTES) %CONSTINTEGER MINPARAMSIZE=4; ! MINIMUM STACKABLE PARAMETER(BYTES) %CONSTINTEGER RTPARAMPT=X'51'; ! PTYPER OF RTPARAM WHEN USED AS SCALAR %CONSTINTEGER RTPARAMSIZE=4; ! SIZE OF RT PARAMETER (BYTES) %CONSTINTEGER ARRAYROUNDING=7; ! ALL ARRAYS TO 4 BYTE BNDR %CONSTINTEGER ARRAYINRECROUNDING=0; ! ARRAYS IN RECORDS TO 4 BYTE BOUNDARY %CONSTINTEGER STRVALINWA=YES; ! STRING VALUE PARAMETERS STACKED %CONSTINTEGER STRRESINWA=YES; ! STRING&RECORD FN RESULTS STACKED %CONSTINTEGER RECVALINWA=NO; ! Record values passed via work area ! %CONSTBYTEINTEGERARRAY RNDING(0:3*128-1)= %C {VALUES FOR SCALARS PTYPES 0->X'7F' IN SITUATIONS} {FIRST SITUATION IS IN RECORDS} {SECOND SITUATION IS IN STACK FRAMES} {THIRD SITUATION IS AS PARAMETERS} 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0(3),3,0,0,0(10) {PREC=3}, 0,1,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, 0,7,7,0(13) {PREC=6}, 0,7,7,0(13) {PREC=7}, 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0(3),3,0,1,0(10) {PREC=3}, 0,1,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, 0,7,7,0(13) {PREC=6}, 0,7,7,0(13) {PREC=7}, 0(16) {PREC=0}, 0(16) {PREC=1}, 0(16) {PREC=2}, 0,3,0,3,0,3,0(10) {PREC=3}, 0,3,0(14) {PREC=4}, 0,3,3,0(13) {PREC=5}, 0,7,7,0(13) {PREC=6}, {for non-SPARC} {0,3,3,0(13) PREC=6,} {for SPARC and RS6000} 0,7,7,0(13) {PREC=7}; %CONSTBYTEINTEGERARRAY BYTES(0:7)=0(3),1,2,4,8,16; %CONSTBYTEINTEGERARRAY WORDS(0:7)=0(3),1,1,2,4,8; %CONSTINTEGER DAREA=6; ! SPECIAL DIAGS AREA ON PERQ %CONSTINTEGER DVAREA=4; ! CONST DOPE VECTORS IN sst %CONSTINTEGER LHSADDRFIRST=NO; ! EVALUATE LHS ADDR BEFORE RHS ON ASSNMNT %CONSTINTEGER JRNDBODIES=NO; ! NO NEED TO JUMP ROUNT RT BODIES %CONSTINTEGER STACK DOWN=YES %CONSTINTEGER PARAMSBWARDS=NO; ! YES FOR REVERSED PARAMETERS %CONSTINTEGER DISPLAY NEEDED=YES; ! DISPLAY NEEDED IN LOCAL SPACE %CONSTINTEGER DISPLAY ROUNDING=7; ! Display on D-W bndry %CONSTINTEGER DISPLAY C1=4; ! 4 bytes per routine level on RS6000 %CONSTINTEGER DISPLAY C0=4; ! 4 for globals %CONSTINTEGER RTPARAM1OFFSET=0; ! OFFSET FROM LNB TO PARAM1 %CONSTINTEGER ALPHA=0; ! post parmeter linkage ! ! END OF CONCATENATED DEFINITIONS ! ! ! Recent Source Changes !********************** ! !* p205e.i !* 06/12/91 - Changes (pds) to base dictionary size directly on workfile !* and/or MAXDICT. Source file size is poor indicator in view !* of many large includes. !* ! Oct 89 Version 5 ! Chnages (mostly in CRCALL) to pass record values via work area & pointer ! for risc chips. Controlled by const integer in steering file ! ! DEc88 Version 3 produced ! Changes to note included procedures for Gould and others ! Also change to allow LINT &LINTPT to compile when lonlongs are treated as longs ! ! 8May87 Changes in FPlist so that RT Parameters are aligned according ! the rules of array Rnding ! ! ! Warning this module has the revised triples spec. ! ! In first attempt at Triple Imp considerable use was made of constant operands ! to pass information from Pass2 to GEN. Although for specialised operations%c like ! passing Labels this still applies, this adhocery has caused problems with%c arrays ! and pointers particularly in mapped records. The operands for four triples ! have thus been redefined in a more standard way. ! ! GETPTR X1 is now (ptype of passed)<<16! DIMENSION ! Opnd2 is either a 32 bit const with the size (ACC) as value or ! the ptr or arrayhead as normal operand. ! ! VMY X1 is now dim<<28!maxdim<<24!array name(where known) ! Opnd2 is either a 32 bit const with DV offset into const area or ! the arrayhead as a standard operand ! ! AINDX X1 is ELSIZE<<20 !spare ! Opnd2 is arrayhead as standard operand ! NOTE:- The Operands have been swopped for consistency with norm. ! ! BADJ X1 is arrayptype<<16!no of Dimensions (latter in case of backward%c dvs) ! Opnd2 exactly as for VMY ! !!{GT:}%include "impcompdate.inc" %const %string (9) LADATE="Apr 95"; ! LAST ALTERED %const %integer MAXRECSIZE=x'ffff' %const %integer NO OF SNS=67 %const %integer LRLPT=X'62' ! %const %integer MAXLEVELS=31,CONCOP=13 ! ! ! FIRST THE OPERAND FLAG CONSTANTS ! %CONSTINTEGER SCONST=0; ! CONST UPTO 64 BITS value is carried ! in opnd_d and opnd_xtra %CONSTINTEGER LCONST=1; ! CONST LONGER THAN SCONST const can be ! found elsewhere(at top of ar) by ! meanse of base&offset inf in_d and _xtra %CONSTINTEGER DNAME=2; ! NAME BY DICTIONARY NO the base and disp in ! the dictionary after adjusting by ! possible offset for item in ! in records lead to the variable %CONSTINTEGER ARNAME=3; ! NAME BY AR POINTER opnd_d the ar pointer ! this form local to pass2 ! and used to identify functions ! with params before the call ! is planted %CONSTINTEGER VIAPTR=4; ! VIA TRIPLE WITHOFFSET TO POINTER ! At an offset(_xtra) from address in ! referenced triple can be found a ! pointer to the required operand %CONSTINTEGER INDNAME=5; ! INDIRECT VIA DICTIONARY base&disp ! in dictionary identify a pointer ! variable at possible offset from ! this pointer %CONSTINTEGER INDIRECT=6; ! INDIRECT VIA TRIPLE WITH OFFSET ! the refenced triple has computed ! the (32bit) address of an item ! an offset may have to be applied ! before the fetch or store %CONSTINTEGER LOCALIR=7; ! BASE DISP REF IN CURRENT STACK FRAME ! opnd_b=base<<16!offset used only for ! compiler generated temporaries %CONSTINTEGER REFTRIP=8; ! REFERENCE TO A TRIPLE the operand is the result of ! triple opnd_d %CONSTINTEGER INAREG=9; ! REGISTER OPERAND this form is local to the ! code generating pass(es) %CONSTINTEGER developped=10; ! also local to generator %CONSTINTEGER DEVADDR=11; ! ALSO LOCAL TO GENERATOR %CONSTINTEGER BTREFMASK=1<>10 %if WORKA_FILE ADDR<=0 %then %start %if WORKA_FILE ADDR<-1 %then FILESIZE = IMOD(WORKA_FILE ADDR) %else %c FILESIZE = 64000 WORKA_FILE ADDR = 0 %finish %else %start SHDR == RECORD(WORKA_FILE ADDR) FILE SIZE = SHDR_ENDRA %finish ! ! Derive nnames form workfile K ignoring source size because of includes ! ! Note if nnames goes over 4095 the linking of arrayname parameters ! in sw(11) goes wong as their are only 12 bits left intags_uioj ! this is an absolute limit unless pds in prepared to be very ingenious ! WORKA_NNAMES = 1023 %if WORKA_WKFILEK>513 %then WORKA_NNAMES=2047 %if WORKA_WKFILEK>1000 %or PARM_BITS2&MAXDICT#0 %then WORKA_NNAMES = 4095 ASL = 3*WORKA_NNAMES ! %if ASL>4095 %and (HOST#EMAS %or PARM_BITS2&MAXDICT=0) %then ASL = 4095 WORKA_ASL MAX = ASL ARSIZE = WORKA_WKFILEK*(1024-BYTESPERKFORSOURCE)-300 %end %byte %integer %array %format AF(0:ARSIZE) %byte %integer %array %name A %record (LISTF) %array ASLIST(0:ASL) %integer %array TAGS(0:WORKA_NNAMES) %integer %array WORD(0:WORKA_NNAMES) %integer %array DVHEADS(0:12) %record (LEVELF) %array LEVELINF(0:MAXLEVELS) %record%format swdataform(%integer lseen,default,%integerarray slabs(0:1023)) %externalroutinespec free(%integer ad) %externalintegerfnspec malloc(%integer space) %external %routine %spec INITASL(%record (LISTF) %array %name A, %integer %name B) %externalroutinespec printtrips(%record(tripf)%arrayname trops) %externalroutinespec phex (%integer val) %external %integer %fn %spec MORE SPACE !%externalintegerfnspec NEWCELL %external %routine %spec INSERTATEND(%integer %name S, %integer A,B,C) %external %routine %spec INSERT AFTER(%integer %name S, %integer A,B,C) %external %routine %spec POP(%integer %name C,P,Q,R) %external %routine %spec PUSH(%integer %name C, %integer S1,S2,S3) %external %integer %fn %spec FIND(%integer LAB,LIST) %external %routine %spec BINSERT(%integer %name T,B, %integer S1,S2,S3) %external %routine %spec CLEARLIST(%integer %name HEAD) %external %routine %spec FILL DTABREFS(%integer %name HEAD) %external %routine %spec CXREF(%string (255) NAME, %integer MODE,XTRA, %integer %name AT) %external %routine %spec IMPABORT %external %routine %spec PROLOGUE(%record (LISTF) %array %name ALIST) %external %routine %spec EPILOGUE(%integer STMTS) %external %routine %spec PDATA(%integer AREA,BNDRY,L,AD) %external %routine %spec PRDATA(%integer AREA,BNDRY,L,REP,AD) %external %integer %fn %spec PINITOWN(%integer PTYPE,ACC, %record (RD) %name INIT, %string %name XNAME) %external %integer %fn %spec POWNARRAYHEAD(%integer PTYPE,J,LB,SIZE, AOFFSET,AAREA,DVOFFSET, %string (31) XNAME) %external %routine %spec FAULT(%integer A,B,C) %external %routine %spec WARN(%integer N,V) %external %routine %spec TRIP OPT(%record (TRIPF) %array %name T, %integer first TRIP) %external %routine %spec MOVE BYTES(%integer LENGTH,FBASE,FOFF,TOBASE,TOOFF) %external %routine %spec CTOP(%integer %name OP,MASK, %integer XTRA, %record (RD) %name OPND1,OPND2) %if HOST#TARGET %start %external %routine %spec REFORMATC(%record (RD) %name OPND) %external %routine %spec CHANGE SEX(%integer BASEAD,OFFSET,L) %finish %external %routine %spec GENERATE(%record (TRIPF) %array %name T, %integer CURRLEVEL, %routine GETWSP(%integer %name PL, %integer SIZE)) %externalstringfnspec printname (%integer jj) %external %routine %spec PRINTLIST(%integer HEAD) ! START OF COMPILATION K = host//10 %if k=0 %then k=1 K = BYTESPERKFORSOURCE//K; ! DISTINGUISH BYTE&WORD ADDRESSED%c HOSTS ! ALLOW FOR BYTE & WORD ADDRESS M-CS A == ARRAY(WORKA_WKFILE AD+K*WORKA_WKFILEK,AF) %begin !*********************************************************************** !* THIS BLOCK INITIALISE THE COMPILER SCALARS AND ARRAYS * !* WAS ORIGINALLY ROUTINE 'INITIALISE'. * !* THE INITIALISATION OF THE CONSTANT LISTS WITH THE VALUES * !* IN PERM MAY BE OMITTED IN BATCH OR CUT-DOWN VERSIONS. * !*********************************************************************** %external %integer %fn %spec PASSONE WORKA_CCSIZE = BYTESPERKFORSOURCE*(WORKA_WKFILEK-1); ! CCSIZE ALWAYS AS%c BYTES %byte %integer %array %format CCF(0:WORKA_CCSIZE) %byte %integer %array %name CC CC == ARRAY(WORKA_WKFILEAD+32,CCF) WORKA_CC == CC WORKA_A == A WORKA_WORD == WORD WORKA_TAGS == TAGS WORKA_LINE == LINE WORKA_N == N WORKA_RELEASE = RELEASE WORKA_LADATE = LADATE WORKA_AASL0 = ADDR(ASLIST(0)) WORKA_AMAINEP = ADDR(MAINEP) WORKA_LASTTRIP = WORKA_CCSIZE//40-2; ! 40 IS SIZE OF THE TRIP ARRAY %if WORKA_LASTTRIP>699 %then WORKA_LASTTRIP = 699 WORKA_OPTCNT = 0; ! ZERO COUNT OF OPTIMISATIONS worka_const ptr=1; ! leaving zero for dont knows WORKA_ASLIST == ASLIST PLABEL = 24999 N = 12; MAX ULAB = WORKA_NNAMES+16384; ! LARGEST VALID USER LABEL LAST INST = 0 SFLABEL = 20999 RLEVEL = 0; NMAX = 0; BFFLAG = 0 RBASE = 1 SSTL == CAS(4); USTPTR == CAS(5) STMTS = 1; SNUM = 0 BIMSTR = 0 WORKA_RTCOUNT = 1; ! ROUTINE 0 RESERVED FOR MAIN PROG MAINEP = "s#go"; ! DEFAULT MAIN ENTRY INITASL(ASLIST,ASL) %cycle I = 0,1,12 CAS(I) = 0; DVHEADS(I) = 0 %repeat ! DUMMY FORMAT = 0; ! DUMMY RECORD FORMAT PUSH(DUMMY FORMAT,0,0,0); ! FOR BETTER ERROR RECOVERY P1SIZE = PASSONE R = P1SIZE WORKA_ARTOP = P1SIZE %end; ! OF BLOCK CONTAINING PASS 1 %if PARM_FAULTY#0 %start COMREG(24) = 8 COMREG(47) = PARM_FAULTY %return %finish %begin !*********************************************************************** !* SECOND OR TRIPLES GENERATING PASS * !*********************************************************************** %record (LEVELF) %name CURRINF %integer TWSPHEAD,FORCNT,FORDPTH,FORCECNT,internalblockid %if HOST=EMAS %or HOST=IBM %or HOST=AMDAHL %or HOST=IBMXA %start ! LPUT BASED WORKFILE USED FOR OBJECT %record (TRIPF) %array TRIPLES(0:WORKA_LASTTRIP) %finish %else %start %record (TRIPF) %array %format TRIPLESFORM(0:WORKA_LASTTRIP) %record (TRIPF) %array %name TRIPLES TRIPLES == ARRAY(WORKA_WKFILEAD+32,TRIPLESFORM) %finish %integer %array %format CF(0:12*WORKA_NNAMES) %integer %array %name CTABLE !%routinespec NOTE CREF(%integer CA) !%routinespec STORE CONST(%integername D,%integer L,AD) !%integerfnspec WORD CONST(%integer VALUE) %routine %spec REUSE TEMPS %routine %spec GET WSP(%integer %name PLACE, %integer SIZE) %routine %spec RETURN WSP(%integer PLACE,SIZE) %routine %spec COMPILE A STMNT %routine %spec outsym(%integer sym) %routinespec force line %routine %spec outstring(%string(255) str) %routinespec outint(%integer id) %integer %fn %spec NEW TRIP %integer %fn %spec FROMAR4(%integer PTR) %integer %fn %spec FROMAR2(%integer PTR) %integer %fn %spec UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST) %integer %fn %spec ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2) %integer %fn %spec UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME) %integer %fn %spec UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP) %integer %fn %spec BRECTRIP(%integer OPERN,OPTYPE,FLAGS, %record (RD) %name OPND1,OPND2) %integer %fn %spec URECTRIP(%integer OPERN,OPTYPE,FLAG, %record (RD) %name OPND1) %routine %spec KEEPUSECOUNT(%record (RD) %name OPND) %routine %spec CSS(%integer P) %recordformat outform(%integer line,length,lastnl,prevlast,%bytearrayname l) %ownbyteintegerarray lspace(0:128*1024) %ownrecord(outform) opline %constinteger breakoplines=99 opline=0 opline_l==lspace %cycle I = 0,1,MAXLEVELS LEVELINF(I) = 0 LEVELINF(I)_NAMES = -1 %repeat CTABLE == ARRAY(ADDR(ASLIST(1)),CF) WORKA_CTABLE == CTABLE WORKA_LEVELINF == LEVELINF CTABLE(0) = M'CTAB' TWSPHEAD = 0 FORCNT = 0; ! COUNTS FORS TO DETECT NESTING FORDPTH = 0; ! COUNTS DEPTH OF NESTED FORS FORCECNT = 0; ! UPDATED WHEN TRIPLES FORCED OUT ! KEPT SO THAT GLAENING IS POSSIBLE internalblockid=0 PROLOGUE(ASLIST) LINE = 0 NEXTTRIP = 1 TRIPLES(0) = 0 NEXTP = 1; LEVEL = 1; STMTS = 0 CURRINF == LEVELINF(LEVEL) RLEVEL = 0; RBASE = 0 CURRINF = 0 CURRINF_CLEVEL = LEVEL CURRINF_NAMES = -1 ! %if target=gould %then currinf_maxpp = 8; ! max parameters passed %while A(NEXTP+3)!A(NEXTP+4)#0 %cycle COMPILE A STMNT %repeat outsym(NL) outstring("/* end of automatic translation */") outsym(NL) force line LINE = 99999 EPILOGUE(STMTS) %if PARM_FAULTY#0 %start COMREG(24) = 8 STMTS = PARM_FAULTY %else COMREG(24) = 0 %finish COMREG(47) = STMTS %if HOST=PERQ %start *RETURN; ! JUMP WONT REACH! %finish %else ->P2END %integerfn insert curly(%integer cad,at) !*********************************************************************** !* Adds in a curly bracket comment * !* Checks for the case of a C macro (Ist char #) %and reinserts * !* The 'comment' unchanged * !*********************************************************************** %integer i,j,k,scount,res %ownbytearray save (1:64*1024) scount=0 %if at >opline_length %then at=opline_length { should not happen } %for i=at,1,opline_length-1 %cycle scount=scount+1 save(scount)=opline_l(i) %repeat opline_length=at %if byteinteger(curlinead)#'#' { C macro } %start outsym(9) { Tab } outstring("/*") %else outsym('{') %finish j=cad i=0 %cycle j=j+1; i=i+1 %if byteinteger(j)=NL %or byteinteger(j)='}' %start %if byteinteger(curlinead)#'#' { C macro } %start outstring("*/") %else %if byteinteger(j)='}' %then outsym('}') %finish res=i+1 %exit %else opline_l(opline_length)=byteinteger(j) opline_length=opline_length+1 %finish %repeat %for i=1,1,scount %cycle opline_l(opline_length)=save(i) opline_length=opline_length+1 %repeat %result=res %end %integerfn locate curly(%integer cad) !*********************************************************************** !* Try to find where to insert a curly comment by counting commas * !*********************************************************************** %integer ccount,firstc,i,bcount,commaafter ccount=0; bcount=0; commaafter=0 ! ! first check if there is a comma after the curly comment ! i=cad i=i+1 %until byteinteger(i)='}' %or byteinteger(i)=NL %if byteinteger(i)='}' %start i=i+1 i=i+1 %while byteinteger(i)=' ' %if byteinteger(i)=',' %then commaafter=1 %and ccount=1 %finish %for i=cad,-1,curlinead %cycle %if byteinteger(i)=',' %start %if ccount=0 %then firstc=i ccount=ccount+1 %finish %repeat %if ccount=0 %then %result=opline_length %if commaafter=0 %start %for i=firstc,1,cad-1 %cycle %if 33<=byteinteger(i)<=127 %then bcount=bcount+1 %if byteinteger(i)='{' %or byteinteger(i)='}' %then bcount=bcount+1 %repeat %finish %for i=0,1,opline_length %cycle %if opline_l(i)=',' %or opline_l(i)=';' %start ccount=ccount-1 %if ccount=0 %then -> next %finish %repeat %result=opline_length next: !printstring("locate "); write(commaafter,1); write(bcount,0) ! write(opline_l(i),4); write(opline_l(i+1),4); newline %if commaafter#0 %then %result=i %if bcount=0 %then %result=i+1 %for i=i,1,opline_length %cycle %if 33<=opline_l(i)<=127 %then bcount=bcount-1 %if bcount=0 %then %start i=i+1 %while icurlinead %and curlinead#last linead %c %and nextlinead-curlinead <=2047 %start %for i=curlinead,1,nextlinead-1 %cycle %if byteinteger(i)='{' %then %start at=locate curly(i) i=i+insert curly(i,at) ! %if mode=1 %then warn(12,0) %finish %repeat last linead=curlinead { avoid multiple copies of curlies } %finish %end !* %routine force line !*********************************************************************** !* Push out current line after dealing with any missed or * !* faulty lines and merging back any {} comments * !*********************************************************************** %integer i,at %externalintegerspec filesseen %if filesseen=0 %or line <20000 %start { omit include ifiles if any } !printstring("Force line"); write(nextlinead,5); write(curlinead,5); write(lastlinead,5); newline ! %for i=curlinead,1,nextlinead %cycle ! printsymbol(byteinteger(i)) ! %repeat ! newline ! %for i=0,1,opline_length-1 %cycle ! printsymbol(opline_l(i)) ! %repeat ! newline ! printstring(" end of force line daignostics"); newline curlycheck(0) %return %if opline_length=0 %for i=0,1,opline_length-1 %cycle print symbol(opline_l(i)) %repeat newline %finish i=opline_length-1 i=i-1 %while I>0 %and (opline_l(i)='}' %or opline_l(i)=NL ) %if i>=0 %then opline_prevlast=opline_l(i) opline_length=0 opline_lastnl=-1 %end %routine outsym(%integer sym) %if sym=NL %then opline_lastnl=opline_length opline_l(opline_length)=sym opline_length=opline_length+1 %if currentSSalt=12{Const integers and constlists } %and sym=',' %c %and opline_length-opline_lastnl > breakoplines>>1 %start outsym(NL); %return %finish %if opline_length-opline_lastnl > breakoplines %start %if opline_l(opline_lastnl+1)#'#' %start %if sym=' ' %or sym=',' %or sym=')' %then outsym(NL) %finish %finish %end {outsym} !* %routine outsep !*********************************************************************** !* Outputs a semicolon avoiding obvious duplicates * !*********************************************************************** %integer i i=opline_length-1 %while i>=0 %and %c (opline_l(i)=NL %or opline_l(i)='}') %cycle i=i-1 %repeat ! printstring("Outsep i,l(i),prev="); write(i,1); space ! printsymbol(opline_l(i))%if i>=0 ! space; printsymbol(opline_prevlast); newline %if i>=0 %and opline_l(i)=';' %then %return %if i<0 %and opline_prevlast=';' %then %return outsym(';') %end {outsep} !* %routine outstring(%string(255) s) %integer i,j,sym j=opline_length %for i=1,1,length(s) %cycle sym=charno(s,i) %if sym=NL %then %start opline_l(j)='\'; opline_l(j+1)='n'; j=j+2 %finish %else %if sym='"' %start opline_l(j)='\'; opline_l(j+1)='"'; j=j+2 %else opline_l(j)=sym j=j+1 %finish %repeat opline_length=j %end %routine outcommentend %if opline_l(opline_length-1)#'*' %start {GT:} ! Let 'indent' take care of this ... !outsym(' ') %while opline_length-opline_lastnl <78 %finish outstring("*/") %end %string(255)%fn validname(%string(255) name) !*********************************************************************** !* Check name is not a C reserved word. If so amaned it * {GT:} ! Should also check for std library names??? !*********************************************************************** %constinteger nr=34+1 %conststring(11)%array rnames(0:nr)="sizeof","auto","static","extern","register", "typedef","char","short","long","int", "unsigned","float","double","void","enum", "struct","union","if","else","while", "do","for","switch","case","default", "break","continue","return","goto","abs", "fabs","volatile","asm","const","signed", { AND NOW LIBS }"exit" %integer i %for i=0,1,nr %cycle %if name=rnames(i) %then %start charno(name,1)=charno(name,1)-32 %result=name %finish %repeat %result=name %end !* %routine revisename(%string(255)%name name) %integer i %{if parm_quotes#0 %then} %return %for i=1,1,length(name) %cycle %if 'a'<=charno(name,i)<='z' %then charno(name,i)=charno(name,i)-32 %repeat %end !* %routine outname(%integer id) !*********************************************************************** !* produce name text from an id * !*********************************************************************** %integer i,ad %record(listf)%name lcell %string(255) name i=worka_word(id) ad=addr(worka_lett(i)) name=string(ad) lcell==aslist(worka_tags(id)) %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c %then revisename(name) name=validname(name) %unless lcell_ptype=x'156' { Dont revise switches CmcP } outstring(name) %if opline_length-opline_lastnl > breakoplines %start %if opline_l(opline_lastnl+1)#'#' %then outsym(NL) %finish %end !* %routine outswadname(%integer id) !*********************************************************************** !* output a sw name adjusting it if in an inner block !*********************************************************************** %integer i,ad %record(listf)%name lcell %string(255) name i=worka_word(id) ad=addr(worka_lett(i)) name=string(ad) lcell==aslist(worka_tags(id)) %if lcell_ptype&x'ff00'=x'4000' %and lcell_uioj&x'f0'=0 %c %then revisename(name) outstring(name) %if currinf_iblkid>0 %start outsym('_'); outint(currinf_iblkid) %finish %end %integerfn possible typename(%integer id,%stringname typename) !*********************************************************************** !* if id ends in "...type" set typename to ..._type * !*********************************************************************** %integer i,ad,j %string(255) name,firstpart,s,t i=worka_word(id) ad=addr(worka_lett(i)) name=string(ad) j=0; %while name -> s.("type").name %cycle %if j=0 %then firstpart=s %else firstpart=firstpart."type".s j=j+1 %repeat %if name="" %and length(firstpart)>3 %start { ended in ...type } typename=firstpart."_type" %result=1 %else typename="not_a_valid_type_name" %result=0 %finish %end %routine outrevisablename(%integer id) !*********************************************************************** !* produce name text from an id and revise without tag check * !*********************************************************************** %integer i,ad %string(255) name i=worka_word(id) ad=addr(worka_lett(i)) name=string(ad) revisename(name) outstring(validname(name)) %if opline_length-opline_lastnl > breakoplines %start %if opline_l(opline_lastnl+1)#'#' %then outsym(NL) %finish %end !* %routine out formatname(%integer kf) %integer i,kk %record(listf)%name lcell %string(255) s %for i=0,1,worka_nnames %cycle kk=tags(i) %if kk#0 %start lcell==aslist(kk) %if lcell_ptype&15=4 %and lcell_kform=kf %start %if possible typename(i,s)>0 %start outstring(s) %else %if lcell_ptype=4 %then outstring("struct ") %else outstring("union ") outname(i) %finish %return %finish %finish %repeat outstring(" ? unknown format name ?") ! %monitor %end !* !* %routine out extern(%integer extern) %if extern&3=0 %start outstring("static const ") %finish %else %if extern=1 %start outstring("static ") %finish %else %if extern=3 %start outstring("extern ") %finish %end %routine outhex(%integer value) %CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4", "5","6","7","8","9","A","B","C","D","E","F" %INTEGER I,digit %STRING(8)RES RES="" %FOR I=8<<2-4,-4,0 %CYCLE digit=VALUE>>I&15 %if res#"" %or digit#0 %then RES=RES.HEX(digit) %REPEAT %if res="" %then res="0" outstring("0x".res) %end %routine outtype(%integer type,kf) %if type=x'31' %start outstring("unsigned char ") %finish %else %if type=x'41' %start outstring("short int ") %finish %else %if type=x'51' %start outstring("int ") %finish %else %if type=x'61' %start outstring("INT64 ") %finish %else %if type=x'52' %start outstring("float ") %finish %else %if type=x'62' %start outstring("double ") %finish %else %if type=x'72' %start outstring("long double ") %finish %else %if type=x'35' %start outstring("char * ") %finish %else %if type=x'33' %start outformatname(kf) outsym(' ') %else outstring("void ") {GT:DEBUG outstring("/*");outhex(type);outstring("*/")} %finish %end {outtype } !* %routine outxtype(%integer xtype,kf) %integer rout,nam,arr,type rout=xtype>>12&1 nam=xtype>>10&3 arr=xtype>>8&3 type=xtype&7 outtype(xtype&255,kf) %if (rout#0 %or arr#0 %or nam&1#0) %and type#5 %then outsym('*') %end %routine outlhex(%integer msh,lsh) %CONSTSTRING(1)%ARRAY HEX(0:15)="0","1","2","3","4", "5","6","7","8","9","A","B","C","D","E","F" %INTEGER I,digit %string(16)res RES="" %FOR I=8<<2-4,-4,0 %CYCLE digit=msh>>I&15 %if res#"" %or digit#0 %then RES=RES.HEX(digit) %REPEAT %FOR I=8<<2-4,-4,0 %CYCLE digit=lsh>>I&15 %if res#"" %or digit#0 %then RES=RES.HEX(digit) %REPEAT %if res="" %then res="0" outstring("0x".res) %end {GT: outhex moved higher up} !* %routine outint(%integer value) !*********************************************************************** !* SIMPLE MINDED ALL IMP VERSION NOT USING STRINGS * !*********************************************************************** %INTEGER SIGN,WORK,PTR %BYTEINTEGERARRAY CH(0:15) %if value=x'80000000' %then outhex(value) %and %return SIGN=' ' %IF VALUE<0 %THEN SIGN='-' %AND VALUE=-VALUE PTR=0 %CYCLE WORK=VALUE//10 CH(PTR)=VALUE-10*WORK VALUE=WORK PTR=PTR+1 %REPEATUNTIL VALUE=0 WORK=PTR-1 OUTSYM(SIGN) %if sign='-' outSYM(CH(PTR)+'0') %FOR PTR=WORK,-1,0 %end !* %routine outinternames(%integer info) !*********************************************************************** !* output any intermediate (union) names needed to access * !* elements of imps more general record as C struct * !************************************************************************ %integer k,id %for k=12,-4,0 %cycle id=info>>k&15 %if id#0 %start %if id&8#0 %then %start outstring("s") outint(id&7) %else outstring("u") outint(id&7-1{ union update }) %finish outsym('.') %finish %repeat %end !* %ROUTINESPEC OUTFL (%LONGREAL X, %INTEGER N) %ROUTINE PRINT (%LONGREAL X, %INTEGER N,M) !*********************************************************************** !* PRINTS A REAL NUMBER (X) ALLOWING N PLACES BEFORE THE DECIMAL * !* POINT AND M PLACES AFTER.IT REQUIRES (M+N+2) PRINT PLACES * !* UNLESS (M=0) WHEN (N+1) PLACES ARE REQUIRED. * !* * !* A LITTLE CARE IS NEEDED TO AVOID UNNECESSARY LOSS OF ACCURACY * !* AND TO AVOID OVERFLOW WHEN DEALING WITH VERY LARGE NUMBERS * %CONSTLONGREAL DZ=0 !*********************************************************************** %LONGREAL Y,Z,ROUND,FACTOR %INTEGER I,J,L,MORIG %BYTEINTEGER SIGN M=M&63; ! DEAL WITH STUPID PARAMS MORIG=M %IF N<0 %THEN N=1; N=N&31; ! DEAL WITH STUPID PARAMS X=X+DZ; ! NORMALISE SIGN=' '; ! '+' IMPLIED %IF X<0 %THEN SIGN='-' Y=MOD(X); ! ALL WORK DONE WITH Y ROUND=0.5/10**M; ! ROUNDING FACTOR %IF Y>1.0*10**16 %OR N=0 %THENSTART; ! MEANINGLESS FIGURES GENERATED %IF N>M %THEN M=N; ! FOR FIXED POINT PRINTING OUTFL(X,M); ! OF ENORMOUS NUMBERS %RETURN; ! SO PRINT IN FLOATING FORM %FINISH I=0; Z=1; Y=Y+ROUND %UNTIL Z>Y %CYCLE; ! COUNT LEADING PLACES I=I+1; Z=10*Z; ! NO DANGER OF OVERFLOW HERE %REPEAT OUTSYM(SIGN) J=I-1; Z=10**J FACTOR=1/10 %CYCLE %UNTIL J<0 %CYCLE L=INT PT(Y/Z); ! OBTAIN NEXT DIGIT Y=Y-L*Z; Z=Z*FACTOR; ! AND REDUCE TOTAL OUTSYM(L+'0') J=J-1 %REPEAT %IF M=0 %THENEXIT; ! NO DECIMAL PART TO BE O/P OUTSTRING(".") J=M-1; Z=10**(J-1); M=0 Y=10*Y*Z %REPEAT %if MORIG>0 %start { Chop any redundant trailing 0s} opline_length=opline_length-1 %while %c opline_l(opline_length-1)='0' %and opline_l(opline_length-2)#'.' %finish %END; ! OF ROUTINE PRINT %ROUTINE OUTFL (%LONGREAL X, %INTEGER N) !*********************************************************************** !* PRINTS IN FLOATING POINT FORMAT WITH N PLACES AFTER THE * !* DECIMAL POINT. ALWAYS TAKES N+7 PRINTING POSITIONS. * !* CARE REQUIRED TO AVOID OVERFLOW WITH LARGE X * !*********************************************************************** %LONGREAL SIGN,ROUND,FACTOR,LB,UB %CONSTLONGREAL DZ=0 %INTEGER COUNT,INC inc=integer(addr(x)) %if inc>>20&x'7ff'=x'7ff' %start outstring("NAN {"); outhex(inc); outhex(integer(addr(x)+4)) outsym('}'); %return %finish ROUND=0.5/10**N; ! TO ROUND SCALED NO LB=1-ROUND; UB=10-ROUND SIGN=1 X=X+DZ; ! NORMALISE %IF X=0 %THEN COUNT=0 %ELSESTART %IF X<0 %THEN X=-X %AND SIGN=-SIGN INC=1; COUNT=0 FACTOR=1/10 %IF X<=1 %THEN FACTOR=10 %AND INC=-1 ! FORCE INTO RANGE 1->10 %WHILE X=UB %CYCLE X=X*FACTOR; COUNT=COUNT+INC %REPEAT %FINISH PRINT(SIGN*X,1,N) %if count#0 %start OUTSTRING("E") OUTINT(COUNT) %finish %END; ! OF ROUTINE OUTFL %routine FORCE TRIPS !*********************************************************************** !* FORCE OUT THE TRIPLES TO CODE. NEEDED IN CEND ETC * !*********************************************************************** triples(0)=0 nexttrip=1 triples(0)_flink=1 { return any triples } %end %routine COMPILE A STMNT %integer I force trips I = NEXTP STARSIZE = A(NEXTP)<<16+A(NEXTP+1)<<8+A(NEXTP+2) NEXTP = NEXTP+STARSIZE LINE = A(I+3)<<8+A(I+4) curlinead=fromar4(I+5) nextlinead=fromar4(NEXTP+5) STMTS = STMTS+1 opline_line=line CSS(I+9) %if a(NEXTP+3)<<8!A(NEXTP+4)=line %then %start curly check(1) outsym(9) %else force line %finish %end %integerfn nextstmntalt %result=a(NEXTP+9) %end %routine CSS(%integer Pinit) %routine %spec ENTER JUMP(%integer MASK,STAD,FLAG) %integer %fn %spec ENTER LAB(%integer M,FLAG) %routine %spec REMOVE LAB(%integer LAB) %routine %spec SAVE STACK PTR %routine %spec CEND(%integer KKK) %integer %fn %spec CCOND(%integer CTO,A,B,JFLAGS) %integer %fn %spec REVERSE(%integer MASK) %routine %spec SET LINE %routine %spec CUI(%integer CODE) %routine %spec ASSIGN(%integer A,B) %routine %spec CSTART(%integer CCRES,MODE) %routine %spec CCYCBODY(%integer UA,ELAB,CLAB) %routine %spec CLOOP(%integer ALT,MARKC,MARKUI) %routine %spec CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse) %integer %fn %spec CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND) %routine %spec TORP(%integer %name HEAD,BOT,NOPS,%integer mode) %integer %fn %spec INTEXP(%integer %name VALUE, %integer PRECTYPE) %integer %fn %spec CONSTEXP(%integer PRECTYPE) %routine %spec CSEXP(%integer MODE) %routine %spec labexp %routine %spec outopnd(%record(rd)%name opnd,%integer mode) %routine %spec outtriple(%integer tripno,mode) %routine %spec CSTREXP(%integer B) %routine %spec CRES(%integer LAB) %routine %spec EXPOP(%integer %name A,B, %integer C,D) %routine %spec TEST APP(%integer %name NUM) %routine %spec SKIP EXP %routine %spec SKIP APP %routine %spec NO APP %integer %fn %spec DOPE VECTOR(%integer A,B,C,MODE,ID) %routine %spec DECLARE ARRAYS(%integer A,B) %routine %spec DECLARE SCALARS(%integer B) %routine %spec CRSPEC(%integer M) %routine %spec CFPLIST(%integer %name A,B) %routine %spec CFPDEL %routine %spec CLT %integer %fn %spec ROUNDING LENGTH(%integer PTYPE,RULES) %routine %spec CQN(%integer P) %integer %fn %spec TSEXP(%integer %name VALUE) %integer %fn %spec tcond %routine %spec CRCALL(%integer RTNAME) %routine %spec NAMEOP(%integer Z,SIZE,NAMEP) %routine %spec CNAME(%integer Z) %routine %spec CANAME(%integer Z,ARRP, %record (RD) %name HDOPND) %routine %spec CSNAME(%integer Z) %routine %spec COPY TAG(%integer KK,DECLARE) %routine %spec REDUCE TAG(%integer DECLARE) %routine %spec STORE TAG(%integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK, KFORM) %routine %spec UNPACK %routine %spec PACK(%integer %name PTYPE) %routine %spec RDISPLAY(%integer KK) %routine %spec RHEAD(%integer RTNAME,AXNAME,Xtra) %integer %fn %spec CFORMATREF %routine %spec CRFORMAT(%integer myrflevel) %routinespec process format(%integer level,alt,structor union,intid, %integername strid,ophed,opbot) %integer %fn %spec DISPLACEMENT(%integer LINK) %integer %fn %spec COPY RECORD TAG(%integer %name SUBS) %integer %fn %spec CHK REC ALIGN(%integer p1) %switch SW(1:24) %const %byte %integer %array FCOMP(0:14)=0, 8,10,2,7,12,4,7, 8,12,4,7,10,2,7 %integer %array rfhead,rfbot(0:12,0:12),rfalt(0:12) %integer rflevel %integer P,SNDISP,ACC,K,KFORM,STNAME,MIDCELL %integer TCELL,JJ,JJJ,KK,QQ,MARKER,REPORTUI,XDISP,MASK,BASE,AREA, ACCESS,DISP,EXTRN,CURR INST,VALUE,STRINGL,PTYPE,I,J,OLDI,USEBITS, STRFNRES,MARKIU,MARKUI,MARKC,MARKE,MARKR,INAFORMAT %integer LITL,ROUT,NAM,ARR,PREC,TYPE,lhformatname,doinglabel %record (RD) EXPOPND,NAMEOPND,MLOPND; ! RESULT RECORD FOR EXPOP&CNAME ! ! on some machines global parameters are difficult to access hence ! copy pinit into local P which is frequently updated globally ! P = Pinit doinglabel=0 CURR INST = 0; INAFORMAT = 0 currentSSalt=a(p) ->SW(currentSSalt) SW(13): ! INCLUDE SOMETHING %begin %string(255) s,head,tail s=string(addr(a(P+2))) { File name} %if s-> head.(".inc").tail %then s=head.".h" outstring("#include "); outsym('"') outstring(s) outsym('"') %end ->cssexit2 SW(24): ! REDUNDANT SEP %if a(p+1)=10 %then outsym(' ') { extar neline } ->css exit2 SW(2): ! p=p+1 kk=a(p); p=p+1; ! kk=1 # comment, =2 ! comment, =3 %comment jj=a(p); jjj=0 %if KK=1 %then outsym('#') %else outstring("/*") { preserve any #defines in the imp} %while jj#NL %cycle %if JJ>128 %and jjj<128 %then outsym('%') outsym(jj&127) jjj=jj p=p+1; jj=a(p) %if jjj='\' %and JJ=13{CR} %and KK=1 %then outsym(NL) %and p=p+1 %and %continue %if jjj=',' %and ((kk=2 %and jj='!') %or (kk=1 %and jj='#')) %start { unscramble comments ending with a comma = continuation} %if kk=1 %start outsym(NL); outsym('#') %else outcommentend; outsym(NL) outstring("/*") %finish jjj=jj; p=p+1; jj=a(p) %finish %repeat %if kk>1 %then outcommentend ->CSSEXIT2 CSSEXIT: outsep %unless opline_length>0 %and opline_l(opline_length-1)='}' Cssexit2: LAST INST = CURR INST %return SW(1): !(UI)(S) ! FAULT(57,0,0) %unless LEVEL>=2 MARKER = P+1+A(P+1)<<8+A(P+2) P = P+3 ->LABFND %if A(MARKER)=1 %if A(MARKER)=2 %then SET LINE %and CUI(0) %and ->CSSEXIT MARKE = 0; MARKR = 0 MARKUI = P; MARKIU = MARKER+1 MARKC = MARKIU+1 %if A(MARKER)=3 %then %c CIFTHEN(MARKIU,MARKC,MARKUI,0,0,NO) %and ->CSSEXIT CLOOP(A(MARKIU),MARKC+2,MARKUI) ->CSSEXIT LABFND: OLDLINE = 0 ->SWITCH %unless A(P)=1 %and A(P+5)=2; ! 1ST OF UI AND NO APP ->SWITCH %unless A(P+6)=2 %and A(P+7)=2; ! NO ENAMSE OR ASSNMNT JJ = ENTER LAB(FROM AR2(P+3),0) outname(from ar2(P+3)) outsym(':'); curly check(0); outsym(NL); %if 1<CSSEXIT2 SW(5): ! %cycle ! FAULT(57,0,0) %unless LEVEL>=2 %if A(P+5)=2 %then %start; ! OPEN CYCLE CLOOP(0,P+1,P+1) %finish %else %start SET LINE CLOOP(6,P+6,P+1) %finish ->CSSEXIT ! SW(6): ! REPEAT ->CSSEXIT2 SW(22): ! '%CONTROL' (CONST) ->CSSEXIT2 ! SW(3): ! (%iu)(COND)%then(UI)(ELSE') MARKIU = P+1; MARKC = MARKIU+3 MARKR = P+2+A(P+2)<<8+A(P+3); ! ! FROMAR2(P+2) MARKE = 0 %if A(MARKR)=3 %then %start MARKE = MARKR+1+FROMAR2(MARKR+1) MARKUI = MARKR+3 %finish CIFTHEN(MARKIU,MARKC,MARKUI,MARKE,MARKR,NO) ->CSSEXIT SW(4): ! '%FINISH(ELSE')(S) SW(18): ! '%ELSE' MEANING FINISH ELSE START ->CSSEXIT2 SWITCH: %begin; ! SWITCH LABEL %record (LISTF) %name LCELL %record(swdataform)%name swdata %integer NAPS,FNAME FNAME = FROM AR2(P+3) %unless A(P)=1 %and A(P+5)=1 %then FAULT(5,0,FNAME) %and ->BEND ! 1ST OF UI + APP P = P+6 COPY TAG(FNAME,NO) %if OLDI#LEVEL %or TYPE#6 %then FAULT(4,0,FNAME) %and ->BEND LCELL==aslist(k) swdata==record(LCELL_S1) swdata_slabs(swdata_lseen)=p swdata_lseen=swdata_lseen+1 outswadname(fname); outstring("_"); labexp; outsym(':') curly check(0); outsym(NL); %if 1<CSSEXIT2 SW(23): ! SWITCH(*): %begin %record (LISTF) %name LCELL %record(swdataform)%name swdata %integer FNAME,JJ,RES FNAME = FROM AR2(P+1) COPY TAG(FNAME,NO) %if OLDI=LEVEL %and TYPE=6 %start LCELL == ASLIST(K) swdata==record(LCELL_S1) swdata_default=p outswadname(fname); outstring("_default:") %finish %else FAULT(4,0,FNAME) %end FORCE TRIPS %if PARM_OPT=0 ->CSSEXIT2 ! SW(7): ! (%wu)(SC)(COND)(RESTOFWU) ! FAULT(57,0,0) %unless LEVEL>=2 MARKIU = P+1; ! TO WHILE/UNTIL MARKC = MARKIU+3; ! TO (SC)(COND) CLOOP(A(MARKIU)+3,MARKC,MARKIU+1+FROMAR2(MARKIU+1)) ->CSSEXIT ! SW(8): ! SIMPLE DECLN ! FAULT(57,0,0) %unless LEVEL>=2 P = P+1 MARKER = P+FROMAR2(P); ! TO ALT OF DECLN P = P+2; ROUT = 0; LITL = 0 %if A(MARKER)#1 %then %start; ! ARRAY DECLARATIONS CLT %if TYPE=5 %and (ACC<=0 %or ACC>256) %then %c FAULT(70,ACC-1,0) %and ACC = 255 NAM = 0 SET LINE QQ = 2-A(P+1); P = P+2; ! QQ=1 FOR ARRAYFORMATS DECLARE ARRAYS(QQ,KFORM) %if qq=1 %then ->cssexit2 { ignore formats } FORCE TRIPS %if PARM_OPT=0 %finish %else %start CLT CQN(P+1); P = P+2 DECLARE SCALARS(KFORM) %finish ->CSSEXIT ! SW(9): ! %end %begin %switch S(1:5) %integer etype etype=A(P+1) ->S(etype) S(1): ! ENDOFPROGRAM {GT:} outstring("exit(0);"{"imp_stop();"}); outsym(NL) S(2): ! ENDOFFILE %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2 FAULT(15,LEVEL+PARM_CPRMODE-3,0) %unless LEVEL+PARM_CPRMODE=3 CEND(PARM_CPRMODE) outsym('}') %if etype=1 ->BEND S(3): ! ENDOFLIST ->BEND S(4): ! END %if PARM_CPRMODE=1 %and LEVEL=2 %then FAULT(14,0,0) %else %c CEND(CURRINF_FLAG) outstring("}"); ! outstring(" /* proc */") BEND: %end ->CSSEXIT2 ! SW(11): %begin %integer MARKER1,RTNAME,KKK,PTR,PTYPEP,CNT,PP,PCHAIN,AXNAME, PNAME,NPARAMS,SCHAIN,PARMSPACE,D,PARAMPTYPE,PARAMACC,pcount %record (LISTF) %name LCELL,LCELL2,TCELL P = P+1; MARKER1 = FROM AR2(P)+P; ! (SEX)(RT)(SPEC')(NAME)(FPP) markc=a(marker1) AGN: Q = P; RTNAME = FROM AR2(MARKER1+3); ! RTNAME ON NAME EXTRN = A(P+2); ! 1=SYSTEM,2=EXTERNAL ! 3=DYNAMIC, 4=INTERNAL LITL = EXTRN&3 %if A(MARKER1)=1 %then %start; ! P<%spec'>='%spec' P = P+3; CRSPEC(1-EXTRN>>2); ! 0 FOR ROUTINESPEC ! 1 FOR EXTERNAL (ETC) SPEC ->BEND %finish FORCE TRIPS; ! IN CASE OPTIMISING COPY TAG(RTNAME,NO) AXNAME = ADDR(WORKA_LETT(WORD(RTNAME))) %if EXTRN=3 %then EXTRN = 2 %if TARGET=EMAS %and EXTRN=1 %then WARN(11,0) %if A(MARKER1+5)=1 %then %start;! extract alias name MOVE BYTES(A(MARKER1+6)+1,ADDR(A(0)),MARKER1+6,ADDR(A(0)), WORKA_ARTOP) AXNAME = ADDR(A(WORKA_ARTOP)) WORKA_ARTOP = (WORKA_ARTOP+4+A(MARKER1+6))&(-4) %finish %if EXTRN=4 %then AXNAME = 0 %if OLDI#LEVEL %then %start; ! NAME NOT KNOWN AT THIS LEVEL P = Q+3; CRSPEC(2); P = Q; ->AGN %finish %else %start; ! NAME ALREADY KNOWN AT THIS LEVEL %if PARM_CPRMODE=0 %then PARM_CPRMODE = 2; ! FLAG AS FILE OF%c ROUTINES FAULT(56,0,RTNAME) %unless %c EXTRN=4 %or (PARM_CPRMODE=2 %and LEVEL=1) %if A(P+3)=1 %then KKK = LITL<<14!X'1000' %else %start ROUT = 1; P = P+4; ! FIGURE OUT PTYPE FOR FNS&MAPS CLT; ARR = 0; NAM = 0 %if A(P)=2 %then NAM = 2; ! SET NAME ARRAY BIT FOR MAPS PACK(KKK); ! AND STORE PTYPE IN KKK %finish %finish ! ! UNLESS A MATCH WAS OBTAINED BETWEEN HEADING AND SPEC SOMETHING ! HAS GONE WRONG. COMPILE HEADING AGAIN AS SPEC. THIS WILL ! PREVENT ANY INCONSISTENCIED AND CAUSE A "NAME SET TWICE" ! FOR ANY ERROR ! %unless (J=15 %or J=7*EXTRN) %and PTYPE&X'FFFF'=KKK %start P = Q+3; CRSPEC(2); P = Q; ->AGN %finish {GT:} ! BUG !!! %externalroutinespec fred(%int i) ! translates to void fred(void) PTYPE = PTYPE!(EXTRN&3)<<14; ! DEAL WITH %routinespec FOLLOWED ! BY %externalroutine ! ! RESET THE TAGS TO BODY GIVEN AND ALLOWING FOR SPEC/EXTERNALROUTINE ! AND EXTERNALSPEC/EXTERNAL ROUTINE COMBINATIONS. RESTORE THE USE ! BITS WHICH WILL SHOW USED AS A RESULT OF THE COPY TAG IN THIS SEQUENCE ! TCELL == ASLIST(TAGS(RTNAME)) TCELL_PTYPE <- PTYPE %if PTYPE&x'c000'=x'8000' %then USEBITS = 2; ! externals presumed%c 'used' TCELL_UIOJ <- TCELL_UIOJ&X'3FF0'!USEBITS<<14 ! NEWPTYPE & SET J=0 %if (target=Perq %or Target=Accent) %and J=14 %then %c TCELL_S2 = WORKA_RTCOUNT %and WORKA_RTCOUNT = WORKA_RTCOUNT+1 ! NO RT NO ALLOCATED TO EXTERNAL SPECS PTYPEP = PTYPE %if ptypep&x'c000'=0 %then outstring("static ") outtype(ptypep&255,tcell_kform) %if ptypep&x'800'#0 %and ptypep&7#5 %then outsym('*') %if axname=0 %then outname(rtname) %else outstring(string(axname)) outsym('(') PCHAIN = TCELL_SLINK; ! CHAIN OF PARAMETER DESCRIPTUONS RHEAD(RTNAME,AXNAME,fromar2(marker1+1));! FIRST PART OF ENTRY SEQUENCE ! ! NOW DECLARE THE FORMAL PARAMETERS. FOLLOW BY CLAIMING DISPLAY ! AND SETTING DIAGNOSTIC PTR IN ROUTINE RDISPLAY ! P = MARKER1+6 %if A(P-1)=1 %then P = P+A(P)+1; ! SKIP OVER ALIASNAME CNT = 0 PTYPE = PTYPEP; UNPACK N = RTPARAM1OFFSET %if TARGET=PERQ %or TARGET=ACCENT %start %if TYPE#0 %then N = (BYTES(PREC)+1)&(-2) %if TYPE=5 %or TYPE=3 %then N = 4; ! MAPS %if NAM#0 %then %start %if TYPE=5 %then N = 4 %else N = PTRSIZE(PTYPE&127) ! BYTE MAPS RETURN BYTE PTR %finish CURRINF_RESSIZE = N %finish NPARAMS = 0; PARMSPACE = 0 %if PCHAIN#0 %then NPARAMS = ASLIST(PCHAIN)_S3 %if NPARAMS#0 %then %c PARMSPACE = NPARAMS>>16 %and NPARAMS = NPARAMS&X'FF' ! ALLOW ACTUAL PARAMETER SPACE %while A(P)=1 %cycle; ! WHILE SOME (MORE) FP PART PP = P+1+FROMAR2(P+1) P = P+3 CFPDEL PARAMPTYPE = PTYPE; PARAMACC = ACC; ! may get cahnged for rt%c types PTR = P %until A(PTR-1)=2 %cycle; ! CYCLE DOWN NAMELIST %if PARAMS BWARDS=YES %start; ! MAP PCHAIN TO REVERSE ORDER%c LIST PCHAIN = TCELL_SLINK PCHAIN = ASLIST(PCHAIN)_LINK %for KKK = 2,1,NPARAMS-CNT %finish LCELL == ASLIST(PCHAIN); ! EXTRACT PTYPE XTRA INFO %if PCHAIN#0 %then %start %unless LCELL_PTYPE=PARAMPTYPE %and %c LCELL_ACC&x'FFFF'=PARAMACC %then FAULT(9,CNT+1,RTNAME) %finish PNAME = FROM AR2(PTR); ! NAME FOR PARAM INTERNALLY LCELL_UIOJ <- LCELL_UIOJ!PNAME<<4; ! SAVED IN LIST( max 12 bits!) D = LCELL_SNDISP+N; ! PARAMETER OFFSET %if PARAMPTYPE&x'1000'#0 %start; ! PROCEDURE PARAMETERS P = PTR P = P+3 %until A(P-1)=2 CFPLIST(SCHAIN,KKK); ! PARAMETERLIST FOR PASSED PROC PTYPE = PARAMPTYPE; ! CHANGED BY CFPLIST outtype(paramptype&255,kform); outname(pname); outstring("(") lcell2==aslist(schain) %if KKK=0 %then outstring("void ") %else %start %for pcount=1,1,KKK %cycle %if lcell2_s1&x'10000000'#0 %start outtype(lcell2_s1>>16&255,lcell2_sndisp); outstring("()") %else outxtype(lcell2_s1>>16,lcell2_sndisp) %finish %if lcell2_link#0 %then outsym(',') lcell2==aslist(lcell2_link) %repeat %finish outstring(")") STORETAG(PNAME,LEVEL,RBASE,13,D,LCELL_ACC,SCHAIN,0) %finish %else %start %if TARGET=EMAS %and PTYPE=X'33' %then D = D+8 ! FOR HISTORIC PARAMTER COMPATABILITY %if STRVALINWA=YES %and PTYPE=X'35' %then PTYPE = X'435' ! %if recvalinwa=yes %and ptype=X'33' %and acc#4 %then ptype=x'433' outxtype(paramptype,kform); outname(pname); STORE TAG(PNAME,LEVEL,RBASE,LCELL_UIOJ&15,0,ACC,D,KFORM) PTYPE = PARAMPTYPE %finish PTR = PTR+3 CNT = CNT+1 PCHAIN = LCELL_LINK %if PARAMS BWARDS=NO outsym(',') %unless pchain=0 %repeat P = PP %repeat; ! UNTIL NO MORE FP-PART outstring(") {") N = N+PARMSPACE N = (N+MINPARAMSIZE-1)&(-MINPARAMSIZE); ! TO WORD BOUNDARY AFTER%c ALL SYSTEM ! STANDARD PARAMETERS HAVE BEEN%c DECLARED FAULT(8,0,RTNAME) %if CNT>NPARAMS FAULT(10,0,RTNAME) %if CNTcssexit2 ! SW(14): ! %begin %begin FORCE TRIPS; ! IN CASE OPTIMISING PTYPE = 0 %if LEVEL=1 %and RLEVEL=0 %start %if PARM_CPRMODE=0 %then %start RLEVEL = 1; RBASE = 1 PARM_CPRMODE = 1 RHEAD(-1,ADDR(MAINEP),1) N = RTPARAM1OFFSET+alpha outstring("main() {") %finish %else FAULT(58,0,0) %finish %else %start SET LINE; ! SO 'ENTERED FROM LINE' IS OK outstring("{") RHEAD(-1,0,1) %finish RDISPLAY(-1) %end ->CSSEXIT2 ! SW(15): ! '%ON'(EVENT')(N)(NLIST)'%start' ! Shouldn't we compile a CSTART(..., 3) here? ... Yes! - code supplied by PDS: p=p+2; skip exp; %while a(p)=1 %cycle p=p+1 skip exp %repeat p=p+1 outstring("if (0) {") outsym(NL) cstart(0,3) outstring(" }") ! and in cstart, do... %if code=3 %then outstring("#endif /* On event */") %and outsym(NL) ! so ... where is the %FINISH handled if not there??? ->CSSEXIT SW(16): %begin; ! %switch (SWITCH LIST) %integer Q,RANGE,KKK,LB,UB,PP,D0,OPHEAD,V,R,datad %record (RD) OPND1,OPND2 %record(swdataform)%name swdata ! FAULT(57,0,0) %unless LEVEL>=2 Q = P %until A(Q)=2 %cycle; ! UNTIL NO'REST OF SW LIST' P = P+3 P = P+3 %while A(P)=1 P = P+4; ! TO P(+') KKK = INTEXP(LB,MINAPT); ! EXTRACT LOWER BOUND P = P+3 KKK = KKK!INTEXP(UB,MINAPT); ! EXTRACT UPPER BOUND RANGE = (UB-LB+1) %if RANGE<=0 %or KKK#0 %start LB = 0; UB = 10; RANGE = 1024 %finish datad=malloc(4*range+8) swdata==record(datad) swdata_lseen=0; swdata_default=0 PTYPE = X'56'+1<<8; ! WORD LABEL ARRAY PP = P; P = Q+1 %until A(P-1)=2 %cycle; ! DOWN NAMELIST K = FROM AR2(P) P = P+3 OPHEAD = 0 OPND1_PTYPE <- PTYPE OPND1_XB = 0 OPND1_FLAG = DNAME OPND1_D = K OPND1_XTRA = 0 OPND2_PTYPE = X'61' OPND2_XB = 0 OPND2_FLAG = DNAME OPND2_D = LB OPND2_XTRA = UB V = BRECTRIP(DCLSW,PTYPE,0,OPND1,OPND2) PUSH(OPHEAD,datad,LB,UB) STORE TAG(K,LEVEL,RBASE,1,0,4,OPHEAD,0) {GT:} outstring("int "); outswadname(k); outstring("_value;") {GT:} outstring("int "); outswadname(k); outstring("_line;") {GT:} outstring("char *"); outswadname(k); outstring("_file;") %repeat; ! FOR ANY MORE NAMES IN NAMELIST Q = PP; P = Q %repeat; ! UNTIL A(Q)=2 %end; ->CSSEXIT2 ! SW(17): ->CSSEXIT ! SW(12): ! '%OWN' (TYPE)(OWNDEC) %begin !*********************************************************************** !* INITIALISED DECLARATION GO INTO THE GLA OR GLA SYMBOL TABLES * !* EXCEPT FOR CONST ARRAYS WHICH GO INTO THE CODE SYMBOL TABLES * !* STRINGS AND ARRAYS HAVE A HEADER IN THE GLA. QPUT ARRANGES * !* FOR THE LOADER TO RELOCATE THE HEADERS. * !* EXTERNALS ARE IDENTICAL WITH OWN BUT ALSO HAVE A DATA EP DEFN * !* IN THE LOAD DATA SO THEY CAN BE FOUND AT LOAD TIME * !* EXTRINSICS HAVE A DATA REFERENCE AND A DUMMY HEADER IN THE GLA* !* THE LOADER USES THE FORMER TO RELOCATE THE LATTER. * !*********************************************************************** %routine %spec CLEAR(%integer L) %routine %spec XTRACT CONST(%integer CONTYPE,CONPREC) %routine %spec INIT SPACE(%integer A,B) %integer SLENGTH,PP,SIGN,TAGDISP,DVO,K,STALLOC,SPOINT,tp,savep, CONSTSFOUND,CPREC,EXTRN,NNAMES,MARK,QPUTP,LB,CTYPE,CONSTP, FORMAT,DPTYPE,DIMEN,SACC,TYPEP,KK,orlevel,savesndisp,savekform,II %record (RD) COPND,FCOPND %own %long %real ZERO=0 %string (255) SCONST,NAMTXT %record (LISTF) %name LCELL QPUTP = 5; ! NORMAL CASE GLA SYMBOLTABLES EXTRN = A(P+1) P = P+2 %if EXTRN>=4 %then EXTRN = 0; ! CONST & CONSTANT->0 SNDISP = 0 CONSTS FOUND = 0 %if EXTRN=0 %then QPUTP = 4 CLT ! ! CHECK FOR %spec AND CHANGE EXTERNAL SPEC TO EXTRINSIC ! %if A(P+2)=1 %start %if EXTRN=2 %then EXTRN = 3 %else FAULT(46,0,0) %finish %if 2<=EXTRN<=3 %and ((A(P)=1 %and A(P+1)#3) %or (A(P)=2 %and %c A(P+1)#2)) %then FAULT(46,0,0) %if type=5 %and a(p)#1 %and extrn=0 %then extrn=1 LITL = EXTRN %if LITL<=1 %then LITL = LITL!!1 %if A(P)=1 %then CQN(P+1) %else ARR = 1 %and NAM = 0 %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c FAULT(70,ACC-1,0) %and ACC = 2 STALLOC = ACC; ! ALLOCATION OF STORE FOR ITEM OR%c POINTER %if (TARGET=PERQ %or TARGET=ACCENT %or TARGET=PNX) %and %c TYPE=5 %then STALLOC = (STALLOC+1)&X'FFE' ROUT = 0; PACK(PTYPE); DPTYPE = PTYPE; ! FOR DECLARATION %if NAM#0 %start; ! OWN POINTERS %if ARR#0 %then STALLOC = 8 %else STALLOC = 4 %finish %else %start; ! OWN VARS & ARRAYS ->NON SCALAR %if ARR#0 %finish P = P+2 %until A(MARK)=2 %cycle; ! UNTIL NULL MARK = P+1+FROM AR2(P+1) PP = P+3; P = PP+2; ! PP ON FIRST NAME' K = FROM AR2(PP); ! FOR ERROR MESSAGES RE CONST NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K)))) %if A(P)=1 %then %start; ! ALAIS GIVEN %if LITL=0 %then WARN(10,0) LENGTH(NAMTXT) = A(P+1) CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1) P = P+A(P+1)+1 outstring("#define "); outname(k); outsym(' ') outstring(namtxt); outsym(NL) %finish P = P+1; ! P ON CONST' ! ! OBTAIN THE INITIAL CONSTANT,ITS TYPE(CTYPE) AND SIGN(SIGN) ! SCONST = "" PTYPE = DPTYPE; UNPACK; ! MAY HAVE BEEN CONSTANT EVALUATIONS ! WHICH HAVE CHANGED PTYPE SIGN = 3; CTYPE = TYPE; CONSTSFOUND = 0; CPREC = PREC %if TYPE=3 %then CTYPE = 1; ! RECS INITTED TO REPEATED BYTE %if NAM#0 %then CTYPE = 1 %and CPREC = 5 P = P+1 %if RLEVEL=0 %and EXTRN=0 %start outstring("#define ") outrevisablename(k) %else out extern(EXTRN) %if ptype=x'35' %then outstring("char ") %else outtype(ptype&255,kform) %if nam#0 %then outsym('*') outname(k) %finish %if ptype=x'35' %then %start outstring(" ["); outint(stalloc); outsym(']') %finish tp=1 %if A(P-1)=1 %then %start; ! CONSTANT GIVEN savep=p; p=p-3; tp=tsexp(kk); p=savep %if RLEVEL=0 %and EXTRN=0 %start outstring(" "); outstring("(") %if tp<=0 %else outsym('=') %finish XTRACT CONST(CTYPE,CPREC) %finish %else %start WARN(7,K) %if EXTRN=0; ! %const NOT INITIALISED FCOPND = 0; COPND = 0 %finish %if RLEVEL=0 %and EXTRN=0 %start outsym(')') %if tp<=0 %else outsep %finish outsym(NL) %unless a(MARK)=2 PTYPE = DPTYPE; UNPACK; ! MAY HAVE BEEN CONSTANT EVALUATIONS ! WHICH HAVE CHANGED PTYPE J = 0; orlevel = 0 %if NAM#0 %then %start; ! OWNNAMES AND ARRAYNAMES %if ARR=0 %then %start %if (target=ibm %or target=amdahl %or target=ibmxa) %and %c extrn=0 %start tagdisp = worka_const ptr %if type=5 %then ctable(tagdisp)=acc %and %c worka_const ptr=worka_const ptr+1 ctable(worka_const ptr) = fcopnd_d worka_const ptr = worka_const ptr+1 %if worka_const ptr>worka_const limit %then %c fault(102,worka_wkfilek,0) tagdisp = 4*tagdisp; orlevel = 14 %finish %else TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT) %finish %else %start; ! ARRAYNAMES ! DVO = DOPE VECTOR(NO,TYPE,ACC,-1,K,QQ,LB) %if PARM_COMPILER#0 %and LB#0 %then FAULT(99,0,0) %if EXTRN#0 %then SNDISP = 0 %and J = 0 %else %c J = 1 %and SNDISP = (SNDISP&X'3FFFF')>>2 TAGDISP = POWNARRAYHEAD(PTYPE,J,LB,X'FFFFFF',COPND_D,0, DVO,NAMTXT) %finish STORE TAG(K,LEVEL,orlevel,J,SNDISP,ACC,TAGDISP,KFORM) P = MARK %continue %finish %if EXTRN=3 %then %start; ! EXTRINISIC ! PTYPE = PTYPE!X'400'; ! FORCE NAM=1 (IE VIA POINTER) FCOPND_D = 0 TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT) STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM) P = MARK %continue %finish %if TYPE=3 %then %start; ! RECORDS TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT) %finish %if 1<BEND NONSCALAR: ! OWN AND OWNRECORD ARRAYS !*********************************************************************** !* OWN ARRAYS CAN BE INITIALISED BUT ONLY ONE ARRAY CAN BE * !* DECLARED IN A STATEMENT.(THANK HEAVENS!) * !* OWN RECORD ARRAYS ARE INITIALISED AS BYTE ARRAYS * !*********************************************************************** P = P+1 FORMAT = 2-A(P) %if FORMAT#0 %then arr=3 %and pack(ptype) PP = P+2; P = P+4; NNAMES = 1 K = FROM AR2(PP) NAMTXT = STRING(ADDR(WORKA_LETT(WORD(K)))) %if A(P)=1 %then %start; ! ALAIS GIVEN %if LITL=0 %then WARN(10,0) LENGTH(NAMTXT) = A(P+1) CHARNO(NAMTXT,KK) = A(P+KK+1) %for KK = 1,1,A(P+1) P = P+A(P+1)+1 %finish P = P+1; ! P ON CONSTLIST SACC = ACC; TYPEP = PTYPE; savekform=kform DVO = DOPE VECTOR(NO,TYPE,STALLOC,0,K) %if SNDISP=-1 %then SNDISP = 0; ! BUM DOPE VECTOR SNDISP = (SNDISP&X'3FFFF')>>2; ! AS WORD DISPLACEMENT savesndisp=sndisp { Not proof against C-T concatenation !} DIMEN = J; ! SAVE NO OF DIMENESIONS ACC = SACC; PTYPE = TYPEP; UNPACK PP=p %if format=0 %start outextern(EXTRN) outtype(ptype&255,savekform) outname(k) %for ii=dimen,-1,1 %cycle p=ctable(savesndisp+3*ii+2) outstring(" [") csexp(x'51') %if ctable(savesndisp+3*ii)=x'80000000'%start outsym('-'); p=ctable(savesndisp+3*ii+1) outsym('('); csexp(x'51'); outstring(")+1") %finish %else %if ctable(savesndisp+3*ii)<1 %start outsym('+'); outint(1-ctable(savesndisp+3*ii)) %finish %else %if ctable(savesndisp+3*ii)>1 %start outsym('-'); outint(ctable(savesndisp+3*ii)-1) %finish outsym(']') %repeat %finish PTYPE = TYPEP; UNPACK %if LB=0 %and FORMAT=0 %then ARR = 2 %and PACK(PTYPE) %if TYPE=3 %then SLENGTH = QQ %else SLENGTH = QQ//STALLOC ! NO OF ELEMENTS cas(qputp)=(cas(qputp)+arrayrounding)&(\arrayrounding) SPOINT = cas(qputp) %if FORMAT=0 %then %start %if A(PP)=1 %then P = PP+1 %and INIT SPACE(QQ,SLENGTH) %finish outsep %if format=0 %if EXTRN=3 %then SPOINT = 0 ! ! OUTPUT AN ARRAYHEAD INTO THE GLA RELATIVE TO THE START OF THE SYMBOL- ! TABLES IN WHICH THE ARRAY RESIDES. ! PTYPE = TYPEP; UNPACK %if Format#0 %then qputp=0 { avoid data fixup in pownarrayhead} TAGDISP = POWNARRAYHEAD(PTYPE,dimen,LB,QQ,SPOINT,QPUTP,DVO,NAMTXT) SNDISP=savesndisp STORE TAG(K,LEVEL,0,dimen,SNDISP,ACC,TAGDISP,saveKFORM) ->BEND %routine INIT SPACE(%integer SIZE,NELS) !*********************************************************************** !* P IS TO FIRST ENTRY FOR CONSTLIST * !* MAP SPACE ONTO WORKFILE END TO GIVE SANE ERROR MESSAGE IF * !* THERE WAS NOT ENOUGH SPACE * !*********************************************************************** %const %integer BUFSIZE=512 %integer RF,I,II,ELSIZE,AD,SPP,SLENGTH,WRIT,PIN,PP,contype,conprec,ppp,value pIN=p; contype=type conprec=prec outstring(" = {") SPP = 0; WRIT = 0 %until A(P-1)=2 %cycle p=p-3; PP=p; skip exp %if A(P)=1 %start; ! REPITITION FACTOR P = P+2 %if A(P-1)=2 %then %start { * found issue warning } RF = 1 { Except for 0(*) when detectable } %unless a(PP+3)=4 %and a(PP+4)=2 %and a(PP+5)=x'41' %andc a(PP+6)=a(PP+7)=0 %and a(PP+8)=2 %then warn(10,0) %finish %else %start P = P+2 %if INTEXP(RF,MINAPT)#0 %then warn(10,0) %and RF = 1 %finish P = P+1 %finish %else RF = 1 %and P = P+2 warn(10,0) %if RF<=0 spp=p %cycle I = RF,-1,1 p=pp %if contype=5 %then cstrexp(1) %else csexp(conprec<<4!contype) consts found=consts found+1 outsym(',') %unless i=1 %and a(spp-1)=2 { very last const} %if (contype=5 %and consts found&3=0) %or consts found&7=0 %c %then outsym(NL) %repeat p=spp %repeat outstring("}") %end %routine XTRACT CONST(%integer CONTYPE,CONPREC) !*********************************************************************** !* P POINTS TO P<+'> OF <+'> AND IS UPDATED* !* THE CONST IS CONVERTED TO REQUIRED FORM AND IF INTEGER * !* IS LEFT IN ICONST, IF REAL IN RCONST AND IF STRING IN SCONST * !*********************************************************************** %integer SLENGTH,STYPE,SACC,MODE,CH,WR,I,PP STYPE = PTYPE; SACC = ACC; ! MAY BE CHANGED IF CONST IS EXPR %if CONTYPE=5 %then %start P = P-3; CSTREXP(1) WR = WORKA_ARTOP %if EXPOPND_FLAG=LCONST %and EXPOPND_PTYPE=X'35' %start SLENGTH = EXPOPND_XTRA LENGTH(SCONST) = SLENGTH A(WR) = SLENGTH %for I = 1,1,SLENGTH %cycle CH = A(EXPOPND_D+I) CHARNO(SCONST,I) = CH A(WR+I) = CH %repeat COPND_PTYPE = X'35'; COPND_FLAG = LCONST COPND_D = EXPOPND_D COPND_XTRA = SLENGTH %finish %else %start FAULT(44,CONSTS FOUND,K); SCONST = "" SLENGTH = 0 %finish %finish %else %start MODE = CONPREC<<4!CONTYPE %if CONPREC<5 %then MODE = CONTYPE!X'50' PP=P; p=p-3; csexp(mode) p=pp; I = CONSTEXP(MODE) { Evaluate again to get storeable value } ! %if CONSTP=0 %then FAULT(41,0,0) ! CANT EVALUATE EXPT COPND = EXPOPND; ! GET RESULT OPND COPND_PTYPE = MODE %finish PTYPE = STYPE; UNPACK; ACC = SACC FCOPND = COPND %end BEND: %end; ->CSSEXIT2 SW(10): %begin; ! %recordformat (RDECLN) %integer NAME,OPHEAD,OPBOT,NLIST,HeadCell,FHEAD,SPEC,l1,l2,strid,fpt %record (LISTF) %name LCELL,FRCELL %string(255) typename SNDISP = 0 SPEC = A(P+1); ! 1 FOR SPEC 2 FOR FORMAT NAME = FROM AR2(P+2); P = P+4 COPY TAG(NAME,NO) %if SPEC=1 %or %not (PTYPE=4 %and J=15 %and OLDI=LEVEL) %start KFORM = 0 PUSH(KFORM,0,0,0) PTYPE = 4 STORE TAG(NAME,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM) ! IN CASE OF REFS IN FORMAT %finish %if SPEC=2 %start ophead=0; opbot=0; nlist=0 %for l1=0,1,12 %cycle %for l2=0,1,12 %cycle rfhead(l1,l2)=0 rfbot(l1,l2)=0 %repeat rfalt(l1)=0 %repeat INAFORMAT = 1 rflevel=0 crformat(rflevel) INAFORMAT = 0 %if PARM_Z#0 %start %for l1=0,1,12 %cycle %for l2=0,1,12 %cycle %if rfhead(l1,l2)#0 %start printstring("level&rfalt="); write(l1,5); write(l2,5); newline printlist(rfhead(l1,l2)) %finish %repeat %repeat %finish strid=0; { for generating internal names } HeadCell=rfhead(0,1) %if HeadCell=0 %start { No alternatives at top level } outstring("struct "); outname(name) outsym('{'); outsym(NL) process format(0,0,'s',0,strid,ophead,opbot) fpt=4 %else outstring("union "); outname(name) outsym('{'); outsym(NL) process format(0,0,'u',0,strid,ophead,opbot) fpt=x'14' %finish outsym('}'); outsym(';'); outsym(NL) %if PARM_Z#0 %start printstring("after processing") printlist(ophead) %finish %if possible typename(name,typename)#0 %start outsym(NL) outstring("typedef ") %if HeadCell=0 %start { No alternatives at top level } outstring("struct ") %else outstring("union ") %finish outname(name) outstring(" ".typename.";") outsym(NL) %finish CLEAR LIST(NLIST) ! ! IN CASE OF FORWARD REFS COPY TOP CELL OF FORMAT CHAIN INTO DUMMY ! SET UP BEFORE CALL OF CRFORMAT. ALSO RESET J&ACC TO CORRECT VALUE LCELL == ASLIST(TAGS(NAME)) KFORM = LCELL_KFORM %if PARM_Z#0 %start printstring("before throwing dummy cell") printlist(kform) %finish POP(KFORM,I,I,FHEAD); ! THROW DUMMY CELL ! GET HEAD OF FORWARD REFS fhead=ophead %while FHEAD>0 %cycle; ! THROUGH format changeFORWARD REFS FRCELL == ASLIST(fhead) %if frcell_ptype=x'433' %and frcell_kform=lcell_kform %start FRCELL_UIOJ = FRCELL_UIOJ&X'FFFFFFF0'; ! SET J BACK TO 0 FRCELL_ACC <- ACC; ! ACC TO CORRECT VALUE FRCELL_KFORM = OPHEAD; ! CORRECT KFORM %finish fhead=frcell_link %repeat LCELL_UIOJ = LCELL_UIOJ&X'FFFFFFF0'; ! J BACK TO ZERO LCELL_ACC <- ACC LCELL_SLINK = name; ! KFORM&SLINK TO SIDECHAIN & name LCELL_PTYPE=fpt { To distinguish unions from structs } LCELL_KFORM = OPHEAD %if PARM_Z#0 %start printstring("after processing self refs") printlist(ophead) %finish %finish %end; ->CSSEXIT2 ! SW(19): ! '*' (UCI) (S) ! FAULT(57,0,0) %unless LEVEL>=2 outstring("***Untranslateable stmnt***") i=curlinead %while iCSSEXIT SW(20): ! '%TRUSTEDPROGRAM' PARM_COMPILER = 1 %if PARM_ARR=0 %and PARM_CHK=0; ->CSSEXIT SW(21): ! '%MAINEP'(NAME) KK = FROM AR2(P+1) FAULT(97,0,0) %unless PARM_CPRMODE=0 MAINEP <- STRING(ADDR(WORKA_LETT(WORD(KK)))) ->CSSEXIT %integer %fn CFORMATREF !*********************************************************************** !* P IS TO ALT OF FORMAT REF * !* P::=(NAME),(RFDEC)(RESTOFRFDEC)(ALTRFDEC) * !* RETURNS CELL NO OF TOP CELL OF THE FORMATLIST * !*********************************************************************** %integer FNAM,OPHEAD,OPBOT,NHEAD,MRL %record (LISTF) %name LCELL %if A(P)=1 %start; ! A RECORD OF RECORDFORMAT NAME FNAM = FROM AR2(P+1) P = P+3 COPY TAG(FNAM,NO) %if 3<=TYPE<=4 %then %result = KFORM %if INAFORMAT#0 %and OLDI#LEVEL %start PTYPE = 4; ACC = MAXRECSIZE PUSH(KFORM,0,0,0) STORE TAG(FNAM,LEVEL,RBASE,15,0,MAXRECSIZE,KFORM,KFORM) %result = KFORM %finish FAULT(62,0,FNAM); ! NOT A RECORD OF FORMAT NAME ACC = 8; ! GUESS A RECORD SIZE %result = DUMMY FORMAT %finish ! FORMAT ACTUALLY SPECIFIED P = P+1 OPHEAD = 0; OPBOT = 0 outstring("*** imp construction too difficult***") %result = OPHEAD %end %routine CRFORMAT(%integer myrflevel) !*********************************************************************** !* CONVERTS A RECORDFORMAT STATEMENT TO A LIST HEADED BY OPHEAD * !* FORMAT OF AN ENTRY. * !* S1=SUBNAME<<20!PTYPE<<4!J * !* S2,S3=4 16 BIT DISPLACEMENTS D2,ACC,D1,KFORM * !* NORMALLY D1=RECORD RELATIVE DISPLACEMENT AND ACC=LMAX(STRINGS)* !* FOR ARRAYS D2=FIRST ELEMENT DISPLACEMENT AND D1=DISPLACEMENT * !* OF RECORD RELATIVE ARRAYHEAD IN THE GLA * !* KFORM IS ONLY USED FOR RECORDS AND POINTS TO THE FORMAT * !* ON EXIT ACC HAS THE RECORD SIZE ROUNDED UP TO THE BOUNDARY * !* REQUIRED BY ITS LARGEST COMPONENT * !*********************************************************************** %integer D1,D2,FORM,RL,STALLOC,INC,Q,R,RFD,LB,TYPEP,SACC,DVO %routine %spec SN(%integer Q) %routine %spec ROUND FORM = 0; ACC = 0 INC = 0; ! INC COUNTS DOWN RECORD %cycle ROUT = 0; LITL = 0; NAM = 0; RFD = A(P) P = P+1 %if RFD=1 %then %start CLT FORM = KFORM STALLOC = ACC P = P+1 %if A(P-1)=1 %start ! (TYPE) (QNAME')(NAMELIST) FORM = KFORM CQN(P); P = P+1 PACK(PTYPE); D2 = 0 RL = ROUNDING LENGTH(PTYPE,0) %if NAM=1 %then %start STALLOC = PTRSIZE(PREC<<4!TYPE) RL=PTRrounding(ptype&127) %if ARR#0 %then STALLOC = AHEADSIZE %and RL=ROUNDINGLENGTH(AHEADPT,0) %finish fault(70,0,0) %if type=5 %and stalloc=0 ROUND; J = 0 %until A(P-1)=2 %cycle D1 = 0; SN(P) P = P+3; INC = INC+STALLOC %repeat %finish %else %start ! (TYPE)%array(NAMELIST)(BPAIR) Q = P+1; ARR = 1; PACK(PTYPE) %cycle P = Q P = P+3 %until A(P-1)=2 TYPEP = PTYPE; SACC = ACC D2=dope vector(NO,typep&7,acc,0,fromar2(q))>>2 ! DOPE VECTOR INTO SHAREABLE S.T. ACC = SACC; PTYPE = TYPEP; UNPACK RL = ROUNDING LENGTH(PTYPE&255,0); ! FOR ELEMENT AS%c SCALAR %if RL NULL %finish %finish %else %start ! (FORMAT) rflevel=rflevel+1 binsert(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)), 0,rflevel,0) CRFORMAT(rflevel) INC = ACC %finish P = P+1 %repeat %until A(P-1)=2; ! UNTIL NULL ! FINISH OFF %if A(P)=1 %start; ! WHILE %or CLAUSES P = P+1 rfalt(myrflevel)=rfalt(myrflevel)+1 CRFORMAT(myrflevel) %if ACC>INC %then INC = ACC %finish %else P = P+1 ACC = INC; ! SIZE ROUNDED APPROPRIATELY %return %routine SN(%integer Q) !*********************************************************************** !* CHECK THE SUBNAME HAS NOT BEEN USED BEFORE IN THIS FORMAT * !* AND ENTER IT WITH ITS DESCRIPTORS INTO THE LIST. * !* CARE IS NEEDED TO MATCH TAG LAYOUT ON BYTE SWOPPED HOSTS * !*********************************************************************** %record (TAGF) CELL FNAME = FROM AR2(Q) %if aslist(tags(fname))_ptype=x'4051' %then warn(11,0) CELL_PTYPE <- PTYPE; CELL_UIOJ <- FNAME<<4!J CELL_ACC <- ACC CELL_SNDISP <- D2&X'FFFF'; ! IN CASE OF BUM FORMATS CELL_SLINK <- D1&X'FFFF'; ! IN CASE OF BUM FORMATS CELL_KFORM = FORM BINSERT(rfhead(myrflevel,rfalt(myrflevel)),rfbot(myrflevel,rfalt(myrflevel)), CELL_S1,CELL_S2,CELL_S3) ! %if PTYPE=X'433' %and ACC=MAXRECSIZE %then %c PUSH(ASLIST(FORM)_S3,OPBOT,0,0) ! NOTE FORWARD REFERENCE %end %routine ROUND %end %end; ! OF ROUTINE CRFORMAT %routine out fmt cell(%record(listf)%name lcell) !*********************************************************************** !* print out a single cell of a format list * !*********************************************************************** %integer pt,name,dvdisp,nd,ii %record(listf)%name fcell pt=lcell_s1>>16 name=lcell_S1>>4&X'FFF' %if pt&x'cff'=x'35' %start outstring("char "); outname(name) %else OUT XTYPE(PT&x'cff',lcell_kform) outname(name) %finish %if PT&x'300'#0 %start nd=lcell_s1&15 dvdisp=lcell_sndisp %for ii=nd,-1,1 %cycle p=ctable(dvdisp+3*ii+2) outstring(" [") csexp(x'51') %if ctable(dvdisp+3*ii)=x'80000000'%start outsym('-'); p=ctable(dvdisp+3*ii+1) outsym('('); csexp(x'51'); outstring(")+1") %finish %else %if ctable(dvdisp+3*ii)<1 %start outsym('+'); outint(1-ctable(dvdisp+3*ii)) %finish %else %if ctable(dvdisp+3*ii)>1 %start outsym('-'); outint(ctable(dvdisp+3*ii)-1) %finish outsym(']') %repeat %finish %if pt&x'cff'=x'35' %start outsym('['); outint(lcell_acc); outsym(']') %finish outsep outsym(NL) %end %routine process format(%integer level,alt,structor union,intid, %integername strid,ophead,opbot) !*********************************************************************** !* process one level of the recordformay data structure and call & !* itself recursively to handle lower levels. Note C unions cal & !* can have only one element in each alternative so imp multi- & !* element alternatives have to be coalesced into structures & !* this is the main problem & !*********************************************************************** %record (listf)lcell %integer i,j,k,newid,lstrid %if structorunion='s' %start { struct only 1 alt } %while rfhead(level,alt)#0 %cycle pop(rfhead(level,alt),lcell_s1,lcell_s2,lcell_s3) %if lcell_s1#0 %start out fmt cell(lcell) lcell_slink=intid binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3) %else { union within struct } newid=intid<<4!(lcell_s2{-1}{ union update }) outstring("union {"); outsym(NL) process format(lcell_s2,0,'u',newid,strid,ophead,opbot) outstring("} u"); outint(lcell_s2-1) outsym(';'); outsym(NL) %finish %repeat %else { union with at least 2 alternatives } %for i=alt,1,rfalt(level) %cycle %if rfhead(level,i)=rfbot(level,i) %start { only 1 alt } pop(rfhead(level,i),lcell_s1,lcell_s2,lcell_s3) %if lcell_s1#0 %start out fmt cell(lcell) lcell_slink=intid binsert(ophead,opbot,lcell_s1,lcell_s2,lcell_s3) %else { union within union } newid=intid<<4!(lcell_s2{-1}{ union update }) outstring("union {"); outsym(NL) process format(lcell_s2,0,'u',newid,strid,ophead,opbot) outstring("} u"); outint(lcell_s2-1) outsym(';'); outsym(NL) %finish %else { force in a struct } lstrid=strid; strid=strid+1 newid=intid<<4!8!lstrid outstring("struct {"); outsym(NL) process format(level,i,'s',newid,strid,ophead,opbot) outstring("} s"); outint(lstrid) outsym(';'); outsym(NL) %finish %repeat %finish %end %integer %fn DISPLACEMENT(%integer LINK) !*********************************************************************** !* SEARCH A FORMAT LIST FOR A SUBNAME * !* A(P) HAS ENAME--LINK IS HEAD OF RFORMAT LIST. RESULT IS DISP * !* FROM START OF RECORD * !*********************************************************************** %record (LISTF) %name FCELL,PCELL,LCELL %record (TAGF) TOPND %integer RR,II,ENAME,CELL ENAME = A(P)<<8+A(P+1); CELL = 0 %if LINK#0 %then %start; ! CHK RECORDSPEC NOT OMITTED FCELL == ASLIST(LINK); ! ONTO FIRST CELL CELL = LINK; II = -1; ACC = -1 %while LINK>0 %cycle LCELL == ASLIST(LINK) %if LCELL_UIOJ<<16>>20=ENAME %start; ! RIGHT SUBNAME LOCATED TCELL = LINK SNDISP = LCELL_SNDISP K = LCELL_SLINK J = LCELL_UIOJ&15; PTYPE = LCELL_PTYPE ACC = LCELL_ACC&X'FFFF' SNDISP = LCELL_SNDISP KFORM = LCELL_KFORM %if LINK#CELL %start; ! NOT TOP CELL OF FORMAT PCELL_LINK = LCELL_LINK LCELL_LINK = FCELL_LINK FCELL_LINK = LINK %finish; ! ARRANGING LIST WITH THIS SUBNAME ! NEXT TO THE TOP %result = K %finish PCELL == LCELL LINK = LCELL_LINK %repeat %finish FAULT(65,0,ENAME) %if CELL>0 %then %start TOPND_PTYPE = x'51' TOPND_UIOJ <- ENAME<<4 PUSH(ASLIST(CELL)_LINK,TOPND_S1,0,0) %finish PTYPE = X'51'; TCELL = 0; unpack %result = -1 %end %integer %fn COPY RECORD TAG(%integer %name SUBS) !*********************************************************************** !* PRODUCE PTYPE ETC FOR A COMPOUND NAME BY CHAINING DOWN ONE * !* ONE OR MORE RECORD FORMAT LISTS. ON EXIT RESULT =0 IF NO * !* SUBNAME FOUND OR SUBNAME IS OF TYPE RECORD WITH NO FURTHER * !* SUBNAME ATTACHED. RESULT#0 IF BONE-FIDE SUBNAME LOCATED * !* ON ENTRY KFORM HAS POINTER TO THE (FIRST ) FORMAT LIST AND * !* P POINTS TO THE A.R. ENTRY FOR (FIRST) ENAME * !*********************************************************************** %integer Q,FNAME SUBS = 0 %until TYPE#3 %cycle FNAME = KFORM P = P+2; SKIP APP %result = 0 %if A(P)=2 %or FNAME<=0; ! NO (FURTHER) ENAME SUBS = SUBS+1 P = P+1; Q = DISPLACEMENT(FNAME) UNPACK %repeat %result = Q+1; ! GIVES 0 IF SUBNAME NOT KNOWN %end %integerfn chk rec align(%integer p1) !*********************************************************************** !* Tiddles down chain looking for an integer or larger * !* returns 0 unless at least word aligned * !*********************************************************************** %integer cell,i %integerfnspec scan(%integer cell) p=p1; reduce tag(no); ! leaves kform set for records cell=kform ! printstring("chk align ".printname(a(p1)<<8!a(p1+1))) ! write(kform,5); newline ! printlist(cell) %result=scan(cell) %integerfn scan(%integer cell) %integer j %while cell #0 %cycle i=aslist(cell)_ptype>>4&7 %if i>=5 %then %result=i %if aslist(cell)_ptype=x'33' %then %start i=scan(aslist(cell)_kform) %if i>=5 %then %result=i %finish cell=aslist(cell)_link %repeat %result=0 %end %end { chk rec align } %routine CRNAME(%integer Z,MODE,BS,DP, %integer %name NAMEP) !*********************************************************************** !* DEAL WITH RECORD ELEMENT NAMES.Z AS FOR CNAME.CLINK=TAGS(RN) * !* MODE=ACCESS FOR RECORD(NOT THE ELEMENT!) * !* ON EXIT BASE,AREA & DISP POINT TO REQUIRED ELEMENT * !* RECURSIVE CALL IS NEEDED TO DEAL WITH RECORDS IN RECORDS * !* DEPTH SHEWS RECURSIVE LEVELS- NEEDED TO AVOID MIS SETTING * !* REGISTER IN USE IF RECORDNAME IN RECORD HAS THE SAME NAME AS * !* A GENUINE RECORD NAME. * !*********************************************************************** %integer DEPTH,FNAME,EMNAME %routine %spec CENAME(%integer MODE,FNAME,BS,DP,XD) %record (RD) HDOPND HDOPND = 0 DEPTH = 0 EMNAME = NAMEP&X'FFFF'; ! ORIGINAL RECORD NAME FOR ERROR%c MESSES FNAME = KFORM; ! POINTER TO FORMAT %if ARR=0 %or (6<=z<=7 %and A(P+2)=2) %start; ! SIMPLE RECORD %if A(P+2)=2 %then P = P+3 %else NO APP CENAME(MODE,FNAME,BS,DP,0) %finish %else %start HDOPND_PTYPE = AHEADPT HDOPND_FLAG = LOCALIR HDOPND_D = BS<<16!DP CANAME(Z,ARR,HDOPND) NAMEP = -1 CENAME(ACCESS,FNAME,BASE,DISP,0) %finish; %return ! %routine CENAME(%integer MODE,FNAME,BS,DP,XD) !*********************************************************************** !* FINDS OUT ABOUT SUBNAME AND ACTS ACCORDINGLY.MOSTLY ACTION * !* CONSISTS OF UPPING XD BY OFFSET OF THE SUBNAME BUT IS VERY * !* HAIRY FOR RECORDS IN RECORDS ETC * !* MODE IS ACCESS FOR THE RECORD * !*********************************************************************** %routine %spec FETCH RAD %integer Q,QQ,D,C,TR,ENAME,RPTYPE,EPTYPE %record (RD) RADOPND,OPND1 %record (LISTF) %name LCELL DEPTH = DEPTH+1 RPTYPE=PTYPE %if A(P)=2 %then %start; ! ENAME MISSING ACCESS = MODE; XDISP = XD BASE = BS; DISP = DP; ! FOR POINTER %if Z<14 %then %start; ! NOT A RECORD OPERATION %unless 3<=Z<=4 %or Z=6 %or Z=7 %start; ! ADDR(RECORD) FAULT(64,0,EMNAME); BASE = RBASE DISP = 0; ACCESS = 0; PTYPE = X'51' UNPACK %finish %finish %return %finish P = P+1; ! FIND OUT ABOUT SUBNAME Q = DISPLACEMENT(FNAME); ! TCELL POINTS TO CELL HOLDING EPTYPE=PTYPE; ! Save ptype of ename UNPACK; ! INFO ABOUT THE SUBNAME ! %if Q=-1=ACC %or PTYPE=X'51' %start; ! WRONG SUBNAME(HAS BEEN%c ! FAULTED) ! P = P+2; SKIP APP; P = P-3 ! ACCESS = 0; BASE = RBASE; DISP = 0 ! %return ! %finish ENAME = A(P)<<8!A(P+1) NAMEP = ENAME<<16!NAMEP; ! NAMEP=-1 UNALTERED ! %if rptype&x'f00'=x'400' %then outstring("->") %else outstring(".") outinternames(q) outname(ename) ->AE %if ARR=1; ! ARRAYS INCLUDING RECORDARRAYS %if A(P+2)=2 %then P = P+3 %else NO APP %if TYPE<=2 %or TYPE=5 %or (TYPE=3 %and A(P)=2 %and %c (3<=Z<=4 %or 6<=z<=7)) %start ACCESS = MODE+4+4*NAM; BASE = BS; DISP = DP; XDISP = XD+Q %return %finish ! ! NOW CODING BECOMES HAIRY:- STILL LEFT ARE ! A) RECORDS IN RECORDS Q POINTS TO SECONDARY RECORD ! B) RECORDNAMES IN RECORDS Q HAS OFF-SET OF A POINTER ! C) RECORDARRAYNAMES IN RECORDS Q HAS OFF-SET A HEADER IN RECORD ! D) RECORDARRAYS IN RECORDS NOT YET ALLOWED ! Q WOULD HAVE OFF-SET OF A RECORD RELATIVE HEADER IN THE GLA ! XD = XD+Q NAMEP = NAMEP!X'FFFF0000' %if NAM=1 %then %start MODE = MODE+4; ! SO ADDRESS OF POINTER FETCHED FETCH RAD; ! NEW METHOD IS AS FOR REC FNS EXPOPND = RADOPND; ! EXPOPND IS ADDRESS TO WHICH POINTER%c POINTED MODE = 3 DP = 0; XD = 0; BS = 0 NAMEP = -1 %finish CENAME(MODE,KFORM,BS,DP,XD) %return AE: ! ARRAYS AND ARRAYNAMES AS ELEMEN LCELL == ASLIST(TCELL) ACC = LCELL_ACC&X'FFFF'; SNDISP = LCELL_SNDISP&X'FFFF' KFORM = LCELL_KFORM; K = LCELL_SLINK&x'ffff' C = ACC; D = SNDISP; Q = K; QQ = KFORM %if (Z=6 %or Z>=11) %and A(P+2)=2 %start; ! 'GET ARRAYHEAD'%c CALL P = P+3 %if NAM=1 %then %start ACCESS = MODE+8; BASE = BS DISP = DP; XDISP = XD+Q PTYPE = AHEADPT NAMEOP(6,8,NAMEP); ! PTR TO HEAD %return %finish ! ! PASSING AN ARRAY IN A RECORD BY NAME MUST CONSTRUCT PROPER ARRAYHEAD ! FROM THE RECORD RELATIVE ONE AT Q(GLA) ! FETCH RAD NAMEP = -1 OPND1 = 0 OPND1_PTYPE = AHEADPT OPND1_FLAG = LOCALIR OPND1_D = Q NAMEOPND_D = CREATE AH(1,RADOPND,OPND1) NAMEOPND_PTYPE = AHEADPT; NAMEOPND_FLAG = REFTRIP NAMEOPND_XTRA = 0 %finish %else %start; ! ARRAY ELEMENTS IN RECORDS %if NAM=1 %then %start; ! ARRAYNAMES-FULLHEAD IN RECORD XD = XD+Q ACCESS = MODE+8 BASE = BS; DISP = DP; XDISP = XD NAMEOP(6,AHEADSIZE,NAMEP) OPND1 = NAMEOPND OPND1_PTYPE = AHEADPT PTYPE = LCELL_PTYPE; UNPACK CANAME(Z,3,OPND1); ! ARRAY MODE SETS DISP,AREA&BASE XD = 0 %finish %else %start; ! ARRAY RELATIVE HEAD IN GLA FETCH RAD; ! 32 BIT ADDR TO ETOS OPND1 = 0; OPND1_PTYPE = AHEADPT OPND1_FLAG = LOCALIR OPND1_D = Q CANAME(Z,3,OPND1); ! RECORD REL ARRAY ACCESS ! CAN RETURN ACCESS=1 OR 3 ONLY TR =0 ! TR = BRECTRIP(AAINC,X'51',0,RADOPND,EXPOPND) EXPOPND_FLAG = REFTRIP EXPOPND_D = TR ! TRIPLES(TR)_X1 = PTYPE&255; ! FRIG FOR PERQ&ACCENT 3%c WORD BYTE PTRS! XD = 0 %finish NAMEP = -1 XDISP = XD %if TYPE=3 %then%start CENAME(ACCESS,QQ,BASE,DISP,XD) c=acc; ! to return element size %else %if Z>=11 %then FAULT(17,0,ENAME) %finish ! AN ELEMENT IS NOT AN ARRAY FOR P-P %finish ACC = C; ! NEEDED FOR STRING ARRAYS %return %routine FETCH RAD !*********************************************************************** !* SET ACC TO 32 BIT ADDRESS OF RECORD. * !*********************************************************************** ACCESS = MODE+4 BASE = BS DISP = DP; XDISP = XD ptype=rptype; unpack NAMEOP(4,4,NAMEP) ptype=eptype; unpack RADOPND = NAMEOPND %end %end; ! OF ROUTINE CENAME %end; ! OF ROUTINE CRNAME %routine CSTREXP(%integer MODE) !*********************************************************************** !* PLANT IN-LINE CODE FOR CONCATENATION. A WORK AREA IN THE * !* CURRENT STACK FRAME IS USUALLY REQUIRED. * !* ON ENTRY:- * !* MODE=0 NORMAL. WK AREA NOT USED FOR ONE OPERAND EXPSSNS * !* MODE=1 STRING MUST GO TO WORK AREA * !* 2**5 BIT OF MODE SET IF FULL VIRTUAL ADDRESS REQUIRED * !* 2**4 BIT OF MODE IS SET IF WK-AREA NOT TO BE FREED ON EXIT * !* ON EXIT:- * !* VALUE#0 %if RESULT IN A WORK AREA(CCOND MUST KNOW) * !*********************************************************************** %integer PP,WKAREA,DOTS,ERR,KEEPWA,FNAM,I,ENDFLAG,Firsttrip,trip %record (RD) OPND1,OPND2,OPND3 %integer %fn %spec STROP(%record (RD) %name OPND) KEEPWA = MODE&16; MODE = MODE&15 OPND1 = 0 OPND1_PTYPE = X'35' OPND1_FLAG = LOCALIR OPND1_XTRA = 268; ! THE WORK AREA SIZE NEEDED FOR PP = P; STRINGL = 0; FNAM = 0; WKAREA = 0 P = P+3; ! LENGTH OF CONSTANT PART ERR = 72; ->ERROR %unless A(P)=4 P = P+1 DOTS = 0; ! NO OPERATORS YET ENDFLAG = 0 STRINGL = 0 ERR = STROP(OPND2); ! GET FIRST OPERAND %if STRRESINWA=NO %and PTYPE&X'1000'#0 %then MODE = 1 ! IF FN RESULT NOT IN A WORK AREA ! COPY IN FROM TOP OF STACK ! SOMETIMES NOT NECESSARY BUT FN=FN%c COMPARISONS ! WILL GO WRONG WITHOUT THIS ->ERROR %unless ERR=0 NEXT: %if A(P)=2 %then ENDFLAG = 1 %else %start %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR P = P+2 ! ! LEFT TO RIGHT EVALUATION IS DEFINED BUT IF FIRST OPERAND IS ACONST ! WE CAN EVALUATE THE SECOND. THIS ENABLES US TO FOLD "TOSTRING(NL)" ETC ! %if DOTS=0 %and OPND2_FLAG=LCONST %then %start ERR = STROP(OPND3) ->ERROR %unless ERR=0 %finish %else OPND3_FLAG = 255 %finish %if ENDFLAG=0 %and OPND2_FLAG=LCONST=OPND3_FLAG %and mode=1 %start ! ! CAN FOLD OUT A CONCATENATION HERE ! I = CONCAT CTOP(I,ERR,0,OPND2,OPND3) %if I=0 %then ->NEXT; ! FOLDED OUR %finish %if DOTS=0 %start %if ENDFLAG#0 %start; ! NO RUN-TIME OPERATIONS outopnd(opnd2,0) OPND1 = OPND2; ->TIDY %finish Firsttrip = BRECTRIP(PRECC,X'35',0,OPND1,OPND2) OPND1_FLAG = REFTRIP OPND1_D = Firsttrip; ! CHANGE TO TRIPLES REFERENCE DOTS = DOTS + 1 %finish %if ENDFLAG=0 %then %start %if OPND3_FLAG=255 %start; ! 3 NEED EVALUATION ERR = STROP(OPND3) ->ERROR %unless ERR=0 %finish OPND1_D = BRECTRIP(CONCAT,X'35',0,OPND1,OPND3) dots = dots +1; ->NEXT %finish ! printtrips(triples) outstring("imp_concat(") %for i=2,1,DOTS trip=Firsttrip %while trip #0 %cycle outopnd(Triples(trip)_opnd2,0) %if trip=Firsttrip %then outstring(",") %else %start outstring(")") outsym(',') %unless Triples(trip)_puse=0 %finish trip=Triples(trip)_puse %repeat TIDY: ! FINISH OFF EXPOPND = OPND1; ! LEAVE REULT IN EXPOPND VALUE = WKAREA P = P+1; ! PAST REST OF EXPRN RETURN WSP(WKAREA,268) %if KEEPWA=0 %and WKAREA>0 STRINGL = 0 %return ERROR: FAULT(ERR,0,FNAM) EXPOPND = OPND1 BASE = RBASE; DISP = 0 VALUE = 0; ACCESS = 0 P = PP; SKIP EXP %return %integer %fn STROP(%record (RD) %name OPND) !*********************************************************************** !* DEALS WITH OPERAND FOR CONCATENATION. RETURN RESULT=0 FOR * !* VALID OPERAND OTHERWISE AN ERROR NUMBER. * !*********************************************************************** %integer CTYPE,alt,I alt = A(P); ! ALTERNATIVE OF OPERAND OPND = 0 %result = 75 %if alt >2 %if alt #1 %then %start CTYPE = A(P+1); ! GET CONST TYPE & LOSE AMCK FLAGS %if CTYPE=X'35' %then %start PTYPE = CTYPE STRINGL = A(P+2) OPND_PTYPE = CTYPE OPND_FLAG = LCONST OPND_D = P+2 OPND_XTRA = STRINGL P = P+STRINGL+3 %finish %else %result = 73 %finish %else %start P = P+1; ! MUST CHECK FIRST COPYTAG(FROMAR2(P),NO) %if PTYPE=x'1006' %then TYPE = ACC&7; ! special for "string" %if TYPE=3 %then REDUCE TAG(NO) %if 5#TYPE#7 %then FNAM = FROMAR2(P) %and %result = 71 %if ptype=x'4035' %and A(P+2)=2=A(P+3) %and mode#0 %start opnd_flag=lconst; opnd_ptype=x'35' opnd_d=midcell; opnd_xtra=kform stringl=opnd_xtra p=p+4 %result=0 %finish %if PTYPE=X'35' %and A(P+2)=2=A(P+3) %start OPND_FLAG = DNAME OPND_XTRA = 0 OPND_PTYPE <- PTYPE OPND_D = FROMAR2(P) P = P+4 %finish %else %start OPND_FLAG = ARNAME OPND_D = P p=p+2; skip app %while a(p)=1 %cycle p=p+3; skip app; %repeat p=p+1 %finish STRINGL = 0 %finish %result = 0 %end; ! OF INTEGERFN STROP %end; ! OF ROUTINE CSTREXP %routine CRES(%integer LAB) !********************************************************************** !* COMPILES A RESOLUTION E.G A->B.(C).D.(E).F AND JUMPS TO LAB * !* ON FAILURE. (LAB=0 FOR UNCONDITIONAL RESOLUTION TO PERM ON * !* FAILURE ). * !* THE METHOD IS TO CALL A SUBROUTINE PASSING 5 PARAMS:- * !* P1(32BITS) POINTS TO LHS(A) * !* P2(16BITS) ORIGINAL LENGTH OF A * !* P3(32BITS) FULL POINTER TO BYTES USED UP INITIALLY 0 * !* P4(48BITS) STRING TO CONTAIN FRAGMENT * !* (PASSED AS LMAX FOLLOWED BY 32BIT ADDRESS) * !* P5(32BITS) THE EXPRESSION PASSED AS 32 BIT ADDRESS * !* SUBROUTINE TRIES TO PERFORM THE RESOLUTION AND SETS THE * !* RESULT TO TRUE IF IT SUCCEEDS. * !* * !* ON ENTRY LHS IS IN THE ESTACK(32BITS). * !* P POINTS TO P(+') OF RHS DEFINED AS (+')(OPERAND)(RESTOFEXP) * !* * !$ THE ROUTINE IS COMPACT BUT DIFFICULT TO FOLLOW (OR ALTER) * !* THE TIME IN PERM IS LARGE SO IT IS NOT WORTHWHILE TO PERSUE * !* CODE EFFICIENCY TOO INDUSTRIOUSLY . * !********************************************************************** %integer P1,P2,SEXPRN,W,LAST,ERR,FNAM,JJ %record (RD) OPND1,OPND2 LAST = 0; FNAM = 0; ! =1 WHEN END OF EXPRNSN FOUND SEXPRN = 0; ! RESOLUTION(BRKTD) EXPRESSNS P1 = P ERR = 43 %if NAMEOPND_PTYPE&X'C700'=X'4000' %then %c FNAM = NAMEOPND_D %and ->ERROR ! CANT RESOLVE A CONST STRING ERR = 74; ! NORMAL CRES FAULT GET WSP(W,4); ! TO HOLD P1,P2 AND VALUE OF P3 OPND1_PTYPE = X'61' OPND1_FLAG = LOCALIR OPND1_D = RBASE<<16!W P = P+3 ->RES %if A(P)=4; ! LHS MUST BE A STRING ! BUT THIS CHECKED BEFORE CALL ERR = 72 ERROR:FAULT(ERR,0,FNAM) P = P1; SKIP EXP; %return RES: P = P+1; ! TO P(OPERAND) %if A(P)=3 %then %start; ! B OMITTED OPND2_PTYPE = X'51' OPND2_FLAG = SCONST OPND2_D = 0; ! ZERO CONST FOR NO DEST outstring("NULL,") %finish %else %start ->ERROR %unless A(P)=1; ! P(OPERAND)=NAME P = P+1; P2 = P CNAME(2) outsym(',') OPND2 = NAMEOPND %if TYPE#5 %then ERR = 71 %and FNAM = FROMAR2(P2) %and ->ERROR %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR P = P+2 %finish ->ERROR %unless A(P)=3; ! P(OPERAND)='('(EXPR)')' SEXPRN = SEXPRN+1; P = P+1 CSTREXP(0); ! FULL 32 BIT ADDRESS outsym(',') OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST OPND2_D = LAB %if A(P)=2 %then outstring("NULL") %and ->END %if A(P+1)#CONCOP %then ERR = 72 %and ->ERROR P2 = P+1; P = P2+1 %if A(P)=3 %then %start P = P2 outstring("_imptempstring)") %if lab=0 %then outsym(';') %else outsym('+') outstring("imp_resolve(_imptempstring,") ->RES %finish ->ERROR %unless A(P)=1 P = P+3 %and SKIP APP %until A(P)=2 %if A(P+1)=1 %then %start P = P2 outstring("_imptempstring)") %if lab=0 %then outsym(';') %else outsym('+') outstring("imp_resolve(_imptempstring,") ->RES %finish P1 = P+1 P = P2+2 CNAME(2) P = P1 END: P = P+1 %end %routine SAVE STACK PTR !*********************************************************************** !* SAVE THE CURRENT STACK TOP AND POSSIBLY A DESCRIPTOR TO IT * !* NEEDED ON AUX STACK IMPLEMENTATIONS AND ALSO IN BEGIN-END BLOCKS * !* SO ARRAYS CAN BE UNDECLARED ON BLOCK EXIT. ONLY ACTS ON THE FIRST* !* CALL IN ANY BLOCK OR ROUITNE * !*********************************************************************** %integer JJJ %if CURRINF_AUXSBASE=0 %start JJJ = UTEMPTRIP(SSPTR,MINAPT,0,N); ! SAVE THE STACK POINTER CURRINF_AUXSBASE = N %if TARGET=EMAS %and PARM_STACK=0 %then N = N+16 %else N = N+4 %finish %end %routine CEND(%integer KKK) !*********************************************************************** !* DEAL WITH ALL OCCURENCES OF '%END' * !* KKK=PTYPE(>=X'1000') FOR ROUTINES,FNS AND MAPS * !* KKK=0 FOR ENDS OF '%BEGIN' BLOCKS * !* KKK=1 FOR '%ENDOFPROGRAM' * !* %endofprogram IS REALLY TWO ENDS. THE FIRST IS THE USERS * !* AND THE SECOND IS PERMS. KKK=2 FOR A RECURSIVE CALL OF CEND * !* ON END OF PROGRAM TO DEAL WITH THE %end CORRESPONDING TO * !* THE %begin COMPILED IN THE INITIALISATION SEQUENCE * !*********************************************************************** %integer KP,JJ,BIT %record (TAGF) %name RCELL,TCELL,PCELL %routine %spec DTABLE(%integer LEVEL) SET LINE %unless KKK=2 BIT = 1<X'1000' %and PARM_COMPILER=0 %and %c LAST INST=0 %then JJ = UCONSTTRIP(RTBAD,X'51',0,0) ! RUN FAULT 11 %if KKK=0 %then %start; ! BEGIN BLOCK EXIT %if PARM_TRACE=1 %then %start; ! RESTORE DIAGS POINTERS JJ = UCONSTTRIP(RDPTR,X'51',0,LEVEL-1) %finish JJ = CURRINF_AUXSBASE %if JJ#0 %then %start; ! ARRAYS TO BE UNDECLARED JJ = UCONSTTRIP(RSPTR,X'51',0,JJ) %finish %finish FORCE TRIPS; ! BEFOR LABEL LIST CLEARED IN OPT MODE NMAX = N %if N>NMAX; ! WORK SPACE POINTER ! ! CLEAR OUT THE LABEL LIST FAULTING LABELS WITH JUMPS OUTSTANDING ! AS NOT SET AND COMMENTING ON LABELS NOT USED ! %while CURRINF_LABEL#0 %cycle POP(CURRINF_LABEL,I,J,KP) %if J&X'FFFF'#0 %then %start J = J&X'FFFF' %if 0=0 %start RCELL == ASLIST(TAGS(JJ)) %if RCELL_PTYPE&X'1000'#0 %start; ! NAME COULD BE REDECLARED%c AS LOCAL ! IF THIS HAPPENS SKIP GLEANING K = RCELL_SLINK %while K>0 %cycle; ! DOWN PARAM LIST TCELL == ASLIST(K) %if TCELL_PTYPE&X'F00'=X'500' %and TCELL_UIOJ&15=0 %start ! TCELL IS ARRAY OF UNKNOWN DIMENSION PCELL == ASLIST(TAGS((TCELL_UIOJ>>4)&4095)) ! ONTO LOCAL TAGS TCELL_UIOJ = TCELL_UIOJ!PCELL_UIOJ&15 ! COPY BACK DIMENSIO %finish K = TCELL_LINK %repeat %finish %finish ! ! NOW PLANT THE BLOCK EXIT SEQUENCE ! %if KKK&X'1000'#0 %then JJ = UCONSTTRIP(RTXIT,X'51',0,KKK) JJ = UCONSTTRIP(XSTOP,X'51',0,KKK) %if KKK=1; ! %stop AT%c %endofprogram CLEAR LIST(TWSPHEAD); ! CAN NOT CARRY FORWARD %cycle JJ = 0,1,4 CLEAR LIST(CURRINF_AVL WSP(JJ)); ! RELEASE TEMPORARY LOCATIONS %repeat %if TARGET=PERQ %or TARGET=ACCENT %then FORCE TRIPS ! PERQ NEED THIS BEFORE DTABLE AS ! DTABLE OFFSET GOES IN RTDICT ! PNX MUST HAVE DATBLE FIRST OR ! FILLING OF DTABLE REFS FAILS DTABLE(LEVEL); ! OUTPUT DIAGNOSTIC TABLES FORCE TRIPS ! ALL TRIPS MUST BE DEALT WITH ! BEFORE CURRENT LEVELS ARE CHANGED %while CURRINF_UNATT FORMATS#0 %cycle POP(CURRINF_UNATT FORMATS,I,J,JJ) CLEAR LIST(I) CLEAR LIST(J) CLEAR LIST(JJ) %repeat ! ! NOW CLAIM THE STACK FRAME BY FILING THE ASF IN THE BLOCK ENTRY CODING ! %if KKK=2 %then %return ! ! RETURN TO PREVIOUS LEVEL PROVIDED THERE IS A VALID ONE ! ! %unless LEVEL>2 %or (LEVEL=2 %and PARM_CPRMODE=2) %then %start %if KKK=1 %and LEVEL=2 %then KKK = 2 %else FAULT(109,0,0) ! SHOULD BE CHKD IN PASS1 %finish LEVEL = LEVEL-1 CURRINF == LEVELINF(LEVEL) %if KKK&X'1000'#0 %then %start RLEVEL = CURRINF_RBASE RBASE = RLEVEL %finish ! ! RESTORE INFORMATION ABOUT THE (NEW) CURRENT LEVEL ! NMAX = CURRINF_SNMAX %if KKK&X'1000'#0 N = CURRINF_SN %if KKK=2 %then CEND(KKK); ! ROUND AGAIN FOR 'ENDOFPROGRAM' ! ! COMPLETE THE JUMP AROUND ALL NON-EXTERNAL ROUTINES EXCEPT WHEN ! %trustedprogram IS IN OPERATION. ! %if KKK&X'1000'#0 %and PARM_COMPILER=0 %and (RLEVEL>0 %or %c PARM_CPRMODE#2) %then %start JJ = NEXTP+6 %unless A(NEXTP+5)=11 %and A(JJ+FROMAR2(JJ))=2 %start JJ = ENTER LAB(CURRINF_JROUND,1) CURRINF_JROUND = 0 %finish %finish %return ! ! LAYOUT OF DIAGNOSIC TABLES ! ****** ** ********* ****** ! ! THE BOUND FIELD OF PLT DESCRIPTOR STORED AT (LNB+3 & LNB+4) IF ! USED TO CONTAIN A DISPLACEMENT RELATIVE TO THE START OF SST OF THE ! DIAGNOSTIC TABLES FOR THE BLOCK OR ROUTINE BEING EXECUTED. ! A ZERO BOUND MEANS NO DIAGNOSTIC REQUESTED.(NB THIS MAY MEAN A DUMMY ! FIRST WORD IN THE SST). ! THE ABSOLUTE ADDRESS OF THE SST FOR THE CURRENT CODE SEGMENT WILL ! ALWAYS BE FOUND IN THE STANDARD 10 WORDS OF THE GLA/PLT ! ! FORM OF THE TABLES:- ! ! WORD 0 = LINE OF RT IN SOURCE PROG <<16 ! LINE NO POSN(FROM LNB) ! WORD 1 = (12 LANG DEPENDENT BITS)<<18 ! ENVIRONMENT ! ( TOP 2 BITS OF LANG DEPENDENT HAS LITL FROM PTYPE) ! ( BOTTOM 4 BITS HAVE TEXTUAL LEVEL) ! WORD 2 = DISPLAY POSN (FROM LNB)<<16 ! RT TYPE INFO ! WORD 3 = ZERO FOR BLKS OR STRING(<=11BYTES) BEING THE ! RT NAME. THIS WILL TAKE WORDS 4 AND 5 IF NEEDED ! WORD 6 = LANGUAGE DEPENDENT INFO . IMP ON CONDITIONS ETC ! ! THE REST IS MADE UP OF VARIABLE ENTRIES AND THE SECTION IS TERMINATED BY ! A WORD OF X'FFFFFFFF' ! ! EACH VARIABLE ENTRY CONSISTS OF THE VARIABLE WORD FOLLOWED BY ! THE VARIABLE NAME AS A STRING. THE WORD CONSISTS OF ! BITS 2**31 TO 2**20 TYPE INFORMATION (MAY BE LANGUAGE DEPENDENT ! BIT 2**19 =0 UNDER LNB =1 IN GLA ! BITS 2**18 TO 2**0 DISPLACEMENT FROM LNB(GLA) IN BYTES ! ! ! THE ENVIRONMENT IS A POINTER (RELATIVE TO SST) OF THE NEXT OUTERMOST ! BLOCK OR A POINTER TO GLOBAL OWNS, EXTERNAL OR COMMON AREAS ! A ZERO MEANS NO ENCLOSING BLOCK. WORD1=WORD3=0 IS AN ! IMP MAIN PROGRAM AND WILL TERMINATE THE DIAGNOSTICS. ! %routine DTABLE(%integer LEVEL) !*********************************************************************** !* THIS ROUTINE LOOKS AT THE DECLARATIONS FOR THE CURRENT LEVEL & * !* SETS UP THE SEGMENT OF SHARABLE SYMBOL TABLES TO DESCRIBE THEM.* !* FOR MAIN PROGRAMS OR EXTERNAL ROUTINES THE 'GLOBAL' VARIABLES * !* (IF ANY) ARE ALSO INCLUDED. * !*********************************************************************** %integerfnspec swopof(%integer ptype,value) %string (11) RT NAME %string (11) LOCAL NAME %if 1<>14<<30!LEVEL<<18; ! GET LITL FROM PTYPE %if PARM_TRACE=1 %then PDATA(DAREA,4,0,ADDR(DD(0))); ! TO WORD BOUNDARY FILL DTABREFS(CURRINF_RAL) PUSH(LEVELINF(LEVEL-1)_RAL,DAREA,CAS(DAREA)+4,LANGD) %if PARM_TRACE#0 DHEAD == RECORD(ADDR(DD(0))) DHEAD_RTLINE <-swopof(X'41', CURRINF_L) DHEAD_LINEOFF <-Swop of(x'41', CURRINF_DIAGINF) DHEAD_OFLAGS <-Swop of(x'41', LANGD>>16) DHEAD_ENV = 0 %if TARGET=IBM %or TARGET=IBMXA %or TARGET=AMDAHL %then %c DHEAD_DISPLAY = CURRINF_RBASE %else %c DHEAD_DISPLAY <-Swop of(x'41', CURRINF_DISPLAY) DHEAD_RTFLAGS <-Swop of(x'41', CURRINF_FLAG&X'3FFF') ML = CURRINF_M; ! ROUTINE NAME(=0 FOR %begin) %if ML#0 %then ML = WORD(ML-1); ! IF NOT BLOCK GET DIRPTR LNUM = WORKA_LETT(ML); ! LENGTH OF THE NAME DPTR = 4; DEND = 0 %if LNUM=0 %then DHEAD_IDHEAD = 0 %else %start Q = ADDR(WORKA_LETT(ML)) RT NAME <- STRING(Q); ! FOR RTS MOVE IN 1ST 32 CHARS LNUM = LENGTH(RT NAME) DHEAD_RTNAME = RTNAME; ! AND UPDATE POINTER PAST ! %if HOST#TARGET %and PARM_TRACE#0 %then %c ! CHANGE SEX(ADDR(DD(0)),12,LNUM+1) DPTR = DPTR+LNUM>>2; ! ACTUAL NO OF CHARS %finish DD(DPTR) <-Swop of(X'51',CURRINF_ONWORD);! ON CONDITION WORD DPTR = DPTR+1 JJ = CURRINF_NAMES %while 0<=JJ2 %or PTYPE&X'FF00'#X'4000' %or %c PARM_STACK#0) %and T_UIOJ&X'C000'=0 %then WARN(2,JJ) I = T_UIOJ>>4&15 J = T_UIOJ&15 K = T_SLINK ! ! ALLOW OWNS (LITL=0) AND EXTERNALS (=2) NOT CONSTS(=1) OR EXTRINSIC(=3) ! %if PARM_DIAG#0 %and PTYPE&X'7300'<=X'200' %and %c DPTRCurrinf_display))%c %and PTYPE&X'C00'=0 %and II=0 %and %c (TYPE=3 %or TYPE=5) %start;! VALUE RECS&STRS %if K>2 %finish %if J=15 %and PTYPE&X'3000'#0 %and T_UIOJ&X'C000'#0 %then %c FAULT(28,0,JJ) ! SPEC&USED BUT NO BODY GIVEN %if J=15 %and TYPE=4 %then FAULT(62,0,JJ) %if PTYPE&X'3000'#0 %then %start ! printstring("clearing list for "); printstring(printname(jj)); newline; printlist(k) CLEAR LIST(K) %Finish %if TYPE=4 %then %start ! printstring("clearing list for "); printstring(printname(jj)); newline; printlist(t_kform) CLEAR LIST(t_kform) %Finish %if type=6 %start scell==aslist(lcell_slink) swdata==record(scell_s1) outstring("goto "); outswadname(jj); outstring("_skip;"); outsym(NL) {GT:} ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__ ! rather than allow them to be picked up at point of dispatch ! by which time they are meaningless outswadname(jj); outstring("_despatch:"); outsym(NL) outstring("switch ("); outswadname(jj); outstring("_value) {"); outsym(NL) %for lnum=0,1,swdata_lseen-1 %cycle outstring("case ") p=swdata_slabs(lnum); csexp(x'51') { No symbolic consts} outstring(": goto "); outswadname(jj) outsym('_') p=swdata_slabs(lnum); labexp outsym(';'); outsym(NL) %repeat outstring("default:") %if swdata_default#0 %then %start outstring("goto "); outswadname(jj) outstring("_default;") %else {GT:} ! NOTE: using __LINE__ and __FILE__ from the dispatch table ! is not very helpful. We really want to know where the switch ! was jumped to from, at the source of the original ->sw(i) ! so I now note the originals into name_file and name_line ! at the point of the jump. I think it's worth the overhead ! of the two extra assignments. ! NOTE ALSO: I assume the body of BADSWITCH is ! dumped at a %endofprogram - would be better not to, ! and to supply it in "imptoc.h" instead ! because of problems described elsewhere to ! do with limitations of this traslator ! (though I haven't yet found where it's dumped so I may be wrong) outstring("BADSWITCH("); outswadname(jj); {GT:}! outstring("_value,__LINE__,__FILE__);") outstring("_value,") outswadname(jj); outstring("_line,") outswadname(jj);outstring("_file);") %finish outsym(NL); outsym('}'); outsym(NL) outswadname(jj); outstring("_skip:;"); outsym(NL) free(addr(swdata)) kk=t_slink clear list(kk) %finish LCELL_LINK = ASL; ASL = TAGS(JJ) TAGS(JJ) = S4&X'3FFFF' JJ = S4>>18 %repeat DD(DPTR) = -1; ! 'END OF SEGMENT' MARK (Not swopped!) DPTR = DPTR<<2+4 %if PARM_TRACE=1 %then PDATA(DAREA,4,DPTR,ADDR(DD(0))) ! ADD TO SHARABLE SYM TABS %return %integerfn Swopof(%integer ptype,value) !*********************************************************************** !* Does the byte swopping for cross compilers using rt in P4 * !*********************************************************************** %record(rd)opnd %if host#target %then %start Opnd=0 Opnd_d=value Opnd_ptype=ptype Reformatc(Opnd) value=Opnd_d %finish %result=Value %end %end; ! OF ROUTINE DTABLE %end %routine DECLARE SCALARS(%integer XTRA) !*********************************************************************** !* THIS ROUTINE DECLARES A LIST OF SCALARS FROM INFORMATION * !* IN THE GLOBAL VARIABLES ROUT,NAM,ARR,PREC,TYPE & ACC.IT WORKS * !* OUT ROUNDING FACTORS FOR ITSELF. * !* P POINTS TO THE NAMELIST ON ENTRY AND IS UPDATED. * !*********************************************************************** %integer INC,SCAL NAME,RL PACK(PTYPE) INC = ACC; SNDISP = 0 RL = ROUNDING LENGTH(PTYPE,1) %if NAM#0 %and ARR=0 %then INC = PTRSIZE(PTYPE&127) %and RL=ptrrounding(ptype&127+128) %if NAM>0 %and ARR>0 %then INC = AHEADSIZE %and RL=rounding length(aheadpt,1) %if PTYPE=X'35' %and (ACC<=0 %or ACC>256) %then %c FAULT(70,ACC-1,0) %and ACC = 255 %if type=5 %start outstring("char ") %finish %else outtype(ptype&255,xtra) %until A(P-1)=2 %cycle; ! DOWN THE NAMELIST N = (N+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN SCAL NAME = FROM AR2(P) %if nam#0 %then outstring("*") outname(scalname) P = P+3 STORE TAG(SCAL NAME,LEVEL,RBASE,0,SNDISP,ACC,N,XTRA) N = N+INC %if type=5 %and nam=0 %start outstring(" ["); outint(acc); outstring("] ") %finish %if a(p-1)=1 %then outsym(',') %repeat N = (N+MIN PARAM SIZE-1)&(-MIN PARAM SIZE); ! THIS IS NECESSARY ! %end %integer %fn DOPE VECTOR(%integer TAMPER,TYPEP,ELSIZE,MODE,IDEN) !*********************************************************************** !* Construcst a pseudo dope vector for the handling of arrays * !* which is as much like the compiler one as possible. Since * !* C arrays all start from 0 but Imp ones can start from anywhere * !* provision is needed to take off the lower bound from each index * !* on every access. * !* The dope vector consists of:- * !* word 0 ignored * !* word 1 dimensions<<16 ! element size * !* word 2 ignored * !* and then a triple for each dimension * !* word 0 the lower bound if constant * !* word 1 pointer to the lb expression * !* word 2 pointer to the ub expression * !* * !* If TAMPER =YES then small +ve lower bounds are reset * !* to zero in the interests of access efficiency * !* IDEN is only for error messages * !* Mode not relevant * !*********************************************************************** %integer I,JJ,K,ND,D,M0,HEAD,NOPS,TYPEPP,PIN,etype,value %record (RD) OPND %record (LISTF) %name LCELL %integer %array LBH,LBB,LBp,UBp(0:12) %integer %array DV(0:39); ! ENOUGH FOR 12 DIMENSIONS ND = 0; TYPEPP = 0; PIN = P M0 = 1 %until A(P)=2 %cycle ND = ND+1; P = P+1 LBp(ND)=p; etype=tsexp(value) p= LBp(ND)+3 FAULT(37,0,IDEN) %and ND = 1 %if ND>12 LBH(ND) = 0; LBB(ND) = 0 NOPS=0 TORP(LBH(ND),LBB(ND),NOPS,1) UBp(ND)=p skip exp %if imod(etype)=1 %start expop(LBH(ND),LBB(ND),NOPS,x'251') lbb(ND)=expopnd_d %else lbb(ND)=x'80000000' { Mark as not known } %finish %repeat P = P+1 ! ! now tamper with the lower bounds if permitted ! %if TAMPER=YES %start %cycle D = 1,1,ND %if LBB(d)>0 %and LBB(d)*ND<=6 %then LBB(d)=0 %repeat %finish ! ! SET UP THE DOPEVECTOR ! DV(1) = ND<<16!ELSIZE %for d=1,1,nd %cycle k=3*d DV(k)=LBB(d) DV(K+1)=LBp(d) DV(k+2)=UBp(d) %repeat K = 3*ND+2 j = ND; ! set dimensionality SNDISP = 4*WORKA_CONST PTR I = SNDISP %cycle D = 0,1,K CTABLE(WORKA_CONST PTR) = DV(D) WORKA_CONST PTR = WORKA_CONST PTR+1 %repeat %if WORKA_CONST PTR>WORKA_CONST LIMIT %then %c FAULT(102,WORKA_WKFILEK,0) %result = I %end %routine DECLARE ARRAYS(%integer FORMAT,FINF) !*********************************************************************** !* FORMAT=1 FOR 'ARRAYFORMAT' =0 OTHERWISE * !* FINF>0 FOR RECORD FORMAT INFORMATION =0 OTHERWISE * !* P IS AT P IN * !* * !* P= * !* P = '('':'*')' * !* * !* ARRAYS WITH CONSTANT BOUNDS HAVE THEIR D-V IN THE SST * !* ALL OTHER ARRAYS HAVE A DOPE VECTOR AMONG THE LOCALS AND GET * !* THEIR SPACE OFF THE STACK AT RUN TIME * !* BOTH SORTS OF ARRAYS HAVE A FOUR WORD HEAD AND D-V TO EMAS * !* SYSTEM STANDARDS * !*********************************************************************** %integer DVDISP,PP,DVF,ELSIZE,TOTSIZE,PTYPEP,ARRP,NN,ND,II,CDV, LWB,PTYPEPP,JJJ,JJ,TRIP1,RL,TOPp,iden %record (RD) OPND1 SAVE STACK PTR; ! FOR LATER UNDECLARING ARRP = 2*FORMAT+1; ARR = ARRP; PACK(PTYPEP) ELSIZE = ACC START:NN = 1; P = P+1; ! NO OF NAMES IN NAMELIST PP = P; CDV = 0; PTYPEPP = PTYPEP P = P+3 %and NN = NN+1 %while A(P+2)=1 P = P+3 DVDISP = DOPE VECTOR(YES,TYPE,ELSIZE,1,FROMAR2(PP)) TOPP=P ND = J CDV = 1 %if LWB=0 %and FORMAT=0 %then PTYPEPP = PTYPEP+256 SNDISP = SNDISP>>2 DVDISP=DVDISP>>2 DECL: ! MAKE DECLN - BOTH WAYS J = ND RL=ROUNDINGLENGTH(AHEADPT,1) N = (N+RL)&(\RL); ! MAY BE BENEFITS IN WORD ALIGNMENT %cycle JJJ = 0,1,NN-1; ! DOWN NAMELIST iden = FROM AR2(PP+3*JJJ) PTYPE = PTYPEPP; UNPACK STORE TAG(iden,LEVEL,RBASE,ND,dvdisp,ELSIZE,N,FINF) N = N+AHEADSIZE %if format=0 %start %if ptypepp&15=5 %then outstring("char ") %else outtype(ptypepp&255,finf) outname(iden) %for ii=nd,-1,1 %cycle p=ctable(dvdisp+3*ii+2) outstring(" [") csexp(x'51') %if ctable(dvdisp+3*ii)=x'80000000'%start outsym('-'); p=ctable(dvdisp+3*ii+1) outsym('('); csexp(x'51'); outstring(")+1") %finish %else %if ctable(dvdisp+3*ii)<1 %start outsym('+'); outint(1-ctable(dvdisp+3*ii)) %finish %else %if ctable(dvdisp+3*ii)>1 %start outsym('-'); outint(ctable(dvdisp+3*ii)-1) %finish outsym(']') %if ptypepp&15=5 %start outstring(" ["); outint(elsize); outstring("] ") %finish %repeat %if jjj#NN-1 %then outsym(';') %and outsym(NL) %finish %repeat P = TOPP+1; ! PAST REST OF ARRAYLIST %if A(P-1)=2 %then %return outsym(';') %and outsym(NL) ->start %end %integer %fn ROUNDING LENGTH(%integer PTYPE,RULES) !*********************************************************************** !* RULES=0 IN RECORDS(BEST DEFINED) * !* RULES=1 IN STACK FRAME(MOST LATITUDE) * !* RULES=2 AS PARAMETERS(FUNNY HARDWARE CONSIDERATIONS) * !*********************************************************************** %if PTYPE&X'1000'#0 %then %result = PTR ROUNDING(128*RULES) ! TREAT RT PARAMS AS %name %if PTYPE&X'C00'#0 %then %c %result = PTR ROUNDING(PTYPE&X'7F'+128*RULES) %result = RNDING(PTYPE&X'7F'+128*RULES) %end %routine CLT !*********************************************************************** !* DEAL WITH PHRASE TYPE AND SET PREC,TYPE & ACC * !* ONLY PROBLEM ARE STRINGS WHICH HAS OPTIONAL MAX LENGTH ALSO * !* RECORD WHICH HAVE A FORMAT * !* P ON PHRASE TYPE AT ENTRY - TO NEXT PHRASE AT EXIT. * !*********************************************************************** %integer ALT,PTYPEP,I,FLAGS,SJ ALT = A(P) FLAGS = TYPEFLAG(ALT) %if FLAGS&X'8000'#0 %then %c P = P+1 %and FLAGS = TYPEFLAG(A(P)+FLAGS&15) %if FLAGS&X'4000'#0 %then P = P+1; ! ALLOWS BYTE OR BYTEINTEGER%c ETC %if FLAGS&X'2000'#0 %then WARN(8,0); ! SUBSTITUTION MADE %if FLAGS&X'1000'#0 %then FAULT(99,0,0) PREC = FLAGS>>4&15 TYPE = FLAGS&7 P = P+1 ACC = BYTES(PREC) PACK(PTYPEP); ! PRESERVE ALL COMPONENT ! BEFORE CALLINT INTEXP ETC %if TYPE=5 %then %start; ! P='%STRING' %if A(P)=1 %then %start; ! MAX LENGTH GIVEN %if A(P+1)=1 %start; ! EXPRESSION NOT STAR P = P+4 %if INTEXP(I,MINAPT)#0 %then FAULT(41,0,0) %and i=255 FAULT(70,I,0) %unless 1<=I<=255 ACC = I+1 PTYPE = PTYPEP; UNPACK %finish %else ACC = 0 %and P = P+2 %finish %else ACC = 0 %and P = P+1 %finish KFORM = 0 %if TYPE=3 %then %start SJ = J KFORM = CFORMATREF PTYPE = PTYPEP UNPACK J = SJ %finish %end %routine CQN(%integer P) !*********************************************************************** !* SET NAM & ARR FROM ALTERNATIVE OF PHRASE * !* P='%arrayname','%name',<%NULL> * !* P POINTS TO THE ANALYSIS RECORD ENTRY AS IS NOT UPDATED * !*********************************************************************** %integer I I = A(P); NAM = 0; ARR = 0 %if I=1 %then ARR = 1; ! ARRAYNAMES %if I<=2 %then NAM = 1; ! ARRAYNAMES & NAMES %end %routine CRSPEC(%integer M) !*********************************************************************** !* MODE=0 FOR NORMAL ROUTINE SPEC * !* MODE=1 FOR EXTERNAL(ETC) ROUTINE SPECS XREF NEEDED * !* P ON ENTRY TO P(RT) IN (RT)(MARK)(%spec')(NAME)(FPP) * !*********************************************************************** %integer KK,JJ,TYPEP,OPHEAD,NPARMS,AXNAME,SACC,SKFORM,PCHKWORD,pcount %record(listf) %name lcell %string(255) ss LITL = EXTRN&3 ACC = 0; KFORM = 0; ! FOR NORMAL RTS-CLT WILL REVISE %if A(P)=1 %then %start; ! P=%routine TYPEP = LITL<<14!X'1000' P = P+4; ! IGNORING ALT OF P(SPEC') and hole %finish %else %start; ! P= ROUT = 1; ARR = 0; P = P+1 CLT; NAM = 0 %if A(P)=2 %then NAM = 2; ! 2 FOR MAP 0 FOR FN PACK(TYPEP) P = P+4; ! AGAIN IGNORING ALT OF P(SPEC') and hole %finish KK = FROM AR2(P) AXNAME = ADDR(WORKA_LETT(WORD(KK))) JJ = 0 P = P+3 SACC = ACC; SKFORM = KFORM; ! FOR RECORD MAPS WITH PARAMS %if A(P-1)=1 %then %start %if LITL=0 %then WARN(10,0) MOVE BYTES(A(P)+1,ADDR(A(0)),P,ADDR(A(0)),WORKA_ARTOP) outstring("#define "); outstring(string(axname)) AXNAME = ADDR(A(WORKA_ARTOP)) outsym(' ') %if string(axname)="s_cstring" %then outstring("s__cstring") %else outstring(string(axname)) outsym(NL) WORKA_ARTOP = (WORKA_ARTOP+4+A(P))&(-4) P = P+A(P)+1 %finish CFPLIST(OPHEAD,NPARMS) PCHKWORD = 0 ss=string(axname) { symbol table vsn of name } %if 0<=m<=1 %start %unless typep&x'c000'#0 %andc (ss="malloc" %or ss="free" %or ss="realloc" %or ss="perror" %orc ss="getcwd" %or ss="strlen") %c %then %start ! %if typep&x'c000'=0 %then outstring("static ") %if typep&x'c000'=x'8000' %then outstring("extern ") outtype(typep&255,skform) %if typep&x'800'#0 %and typep&7#5 %then outsym('*') outname(kk); outsym('('); outsym(' ') lcell==aslist(ophead) %if nparms=0 %then outstring("void ") %else %start %for pcount=1,1,nparms %cycle %if lcell_s1&x'10000000'#0 %start {GT: Unfixed bug. Type parameter i 0 in an externalspec } { and shows up as extern void itos(void, void) } { instead of extern void itos(int, int) } outtype(lcell_s1>>16&255,lcell_sndisp); outstring("()") %else outxtype(lcell_s1>>16,lcell_sndisp) %finish %if lcell_link#0 %then outsym(',') lcell==aslist(lcell_link) %repeat %finish outstring(");") %finish %finish %if NPARMS>0 %then PCHKWORD = NPARMS<<16!ASLIST(OPHEAD)_S3>>16 %if M=1 %then %start %if TARGET=EMAS %or TARGET=PNX %or TARGET=IBM %or %c TARGET=IBMXA %or target=amdahl %or %c 1< FOR EACH DEL %if PARAMS BWARDS=YES %then %start PUSH(OPHEAD,0,0,RL) CELL = OPHEAD %finish %else %start BINSERT(OPHEAD,OPBOT,0,0,RL) CELL = OPBOT %finish LCELL == ASLIST(CELL) LCELL_PTYPE <- PTYPE; ! DIRECT "PUSH" FAILS ON HALF SWOPPED%c MACHINES LCELL_SNDISP = kform LCELL_ACC <- ACC NPARMS = NPARMS+1 P = P+3 %repeat P = PP %repeat OPBOT = OPHEAD; INC = 0; ! FURTHER PASS TO ALLOCATE SPACE ! %while OPBOT>0 %cycle ! LCELL == ASLIST(OPBOT) ! RL = LCELL_S3; LCELL_S3 = 0; ! EXTRACT ROUNDIMG LENGTH ! RSIZE = LCELL_SNDISP; ! INC EXTRACTED ! INC = (INC+RL+SFRAME MISALIGN)&(\RL)-SFRAME MISALIGN ! %if PARAMSBWARDS=NO %and RSIZE0 %then ASLIST(OPHEAD)_S3 = PP PRINTLIST(OPHEAD) %if PARM_Z#0 %end %routine CFPDEL !*********************************************************************** !* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION * !* P=<%qname'>, * !* (RT)(%name')(NAMELIST)(FPP), * !* '%NAME'. * !*********************************************************************** %switch FP(1:3) %integer FPALT FPALT = A(P); P = P+1 KFORM = 0; LITL = 0 ->FP(FPALT) FP(1): ! (TYPE)(%qname') ROUT = 0; CLT CQN(P) %if TYPE=5 %and NAM=0 %and (ACC<=0 %or ACC>256) %then %c FAULT(70,ACC-1,0) %and ACC = 255 P = P+1 ->PK FP(2): ! (RT)(%name')(NAMELIST)(FPP) ROUT = 1; NAM = 1 ARR = 0 %if A(P)=1 %then %start; ! RT=%rouitne TYPE = 0; PREC = 0 P = P+2 %finish %else %start P = P+1; CLT; ! RT=(TYPE)(FM) NAM = 1 %if A(P)=2 %then NAM = 3; ! 1 FOR FN 3 FOR MAP P = P+2; ! PAST (%name') WHICH IS IGNORED %finish ACC = RT PARAM SIZE ->PK FP(3): ! %name ACC = PTRSIZE(0); NAM = 1 ROUT = 0; TYPE = 0 ARR = 0; PREC = 0 PK: PACK(PTYPE) %end %routine RHEAD(%integer RTNAME,AXNAME,Xtra) !*********************************************************************** !* COMPILES CODE FOR BLOCK AND ROUTINE ENTRY * !* RTNAME IS THE RT/FN/MAP NAME (=-1 FOR %begin BLOCKS) * !* XNAME IS THE EXTERNAL NAME (="" FOR INTERNALS&BLOCKS * !* ACTIONS INCLUDE PLANTING JUMPS ROUND RT BODY AND * !* DEFINING EXTERNAL ENTRIES AS WELL AS PLANTING ENTRY CODE * !*********************************************************************** %integer W3,Flags %record (LISTF) %name LCELL Flags=0 %if Xtra#0 %then flags=Bstruct CURRINF_SNMAX = NMAX; CURRINF_SN = N %if RTNAME>=0 %then %start; ! SECTION FOR ROUTINES LCELL == ASLIST(TAGS(RTNAME)) ! ! FIRST JUMP ROUND BODY UNLESS AT TOP LEVEL OR IN COMPILER ! OR A JUMP IS ALREADY OUTSTANDING AT THIS LEVEL ! MUST DO THIS HERE BEFORE LEVEL IS CHANGED OR LABEL LIST IS WRONG ! %if PARM_COMPILER=0 %and LEVEL>1 %and CURRINF_JROUND=0 %start PLABEL = PLABEL-1 CURRINF_JROUND = PLABEL %if JRNDBODIES=YES %then ENTER JUMP(15,PLABEL,0) %finish RLEVEL = RLEVEL+1; RBASE = RLEVEL {GT:}! FAULT(105,0,0) %if RLEVEL>=2 {REMOVING THIS ALLOWS NESTED PROCS} %finish LEVEL = LEVEL+1 CURRINF == LEVELINF(LEVEL) CURRINF = 0 CURRINF_RBASE = RBASE CURRINF_CLEVEL = LEVEL; ! SELF POINTER IS NEEDED IN GENERATE CURRINF_NAMES = -1 CURRINF_DIAGINF = LEVELINF(LEVEL-1)_DIAGINF ! %if target=gould %then currinf_maxpp = levelinf(level-1)_maxpp CURRINF_DISPLAY = LEVELINF(LEVEL-1)_DISPLAY FAULT(34,0,0) %if LEVEL=MAX LEVELS FAULT(105,0,0) %if LEVEL>MAX LEVELS ! ! DEAL WITH EXTERNAL ENTRIES SO THAT THEY COME TO THIS POINT ! IN THE CODE. THE DESCRIPTORS SET UP ARE OF NO INTEREST TO THIS MODULE ! ONLY TO OTHER MODULES SO NO DETAILS OF THEN ARE RECORDED IN TAGS ! %if RTNAME<0 %then %start { For begin blocks } %if axname=0 %start { not initial begin } currinf_iblkid=internalblockid internalblockid=internalblockid+1 { keep a blk no for switches & labels } %finish W3 = 0 %else W3 = RTNAME+1 internalblockid=0 %finish CURRINF_L = LINE; CURRINF_M = W3 CURRINF_FLAG = PTYPE&X'FFFF'; ! CURRENT BLOCK TYPE MARKER ! SIGN MUST NOT PROPOGATE ! ! TILL LOADER COPIES GLAP TO GLA MUST CALL A FRIG ROUTINE TO DO ! THIS ESSENTIAL AS SOON AS POSSIBLE IN ANYTHING EXTERNAL ! W3 = ULCONSTTRIP(RTHD,X'61',Flags,RTNAME,AXNAME) %end %routine RDISPLAY(%integer KK) !*********************************************************************** !* SET UP OR COPY THE DISPLAY * !* SINCE THIS IS IN REGISTERS ON 360 IT IS EASY * !* ALSO CLAIM STACK SPACE AND SET DIAGNOSTIC POINTERS * !*********************************************************************** %integer TRIPNO %if KK>=0 %or LEVEL=2 %start; ! DISPLAY NEEDED ! DONE BY THE QCODE CALL CURRINF_PSIZE = N-alpha; ! REMEMBER PARAMETER SIZE FOR RTDICT %if 1<=0 %or LEVEL=2 %start; ! ROUTINE NEW AREA NEEDED %if target=vns %then %c currinf_diaginf = currinf_psize+8 %else %start TRIPNO = UCONSTTRIP(RDAREA,X'51',0,N) N = N+4 N = N+4 %if 1<=0 %or LEVEL=2 %start NMAX = N %finish %end %routine CUI(%integer CODE) !*********************************************************************** !* COMPILE AN UNCONDITIONAL INSTRN WHEREEVER IT OCCURS * !* CODE=0 UNCONDITIOALLY,=1 AFTER %then, =2 AFTER %else * !*********************************************************************** %integer PT,MARKER,J,LNAME,TYPEP,PRECP,ALT,KK %record (RD) OPND1 %integer HEAD1,BOT1,NOPS,savepos %record (RD) RPOP %record (LISTF) %name LCELL %record(swdataform)%name swdata %owninteger depth %switch SW(1:9) depth=depth+1 %if depth=1 %then savepos=opline_length %and outsym(' ') REPORTUI = 0 ALT = A(P) ->SW(ALT) SW(1): ! (NAME)(APP)(ASSMNT?) P = P+1; MARKER = P+FROMAR2(P) %if A(MARKER)=1 %then %start J = P+2; P = MARKER+2 ASSIGN(A(MARKER+1),J) %finish %else %start P = P+2 CNAME(0) P = P+1 %finish AUI: J = A(P); P = P+1 %if j=1 %start %if depth=1 %then opline_l(savepos)='{' {GT:} %if opline_l(opline_length-1) # '{' %then outstring("; ") CUI(CODE) %if depth=1 %then outstring(";}") %finish depth=depth-1 %return SW(2): ! -> (NAME)(APP) CURRINF_NMDECS = CURRINF_NMDECS!1 CURR INST = 1 %if CODE=0 LNAME = FROM AR2(P+1) J = A(P+3); P = P+4 %if J=2 %then %start; ! SIMPLE LABEL ENTER JUMP(15,LNAME,0) REPORTUI = 1 outstring("goto "); outname(lname) %finish %else %start; ! SWITCH LABELS COPY TAG(LNAME,NO) %unless OLDI=LEVEL %and TYPE=6 %start FAULT(4,0,LNAME); P = P-1; SKIP APP %return %finish outsym('{'); outswadname(lname); outstring("_value=") CSEXP(MINAPT) {GT:} ! NOTE goto t_despatch ... should pass in __LINE__ and __FILE__ ! rather than allow them to be picked up at point of dispatch ! by which time they are meaningless {GT:} outstring("; "); outswadname(lname); outstring("_line = __LINE__") {GT:} outstring("; "); outswadname(lname); outstring("_file = __FILE__") outstring("; goto "); outswadname(lname) outstring("_despatch;}") REPORTUI = 1 %finish depth=depth-1 %return SW(3): ! RETURN FAULT(30,0,0) %unless CURRINF_FLAG&X'3FFF'=X'1000' P = P+1 outstring("return ") RET: KK = UCONSTTRIP(RTXIT,X'51',0,0) REPORT UI = 1 CURR INST = 1 %if CODE=0 depth=depth-1 %return SW(4): ! %result(ASSOP)(EXPR) outstring("return ") PTYPE = CURRINF_FLAG&X'3FFF'; UNPACK PT=ptype&255 OPND1 = 0 OPND1_PTYPE <- PTYPE; OPND1_FLAG = DNAME OPND1_D = CURRINF_M-1 %if PTYPE>X'1000' %and A(P+1)#3 %then %start; ! ASSOP #'->' %if A(P+1)=1 %and NAM#0 %and A(P+5)=4 %and A(P+6)=1 %start P = P+7; TYPEP = TYPE; PRECP = PREC; J = P CNAME(4) KK = BRECTRIP(MAPRES,PTYPE&255,0,OPND1,NAMEOPND) FAULT(81,0,0) %unless A(P)=2; P = P+1 FAULT(83,CURRINF_M-1,FROMAR2(J)) %unless %c TYPEP=TYPE %and PRECP=PREC ->RET %finish %if A(P+1)=2 %and NAM=0 %then %start; ! ASSOP='=' P = P+2 %if TYPE=5 %then %start CSTREXP(0); ! FULL VIRTAD %finish %else %if TYPE=3 %start ->BAD RES %unless A(P+3)=4 %and A(P+4)=1 P = P+5 CNAME(3) FAULT(66,0,OPND1_D) %unless TYPE=3 EXPOPND = NAMEOPND %finish %else %start %if PREC<4 %then PREC = 4 CSEXP(PREC<<4!TYPE) %finish %if PT=X'31' %or PT=X'41' %Start kk=urectrip(SHRTN,PT,0,expopnd) expopnd_flag=reftrip; expopnd_d=kk expopnd_ptype=PT %finish KK = BRECTRIP(FNRES,PTYPE&255,0,OPND1,EXPOPND) ->RET %finish %finish P = P+2 BAD RES: FAULT(31,0,0) SKIP EXP; ! IGNORE SPURIOUS RESULT depth=depth-1 %return SW(5): ! %monitor (AUI) ! Woud be nice to intercept this at the level above and translate ! %if %then %monitor ! to ! assert(!(cond)) {GT:} outstring("assert(_IMP_MONITOR_)") P = P+1; ->AUI SW(6): ! %stop {GT:} outstring("exit(0)"{"imp_stop()"}) ! KK = UCONSTTRIP(XSTOP,X'51',0,0) P = P+1 CURR INST = 1 %if CODE=0 REPORTUI = 1 depth=depth-1 %return SW(7): !'%SIGNAL'(EVENT')(N)(OPEXPR) P = P+5 KK = INTEXP(J,MINAPT); ! EVENT NO TO J %if A(P)=1 %start; ! SUBEVENT SPECIFIED P = P+3; skip exp %finish outstring("*** IMP signals untranslateable *****") depth=depth-1 %return SW(8): ! %exit outstring(" break ") REPORTUI = 1 CURR INST = 1 %if CODE=0 depth=depth-1 %return SW(9): ! %continue REPORTUI = 1 CURR INST = 1 %if CODE=0 outstring(" continue ") depth=depth-1 %return %end %routine CIFTHEN(%integer MARKIU,MARKC,MARKUI,MARKE,MARKR,Afterelse) !*********************************************************************** !* THIS ROUTINE COMPILES CONDITIONAL EXPRESSIONS.IT REQUIRES THE * !* FOLLOWING PARAMETERS TO BE SET TO THEIR A .R. ENTRY. * !* MARKIU TO THE ENTRY FOR P(%iu) * !* MARKC TO THE ENTRY FOR P(COND) * !* MARKUI TO THE ENTRY FOR (FIRST OCCURRENCE OF) P(UI) * !* MARKE TO THE ENTRY FOR P(ELSE') - =0 FOR BACKWARDS CONDITION * !* MARKR TO ENTRY FOR P(RESTOFIU) - =0 FOR BACKWARDS CONDITION * !*********************************************************************** %integer ALTUI,CCRES,ELRES,THENLAB,ELSELAB,USERLAB,REPORT,START, ELSEALT,K,J,CS,LINETRIP,ctype %const %integer NULL ELSE=4 %switch ESW(1:NULL ELSE) %owninteger depth=0 depth=depth+1 LINETRIP = -1 SET LINE %and LINETRIP = TRIPLES(0)_BLINK MARKIU = A(MARKIU); ! ALT OF IU 1=%if,2=%unless PLABEL = PLABEL-1 THENLAB = PLABEL START = 0; CS = 0; ! NO START IN CONDITION YET CS = 1 %if STARSIZE>100; ! LONG JUMPS FOR COMPLEX STMTS ELSELAB = 0; ! MEANS NO ELSE CLAUSE P = MARKC %if MARKR>0 %and A(MARKR)<=2 %then %c START = 1 ! '%START' OR '%THENSTART' ! %if MARKE#0 %and LEVEL<2 %and START=0 %then FAULT(57,0,0) USERLAB = -1 %if START#0 %then ALTUI = 0 %else ALTUI = A(MARKUI) %if ALTUI=2 %and A(MARKUI+3)=2 %then USERLAB = FROM AR2(MARKUI+1) ! UI = SIMPLE LABEL %if 8<=ALTUI<=9 %and currinf_EXITLAB#0 %start; ! VALID EXIT %if ALTUI=8 %then USERLAB = currinf_EXITLAB %else %c USERLAB = currinf_CONTLAB %finish ! ctype=rlevel %if tcond#0 %then ctype=0 P = MARKC { may be changed by tcond } %if ctype=0 %start %if Afterelse=NO %then outsym(NL) %and outstring("#if") %else outstring("if ") %finish CCRES = CCOND(1,MARKIU,THENLAB,B'11'!!START!!CS) %if START#0 %then %start; ! %then %start %if CCRES=0 %start; ! CONDITIONAL ! FAULT(57,0,0) %if LEVEL<2 CURRINF_NMDECS = CURRINF_NMDECS!1 %finish %else %start ! DELETE LINE NO UPDATE FOR%c CONDITIONAL STARTR ! (IT MIGHT CONTAIN M-C CODE!) %if LINE TRIP>0 %then TRIPLES(LINETRIP)_OPERN = NULLT %finish P = MARKR+1 %If ctype#0 %then curly check(1) %and outsym('{'); outsym(NL) CSTART(CCRES,1) %If ctype#0 %then outstring("}");! outstring(" /* if clause */") %if A(P)<=2 %then PLABEL = PLABEL-1 %and ELSELAB = PLABEL MARKE = P REPORT = LAST INST %finish %else %start %if CCRES#2 %start %if ctype=0 %then outsym(NL) P = MARKUI; CUI(1) %if MARKE#0 %and a(MARKE)#NULL ELSE %and opline_l(opline_length-1)#'}' %then outsep REPORT = REPORTUI %finish %else %start; ! FIRST UI NEVER EXECUTED REPORT = 1 %finish %finish ELSE: ! ELSE PART %if MARKE=0 %then ELSEALT = NULL ELSE %else ELSEALT = A(MARKE) %if ELSEALTESW(ELSEALT) ESW(1): ! '%ELSESTART' %if ctype=0 %start outsym(NL); outstring("#else"); curly check(1); outsym(NL) %else outstring(" else {"); curly check(1); outsym(NL) %finish %if CCRES=0 %then CURRINF_NMDECS = CURRINF_NMDECS!1 CSTART(CCRES,2) %If ctype#0 %then outstring("}"); ! outstring(" /* else clause*/") %if ctype=0 %start outsym(NL); outstring("#endif") %finish ->ENTER ELSELAB ESW(2): ! '%ELSE' (%iu) ETC MARKE = 0; MARKUI = 0 MARKR = P+1+FROMAR2(P+1) %if A(MARKR)=3 %then %start MARKE = MARKR+1+FROM AR2(MARKR+1) MARKUI = MARKR+3 %finish J = NEXT TRIP %if ctype=0 %start outsym(NL); outstring("#else"); outsym(NL) CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,no) outsym(NL); outstring("#endif") %else outstring(" else "); ! outsym('{') CIFTHEN(P,P+3,MARKUI,MARKE,MARKR,NO) outsym(NL); ! outsym('}') %finish REPORT = 0; ! CANT TELL IN GENERAL ->ENTER ELSELAB ESW(3): ! '%ELSE' %if ctype=0 %start outsym(nl); outstring("#else"); outsym(NL) %else outstring(" else ") %finish %if CCRES#1 %then %start %if START#0 %then SET LINE; ! FOR CORRECT LINE IF FAILS IN UI %if THENLAB=0 %then K = 0 %else K = 2 CUI(K) REPORT = REPORTUI %if ctype=0 %then %start outsep outsym(NL) outstring("#endif") %else %if depth>1 %then outsep %finish %finish ENTER ELSELAB: %if ELSELAB>0 %then ELRES = ENTER LAB(ELSELAB,B'11'!REPORT<<2) depth=depth-1; %return ! CONDITIONAL MERGE ESW(NULL ELSE): ! NULL ELSE CLAUSE %if ctype=0 %start outsep %if start=0 outsym(NL); outstring("#endif") %finish depth=depth-1; %end %routine CSTART(%integer CCRES,CODE) !*********************************************************************** !* COMPILE A COMPLETE START-FINISH BLOCK BY RECURSION * !* IF START NEVER EXECUTED SKIP TO CORRESPONDING FINISH * !* CODE=0 WAS UNCONDITIONAL NOW SHOULD BE UNUSED * !* CODE=1 AFTER THEN * !* CODE=2 AFTER ELSE * !* CODE=3 AFTER ONEVENT * !* P ON ENTRY TO FORWARD POINTER TO THE RIGHT FINISH * !* P ON EXIT TO THE ELSE CLAUSE AFTER THE RIGHT FINISH * !*********************************************************************** %integer SKIPCODE,FINISHAR,OLDNEXTP,OLDLINE {GT:}%if CODE=3 %then outstring("/* beginning of onevent block */") %and outsym(NL) SKIPCODE = NO %if 1<=CODE<=2 %and CCRES!CODE=3 %then SKIPCODE = YES ! NEVER EXECUTED FINISHAR = FROMAR4(P); ! TO START OF AR FOR FINISH OLDLINE = LINE; ! FOR ERROR MESSAGES %cycle; ! THROUGH INTERVENING STATMNTS OLDNEXTP = NEXTP COMPILE A STMNT %repeat %until OLDNEXTP>=FINISHAR; ! HAVING COMPILED FINISH {GT:}%if CODE=3 %then outstring("/* end of onevent block */") %and outsym(NL) P = FINISHAR+10; ! TO ELSE CLAUSE ! %if A(P)<=3 %and CODE#1 %then FAULT(45+CODE,OLDLINE,0) %if SKIPCODE=YES %then LAST INST = 1 %end %routine CCYCBODY(%integer UA,ELAB,CLAB) !*********************************************************************** !* COMPILES A CYCLE REPEAT BODY BY RECURSION * !* ON ENTRY P IS TO FORWARD POINTER. ON EXIT TO ALT OF UNTIL * !* UA = O IF UNTIL NOT ALLOWED * !* ELAB&CLAB ARE LABELS FOR ELSE & CONTINUE * !*********************************************************************** %integer FINISHAR,OLDLINE,SAVEE,SAVEC FINISHAR = FROMAR4(P) %if FINISHAR<=P %then IMPABORT FORDPTH = FORDPTH+1 OLDLINE = LINE; SAVEE = currinf_EXITLAB; SAVEC = currinf_CONTLAB currinf_EXITLAB = ELAB; currinf_CONTLAB = CLAB curly check(1) outsym('{'); outsym(NL) %while NEXTP<=FINISHAR %cycle COMPILE A STMNT %repeat outstring("}"); ! outstring(" /* loop */") currinf_EXITLAB = SAVEE; currinf_CONTLAB = SAVEC P = FINISHAR+10 FORDPTH = FORDPTH-1 %if A(P)=1 %and UA=0 %then FAULT(12,OLDLINE,0) %end %routine CLOOP(%integer ALT,MARKC,MARKUI) !*********************************************************************** !* ALT=1 FOR %while, =2 FOR %until, =3 FOR %for * !* MARKC IS TO THE CONDITION OR CONTROL CLAUSE * !* MARKUI IS TO THE UI, SPECIAL FOR %cycle * !* FORBITS DEFINES FOR LOOP AS FOLLOWS:- * !* 2**2 TO 2**0 SET FOR CONSTANT INITIAL,INC &FINAL * !* CORRESPONDING UPPER BYTE SET DEFINES CONSTANT FURTHER * !* 2**7 NEGATIVE CONSTANT * !* 2**4 CONSTANT IS 2 * !* 2**3 CONSTANT IS 1 * !* 2**2 CONSTANT IS 0 * !* 2**1 CONSTANT IS -1 * !* 2**0 CONSTANT IS -2 * !* THESE BITS ARE PASSED ON TO GENERATOR FOR SPECIAL CASE * !*********************************************************************** %integer L1,L2,L3,L4,CCRES,ELRES,FLINE,TRIP,FOT,PP,DEBJ,JJ,FSTRIP %integer FORNAME,INITP,STEPP,FINALP,REPMASK,FORPT,FORWORDS,FORBITS %record (RD) INITOPND,STEPOPND,FINALOPND,DIFFOPND,ZOPND,OPND %record (TRIPF) %name CURRT %routine %spec FOREXP(%record (RD) %name EOPND, %integer TT,SH) %switch SW(0:6) P = MARKC FORBITS = 0 SFLABEL = SFLABEL-2 L1 = SFLABEL; L2 = L1+1 ! ! SET L3 FOR ALTS 0,5&6 ONLY ! L3 = 0 %if B'1100001'&1<SW(ALT) SW(0): ! %cycle PP = FROM AR4(P)+10; ! TO UNTIL CLAUSE IF ANY %if A(PP)=1 %start; ! %repeat %until outstring("do ") C CYC BODY(1,L2,L3) ! L3 = L3*ENTER LAB(L3,B'011'); ! DELETE IF NOT NEEDED SET LINE outstring(" while ") P = PP+1; CCRES = CCOND(0,2,L1,0) %finish %else %start outstring("for (;;) ") C CYC BODY(1,L2,L1); ! CONTINUES DIRECT TO TOP !outstring(" while (1) /* FOR EVER */") ! ENTER JUMP(15,L1,0) %finish ! L2 = L2*ENTER LAB(L2,B'011'); ! DELETE IF NOT NEEDED WAYOUT: ! REMOVE LABELS NOT REQUIRED %return sw(1): ! UI while cond outstring("while ") ccres=ccond(0,1,l2,b'11') p=markui cui(1) ! enter jump(15,l1,0) ! uncoditional back to while ! L2 = L2*ENTER LAB(L2,B'111'); ! CONDITIONAL(?) & REPLACE ENV ->WAYOUT SW(2): ! UI %until COND P = MARKUI outstring("do ") CUI(1) P = MARKC outsep; outstring(" while ") CCRES = CCOND(0,2,L1,0) ->WAYOUT SW(6): ! %for ... %cycle SW(3): ! UI %for .... FORCNT = FORCNT+1; ! TO DETCT FORS IN ENCLOSED STMTS FORNAME = FROMAR2(P) INITP = P+2 COPY TAG(FORNAME,YES); ! DECLARE IF UNKNOWN TO COMPILER FAULT(91,0,FORNAME) %and ptype=X'51' %unless %c (TYPE=7 %or TYPE=1) %and 4<=PREC<=5 %and ROUT=0=ARR %and LITL#1 FOT = DNAME; ! FOR OPERAND TYPE %if NAM#0 %then FOT = INDNAME FORPT = PTYPE&255; ! SAVE TYPE&PREC OF CONTROL ! P = INITP SKIP EXP; ! P TO STEP EXPRSN STEPP = P; SKIP EXP; ! P TO FINAL FINALP=p ! P = STEPP FOR EXP(STEPOPND,1,1); ! Investigate step and evaluate if constant outstring(" for (") %if FOT=INDNAME %then outsym('*') outname(FORNAME) outsym('=') P = INITP; csexp(FORPT) outsep outsym(' ') %if FOT=INDNAME %then outsym('*') outname(FORNAME) %if STEPOPND_FLAG<=1 %start FAULT(92,0,0) %if STEPOPND_D=0; ! ZERO STEP %if STEPOPND_D<0 %then outstring(">=") %else outstring("<=") %finish %else %start outstring("<=") warn(10,0) %finish p=finalp; csexp(FORPT) outsep outsym(' ') %if FOT=INDNAME %then outsym('*') outname(FORNAME) %if STEPOPND_FLAG<=1 %and iMOD(STEPOPND_D)=1 %start %if STEPOPND_D<0 %then outstring("--") %else outstring("++") %else outstring("+=") p=STEPP; csexp(FORPT) %finish outstring(") ") ! P = MARKUI; ! TO UI OR '%CYCLE'(HOLE) %if ALT=3 %then %start; ! DEAL WITH CONTROLLED STMNTS CUI(0) %finish %else %start CCYCBODY(0,L2,L3) %finish ->WAYOUT SW(4): ! %while COND %cycle SET LINE outstring("while ") CCRES = CCOND(0,1,L2,2); ! merge but not short C CYC BODY(0,L2,L1) ! ENTER JUMP(15,L1,0) ! L2 = L2*ENTER LAB(L2,B'111'); ! CONDITIONAL & REPLACE ENV ->WAYOUT SW(5): ! %until ... %cycle ! ALSO %cycle... %repeat %until ! MARKUI TO %cycle P = MARKUI FLINE = LINE outstring("do ") C CYC BODY(0,L2,L3) P = MARKC ! L3 = L3*ENTER LAB(L3,B'011'); ! CONTINUE LABEL IF NEEDED LINE = FLINE; SET LINE outsep; outstring(" while ") CCRES = CCOND(0,2,L1,0) ! L2 = L2*ENTER LAB(L2,B'011') ->WAYOUT %routine FOR EXP(%record (RD) %name EOPND, %integer TOTEMP,SHIFT) !*********************************************************************** !* P INDEXES EXPRESSION. IF CONST PUT INTO EVALUE OTHERWISE * !* dont generate anything * !*********************************************************************** %integer INP,VAL,SUBBITS %integer exphead,expbot,nops exphead=0; expbot=0; nops=0 INP = P; P = P+3 torp(exphead,expbot,nops,1) %if nops>>16&7=0 %start { nothing difficult } expop(exphead,expbot,nops,x'200'+FORPT) EOPND = EXPOPND; ! EXPRESSION A LITERAL CONST %else eopnd_flag=255 %finish %end %end !* %routine ASSIGN(%integer ASSOP,P1) !*********************************************************************** !* HANDLES ARITHMETIC,STRING & ADDRESS ASSIGNMENTS TO VARIABLES * !* FORMAL PARAMETERS AND DOPEVECTORS * !* ASSOP:- * !* 1 IS FOR '==' * !* 2 IS FOR '=' * !* 3 IS FOR '<-' (JAM TRANSFER) * !* 4 IS FOR '->' (UNCONDITIONAL RESOLUTION) * !* * !* P POINTS TO THE EXPRESSION. P1 TO THE NAME ON LHS * !*********************************************************************** %integer Q,KK,TYPEP,PRECP,PTYPEP,JJJ,P2,JJ,B,D,HEAD2,BOT2,ACCP, II,HEAD1,NOPS,TPCELL,LVL,BOT1,LHNAME,RHNAME,a1,a2 %record (LISTF) %name LHCELL %record (RD) OPND1,OPND2 %switch SW(0:4); ! TO SWITCH ON ASSOP P2 = P LHNAME = A(P1)<<8!A(P1+1) LHCELL == ASLIST(TAGS(LHNAME)) P = P1; REDUCE TAG(NO); ! LOOK AT LH SIDE PTYPEP = PTYPE; JJ = J KK = K; II = I; LVL = OLDI TPCELL = TCELL; ACCP = ACC P = P2; TYPEP = TYPE; PRECP = PREC; ! SAVE USEFUL INFO FOR LATER ->SW(ASSOP) SW(2): SW(3): ! ARITHMETIC ASSIGNMENTS %if TYPE=3 %then ->RECOP TYPE = 1 %unless TYPE=2 %or TYPE=5; ! IN CASE OF RUBBISHY SUBNAMES ->ST %if TYPE=5; ! LHS IS A STRING BACK: HEAD1 = 0; BOT1 = 0; ! CLEAR TEMPORAYRY LIST HEADS HEAD2 = 0; BOT2 = 0 TYPE = 1 %unless TYPE=2; ! DEAL WITH UNSET NAMES TYPEP = TYPE NOPS = 1<<18+1 PTYPE = PTYPEP; UNPACK %if LHSADDRFIRST=NO %or (NAM=0=ARR %and A(P1+2)=2=A(P1+3)) %start ! SCALAR OPND1 = 0 OPND1_PTYPE <- PTYPE; OPND1_FLAG = ARNAME BINSERT(HEAD1,BOT1,OPND1_S1,P1,LHNAME) %finish %else %start P = P1; CNAME(3); ! 32 BIT ADDR TO STACK BINSERT(HEAD1,BOT1,NAMEOPND_S1,NAMEOPND_D,NAMEOPND_XTRA) %finish P = P2+3 TORP(HEAD2,BOT2,NOPS,0); ! RHS TO REVERSE POLISH OPND2 = 0; OPND2_FLAG = VASS+ASSOP-2 BINSERT(HEAD2,BOT2,OPND2_S1,LHNAME<<16!PTYPEP,0) ! = OR <-OPERATOR ASLIST(BOT1)_LINK = HEAD2 HEAD2 = 0; BOT1 = BOT2 PRINT LIST(HEAD1) %if PARM_Z#0 EXPOP(HEAD1,BOT1,NOPS,256+PRECP<<4+TYPEP); ! PLANT CODE tripopt(triples,triples(0)_flink) outopnd(expopnd,0) %return ST: ! STRINGS p = p1 %if assop=3 %then %start outstring("imp_strjam(") %if nam#0 %then warn(10,0) %finish %else outstring("strcpy(") CNAME(2) outsym(',') p = p2 CSTREXP(0) %if assop=3 %then outsym(',') %and outint(accp-1) outsym(')') %return ! ! THIS SECTION DEALS WITH OPERATIONS ON COMPLETE RECORDS ! RECOP: ! LHS IS RECORD WITHOUT SUBNAME Q = TSEXP(JJJ) %if Q=1 %and JJJ=0 %start; ! CLEAR A RECORD TO ZERO outstring("memset(") P = P1; CNAME(3) outstring(",0,") OPND1 = NAMEOPND OPND2 = 0 OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST outstring("sizeof( ") p=p1; reducetag(NO) outformatname(kform) outsym(')'); outsym(')') P = P2; SKIP EXP %return %finish %if assop=3 {<-} %start ->BACK %unless TYPE=3 %and A(P2+3)=4 %and A(P2+4)=1 outstring("memcpy(") P = P1; CNAME(3) outsym(',') OPND1 = NAMEOPND ACCP = ACC P = P2+5; CNAME(3) outsym(',') OPND2 = NAMEOPND %unless A(P)=2 %then FAULT(66,0,LHNAME) %and ->F00 ! %if ASSOP=2 %and ACCP#ACC %then %c ! FAULT(67,LHNAME,FROMAR2(P2+5)) %and ->F00 %if ACCP>ACC %then ACCP = ACC outstring("sizeof( ") p=p1; reducetag(NO) outformatname(kform) outsym(')'); outsym(')') P = P2; SKIP EXP %return %finish p=P1; cname(7) outstring("=") p=p2+5; cname(7) P = P2; SKIP EXP %return SW(4): ! RESOLUTION outstring("imp_resolve(") P = P1; CNAME(2) outsym(',') P = P2; %if TYPE=5 %then CRES(0) %else %start SKIP EXP FAULT(71,0,LHNAME) %unless TYPE=7 %finish outsym(')') %return SW(1): ! '==' AND %name PARAMETERS ->F81 %unless A(P2+3)=4 %and A(P2+4)=1 FAULT(82,0,LHNAME) %and ->F00 %unless NAM=1 %and LITL#1 ! ONLY NON-CONST POINTERS ON LHS OF== lhformatname=kform %if ARR=1 %then %start JJ = 11; KK = 12 II = AHASS; B = AHEADPT %finish %else %start JJ = 6; KK = 3 II = PTRAS; B = X'51' %if PTRSIZE(PTYPE&255)>4 %then B = X'61' %finish P = P1; CNAME(JJ) outsym('=') P = P2+5 RHNAME = A(P)<<8!A(P+1) %if typep=3 %start reduce tag(NO) %if kform#lhformatname %start outsym('('); outformatname(lhformatname) outstring("*)") %finish %finish CNAME(KK); ! DESCRPTR FETCHED %if kk=12 %start !printstring("dv reset "); write( LHCELL_SNDISP,5); write(sndisp,5); write(ctable(sndisp+3),5); newline %if lhcell_uioj&15=0 %then lhcell_uioj= lhcell_uioj!(j&15) %if LHCELL_SNDISP=0 %then LHCELL_SNDISP=sndisp %finish ->F81 %unless A(P)=2; ! NO REST OF EXP ON RHS ! ->F83 %unless TYPE=TYPEP %and PREC=PRECP %and (ARR>0 %or II=PTRAS) ! ->F86 %unless OLDI<=LVL %or I=0 %or NAM#0 ! GLOBAL == NONOWN LOCAL P = P+1 %return F83: FAULT(83,LHNAME,RHNAME); ->F00 F86: FAULT(86,LHNAME,RHNAME); ->F00 F81: FAULT(81,0,LHNAME) F00: P = P2; SKIP EXP %end %routine outopnd(%record(rd)%name opnd,%integer mode) !*********************************************************************** !* Outputs an operand which may be a complete tree * !* mode&1 = 0 output as is * !* mode&1 = 1 output enclosed in ( and ) * !* mode&2#0 output as a store not a load * !* Mode&256#0 all consts as numeric for switches * !*********************************************************************** %integer i,pp %longreal r %switch sw(0:9) %if mode&1=1 %then outsym('(') ->sw(opnd_flag) sw(0): {short const } sw(1): {long const } %if opnd_ptype&7=1 %start %if opnd_ptype&x'f0'=x'60' %then outlhex(opnd_d,opnd_xtra) %else %start %if opnd_ptype&8#0 %and doinglabel=0 %then %start %if opnd_ptype>>4&7=3 %start {GT:} outsym(''''); %if opnd_d = '\' %or opnd_d = '''' %c %then outsym('\'); outsym(opnd_d); outsym('''') %finish %else outhex(opnd_d) %finish %else outint(opnd_d) %finish %finish %if opnd_ptype=x'52' %then outfl(opnd_r,7) %if opnd_ptype=x'62' %start integer(addr(r))=opnd_d integer(addr(r)+4)=opnd_xtra outfl(r,15) %finish %if opnd_ptype=x'72' %start outstring("NAN or unrepresentable value") %finish %if opnd_ptype=x'35' %start outsym('"') outstring(string(addr(a(opnd_d)))) outsym('"') %finish wayout: %if mode&1=1 %then outsym(')') %return sw(2): { name as dictionary no } outname(opnd_d) ->wayout sw(3): { name(app) as ar pointer } pp=p; p=opnd_d %if mode&2#0 %then cname(1) %else cname(2) p=pp; ->wayout sw(8): { triple } outtriple(opnd_d,mode&x'ff00') ->wayout %end %routine outtriple(%integer tripno,mode) !*********************************************************************** !* output an expression defined by a triple which can head a tree * !* mode as for outopnd * !*********************************************************************** %record(tripf)%name trip %conststring(3)%array rsassop(ADD:ANDL)="+=","-=","^=", "|=","*=","/="(2),"&="; %string(15) op,opl %integer case,i,j %switch sw(0:192) trip==triples(tripno) %if mode=1 %and doinglabel=0 %then outsym('(') case=trip_opern ->sw(case) sw(ADD): op="+"; opl="plus" binop: outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1) %if doinglabel#0 %then outstring(opl) %else outstring(op) outopnd(trip_opnd2,mode&x'ff00'!trip_opnd2_flag>>3&1) wayout: %if mode=1 %and doinglabel=0 %then outsym(')') %return sw(SUB): op="-"; opl="minus"; ->binop sw(NONEQ): op="^"; opl="non"; ->binop sw(ORL): op="|"; opl="or"; ->binop sw(MULT): op="*"; opl="mul"; ->binop sw(INTDIV): op=" / "; opl="idiv"; ->binop sw(REALDIV): op=" / "; opl="div"; ->binop sw(ANDL): op="&"; opl="and"; ->binop sw(RSHIFT): op=">>"; opl="rsh"; %if doinglabel=0 %then %start %if trip_opnd1_ptype&x'ff'=x'61' %then %start outstring("(UINT64)") %else outstring("(unsigned)") %finish %finish; ->binop sw(LSHIFT): op="<<"; opl="lsh"; ->binop sw(iexp): outstring("(int)") sw(REXP): outstring("pow(") outopnd(trip_opnd1,mode&x'ff00') outstring(",") outopnd(trip_opnd2,mode&x'ff00') outstring(")") ->wayout sw(RSTORE): ! printstring("Rstore:") %if ADD<=trip_x1<=SUB %and 0<=trip_opnd2_flag<=1 %andc trip_opnd2_d=1 %and trip_opnd1_ptype&x'ff00'=0{not pointer}%start outopnd(trip_opnd1,mode&x'ff00') %if trip_x1=ADD %then outstring("++") %else outstring("--") ->wayout %finish op=rsassop(trip_x1); ->assop sw(VASS):sw(VJASS): op="=" assop: outopnd(trip_opnd1,mode&x'ff00'!2) outstring(op) outopnd(trip_opnd2,mode&x'ff00'!0) ->wayout sw(NOTL): op="~"; opl="not" unaryop: %if doinglabel#0 %then outstring(opl) %else outstring(op) outopnd(trip_opnd1,mode&x'ff00'!trip_opnd1_flag>>3&1) ->wayout sw(LNEG): op="-"; opl="uminus"; ->unaryop sw(IFLOAT): %if trip_opnd1_flag=SCONST %start trip_opnd1_ptype=x'62' %begin %longreal x; x=trip_opnd1_d trip_opnd1_d=integer(addr(x)) trip_opnd1_xtra=integer(addr(x)+4) %end op="" ->unaryop %finish op="(double)"; ->unaryop sw(SHRTN):sw(LNGTHN):sw(JAMSHRTN):sw(NULLT):sw(PRELOAD): outopnd(trip_opnd1,mode&x'ff00'!0) %end {outtriple } %routine CSEXP(%integer MODE) !*********************************************************************** !* COMPILE A SIGNED EXPRESSION TO REGISTER 'REG' IN MODE 'MODE' * !* MODE=1 FOR %integer, =2 REAL, =3 LONG,=0 INTEGER %if POSSIBLE * !* MODE=5 FOR ADDRESS EXPRESSNS(IE LEAVE ANY CONSTANT IN 'ADISP')* !*********************************************************************** %integer EXPHEAD,NOPS,EXPBOT,form EXPHEAD = 0; EXPBOT = 0 NOPS = 0; Form=0 P = P+3 %if a(p)=4 %and a(P+1)=3 %then Form=1 { Bracketed expr } TORP(EXPHEAD,EXPBOT,NOPS,0) EXPOP(EXPHEAD,EXPBOT,NOPS,MODE&x'ffff') ! tripopt(triples,triples(0)_flink) outopnd(expopnd,Form! mode>>16) %end %routine labexp !*********************************************************************** !* Evaluates the expression in a switch label to a valid cname * !* This means operators have to be replaced by lettere * !*********************************************************************** doinglabel=1 csexp(x'51') doinglabel=0 %end %integer %fn CONSTEXP(%integer PRECTYPE) !*********************************************************************** !* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT OF * !* TYPE 'PRECTYPE'. P AS FOR FN INTEXP. * !*********************************************************************** %integer EXPHEAD,EXPBOT,NOPS,RES EXPHEAD = 0; EXPBOT = 0; NOPS = 0; RES = 0 TORP(EXPHEAD,EXPBOT,NOPS,1) ! ->WAYOUT %unless NOPS&X'00040000'=0 EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE) ->WAYOUT %unless EXPOPND_FLAG<=1 RES = ADDR(EXPOPND_D) WAYOUT: %result = RES %end %integer %fn INTEXP(%integer %name VALUE, %integer PRECTYPE) !*********************************************************************** !* COMPILES AN EXPRESSION WHICH SHOULD EVALUATE TO A CONSTANT * !* VALUE RETURNED IN VALUE. RESULT#0 IF FAILED TO EVALUATE * !* IN THIS CASE RESULT IS IN ETOS. USED FOR BOUND CALCULATIONS * !* P POINTS TO P(+') IN (+')(OPERNAD)(RESTOFEXPR) * !*********************************************************************** %integer EXPHEAD,EXPBOT,NOPS,CODE,SPTYPE,SACC EXPHEAD = 0; EXPBOT = 0; NOPS = 0; CODE = 0 SPTYPE = PTYPE; SACC = ACC; ! CALLED IN DECLARATIONS TORP(EXPHEAD,EXPBOT,NOPS,1) EXPOP(EXPHEAD,EXPBOT,NOPS,X'200'+PRECTYPE) CODE = 1 %unless EXPOPND_FLAG<=1 %and EXPOPND_PTYPE&x'77'=PRECTYPE VALUE = EXPOPND_D ACC = SACC; PTYPE = SPTYPE UNPACK %result = CODE %end %routine TORP(%integer %name HEAD,BOT,NOPS,%integer mode) !*********************************************************************** !* CONVERT THE SIGNED EXPRESSION INDEXED BY P INTO REVERSE * !* POLISH NOTATION. THE REVERSE POLISH LIST IS ADDED TO 'HEAD' * !* WHICH MAY CONTAIN ANOTHER EXPRESSION. THE NUMBER OF OPERATORS * !* IS ADDED TO NOPS. * !* N.B. AN INTEGER EXPRESSION IS A SPECIAL CASE OF A REAL EXPRSN * !* THE TOP 20 BITS OF NOPS ARE USED TO RETURN DETAILS OF THE EXPR * !* THESE BITS SIGNIFY AS FOLLOWS:- * !* 1<<17 CONTAINS VARIABLE OF MORE THAN 32 BITS * !* 1<<18 NOT CONSTANT EXPRSSN IE CONTAINS AT LEAST 1 VARIABLE * !* 1<<19 COMPLEX IE CONTAINS FN CALL OR NEEDS DR TO EVALUATE * !* mode # 0 if const expressions to be evaluated * !*********************************************************************** %switch OPERAND(1:3) %const %byte %integer %array PRECEDENCE(0:20)=0,3,3,4,5,5,4,3,3,4,4,5,5,3,5,5, 0(3),3,5 %const %byte %integer %array OPVAL(0:20)=0,ADD,SUB,ANDL,IEXP,REXP,MULT,NONEQ, ORL,INTDIV,REALDIV,RSHIFT,LSHIFT,ADD,IEXP,REXP,0(3),LNEG,NOTL %integer RPHEAD,PASSHEAD,SAVEHEAD,REAL,REALOP,OPERATOR,OPPREC, OPND,C,D,E,BDISP,OPNAME,OPMASK,RPBOT,OPSTK,OPPSTK,PASSBOT,PIN %record (TAGF) %name LCELL %record (RD) RPOP ! PASSHEAD = 0; RPHEAD = 0; SAVEHEAD = 0 REAL = 0; REALOP = 0; BDISP = 0 RPBOT = 0; OPSTK = 0; OPPSTK = 0 PIN=p ! C = A(P) %if 2<=C<=3 %then %start; ! INITIAL '-' OR '\' NOPS = NOPS+1 ! '-' =(11,3) '\' =(10,5) OPSTK = C+17 OPPSTK = PRECEDENCE(OPSTK) OPMASK = 1<<(19+C); ! - %or !! %finish %else OPMASK = 0 NEXTOPND: OPND = A(P+1); P = P+2 RPOP = 0 ->OPERAND(OPND); ! SWITCH ON OPERAND OPERAND(1): ! NAME OPNAME = A(P)<<8+A(P+1) LCELL == ASLIST(TAGS(OPNAME)) LCELL_UIOJ <- LCELL_UIOJ!X'8000'; ! SET USED BIT PTYPE = LCELL_PTYPE TYPE = PTYPE&7; PREC = PTYPE>>4&15 %if PTYPE=X'FFFF' %then PTYPE = X'51'; ! NAME NOT SET %if PTYPE=SNPT %then PTYPE = LCELL_ACC %and UNPACK %if (mode#0 %or string(addr(worka_lett(word(opname))))="pi") %c %and PTYPE&X'FF00'=X'4000' %and A(P+2)=2=A(P+3) %and 1<=TYPE<=2 %then %start ! CONST VAR RPOP_D = LCELL_S2; RPOP_XTRA = LCELL_S3 RPOP_FLAG = 1; PTYPE = PTYPE&255 %if TYPE=1 %and PREC<=5 %and X'FFFF8000'SKNAM %finish RPOP_XTRA = OPNAME RPOP_FLAG = ARNAME; RPOP_D = P; PTYPE = X'51' %if PTYPE=X'57' %if TYPE=3 %then %start D = P; KFORM = LCELL_KFORM C = COPY RECORD TAG(E); P = D; %finish %if TYPE=5 %then FAULT(76,0,OPNAME) %and RPOP_FLAG = 0 %and %c PTYPE = X'51' %if PREC>=6 %then OPMASK = OPMASK!1<<17; ! MORE THAN 32 BITS %if TYPE=2 %then REAL = 1 P = P+2 SKNAM: %if A(P)=2 %then P = P+1 %else SKIP APP %if A(P)=1 %then P = P+3 %and ->SKNAM P = P+2 INS: %if RPOP_FLAG=ARNAME %then OPMASK = OPMASK!1<<18 %if PTYPE>>4&15>5 %then OPMASK = OPMASK!1<<17; ! CONTINS LONG %if 3<=PTYPE&7<=7 %then PTYPE = X'51'; ! NOT SET TO INTEGER RPOP_PTYPE <- PTYPE BINSERT(RPHEAD,RPBOT,RPOP_S1,RPOP_D,RPOP_XTRA) ->OP OPERAND(2): ! CONSTANT PTYPE = A(P); D = PTYPE>>4 C = PTYPE&7 %if (PTYPE=x'61' %and 1<=6 %then OPMASK = OPMASK!1<<17; ! MORE THAN 32 BIT OPERAND %if D=4 %or d=3 %then %start d=4; RPOP_D = FROM AR2(P+1) ! PTYPE = ptype&8!X'51' %finish %else RPOP_D = FROM AR4(P+1) REAL = 1 %if C=2; RPOP_FLAG = 1 %if D=6 %then RPOP_XTRA = FROM AR4(P+5) %if C=5 %then %start; ! STRING CONSTANT FAULT(77,0,0); RPOP_D = 1; RPOP_FLAG = 0 P = P+A(P+1)+3; PTYPE = X'51' %finish %else %start %if D=7 %then RPOP_XTRA = RPOP_D %and RPOP_D = P+1 %if PTYPE=X'51' %and X'FFFF8000'<=RPOP_D<=X'7FFF' %then %c RPOP_FLAG = 0 %and PTYPE = MINAPT P = P+2+BYTES(D) %finish; ->INS OPERAND(3): ! SUB EXPRESSION PASSHEAD = 0; PASSBOT = 0 P = P+3 TORP(PASSHEAD,PASSBOT,NOPS,mode) REAL = 1 %if TYPE=2 ! CONCAT(RPHEAD,PASSHEAD) %if RPBOT=0 %then RPHEAD = PASSHEAD %else %c ASLIST(RPBOT)_LINK = PASSHEAD RPBOT = PASSBOT P = P+1 OP: ! DEAL WITH OPERATOR RPOP = 0 ->EOE %if A(P-1)=2; ! EXPR FINISHED OPERATOR = A(P) ! ! THE STRING OPERATOR '.' CAUSES CHAOS IN AN ARITHMETIC EXPRSN ! SO FAULT IT AND CHANGE IT TO THE INNOCUOUS '+' ! %if OPERATOR=CONCOP %then FAULT(78,0,0) OPPREC = PRECEDENCE(OPERATOR) C = OPVAL(OPERATOR) %if C=REALDIV %or C=REXP %then REAL = 1 NOPS = NOPS+1 ! ! UNLOAD THE OPERATOR STACK OF ALL OPERATORS WHOSE PRECEDENCE IS ! NOT LOWER THAN THE CURRENT OPERATOR. AN EMPTY STACK GIVES'-1' ! AS PRECEDENCE. ! %while OPPREC<=OPPSTK&31 %cycle RPOP_FLAG = OPVAL(OPSTK&31) BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0) OPSTK = OPSTK>>5; OPPSTK = OPPSTK>>5 %repeat ! ! THE CURRENT OPERATOR CAN NOW BE STORED ! OPSTK = OPSTK<<5!OPERATOR OPPSTK = OPPSTK<<5!OPPREC ->NEXTOPND EOE: ! END OF EXPRESSION ! EMPTY REMAINING OPERATORS %while OPSTK#0 %cycle RPOP_FLAG = OPVAL(OPSTK&31) BINSERT(RPHEAD,RPBOT,RPOP_S1,0,0) OPSTK = OPSTK>>5 %repeat PTYPE = REAL+1 TYPE = PTYPE ! CONCAT(RPHEAD,HEAD) %if HEAD=0 %then BOT = RPBOT %else ASLIST(RPBOT)_LINK = HEAD HEAD = RPHEAD; ! HEAD BACK TO TOP OF LIST NOPS = NOPS!OPMASK %end %routine EXPOP(%integer %name HEAD,BOT, %integer NOPS,MODE) !*********************************************************************** !* EVALUATE A LIST OF OPERAND AND'NOPS' OPERATORS AND LEAVE * !* THE RESULT IN REG * !* INHEAD HOLDS THE LIST THE BOTTOM BYTE OF STREAM 1 DEFINES THE * !* ENTRY AS FOLLOWS:- * !* 0 = SHORT (INTEGER) CONSTANT <18 BITS --S2=CONSTANT * !* 1 = OTHER CONSTANT S2 (+S3 IF NEEDED) = CONSTANT * !* 2 = VARIABLE S2 POINT TO AR ENTRY FOR NAME&SUBSCRIPTS * !* (3 = DOPE VECTOR ITEM IF NEEDED) * !* (4 = CONDITONAL EXPRESSION AS IN ALGOL) * !* 7 = INTERMEDIATE RESULT UNDER LNB S2=DISPLCMNT FROM LNB * !* 8 = INTERMEDIATE RESULT STACKED * !* 9 = INTERMEDIATE RESULT IN A REGISTER S2 = REG * !* * !* 10-19 = UNARY OPERATOR S2=OP S3 =EXTRA * !* 20 UP = BINARY OPERATOR * !* * !* MODE HAS TYPE & PREC REQD +256 BIT IF NO RESULT REQD * !*********************************************************************** %routine %spec PSEVAL ! %integer %array OPERAND(0:2),STK(0:99) %record (LISTF) %name LIST %record (RD) %name OPND1,OPND2,OPND %record (TRIPF) %name CURRT ! %integer C,D,KK,JJ,COMM,XTRA,INHEAD,CURR TRIP,STPTR,CONSTFORM, CONDFORM,SAVEP,INITTRIP ! ! CORULES GIVE INFORMATION ON OPERATORS. ! BTM 4 BITS HAVE TYPE CONVERSION RULES(SEE COERCET) ! NEXT 4 BITS HAVE PREC RULES (SEE COERCEP) ! 2**8 SET IF COMMUTATIVE ! %const %half %integer %array CORULES(0:20)= %c X'1FF'{+},X'FF'{-}, X'1F1'{!!},X'1F1'{!}, X'1FF'{*},X'F1'{//}, X'F2'{/},X'1F1'{&},X'71'{>>}, X'71'{<<},X'43'{**}, X'1FF'{COMP},X'FF'{DCOMP}, X'21'{VMY},X'1F1'{COMB}, X'14'{ASSIGN=}, X'54'{ASSIGN<-},X'71'{****}, X'01'{ARR BADJ}, X'001'{ARR INDEX}, X'100'{INDEXED FETCH} %const %integer %array PTYPECH(0:19)=0(12),X'11',0,-X'10',X'10',-X'10',0(3) ! STPTR = 0; CONSTFORM = MODE&512 INITTRIP = NEXTTRIP CONDFORM = MODE&256 SAVEP = P INHEAD = HEAD PSEVAL NEXT: LIST == ASLIST(INHEAD) XTRA = LIST_S2 JJ = LIST_FLAG; D = INHEAD INHEAD = LIST_LINK ->OPERATOR %if JJ>=10 ! ! ANY OPERAND WHICH MAY NEED DR OR B OR ACC IN THEIR EVALUATION ! EG FUNCTIONS,ARRAY ELEMENTS ETC ARE FETCHED AND STACKKED FIRST ! OPND1 == ASLIST(D) STK(STPTR) = D STPTR = STPTR+1 IMPABORT %if STPTR>99 ANYMORE: ->NEXT %unless INHEAD=0 OPND1 == ASLIST(STK(STPTR-1)) EXPOPND = OPND1 ->FINISH OPERATOR: %if JJ<128 %then KK = 1 %else KK = 2; ! UNARY OR BINARY %cycle KK = KK,-1,1 STPTR = STPTR-1 OPERAND(KK) = STK(STPTR) %repeat COMM = 1 OPND1 == ASLIST(OPERAND(1)) %if JJ>=128 %then %start OPND2 == ASLIST(OPERAND(2)) %finish %else OPND2 == RECORD(0) ! next line must be wrong 32 is not dsided ! %if JJ=32 %then COMM = 2; ! DSIDED RESULT=2ND OPERAND ! ALL OTHERS RESULT=1ST OPERAND %if JJ<128 %then C = 0 %else C = CORULES(JJ-128) %if JJ=VASS %or JJ=VJASS %then KK = 1 %else KK = 2 ! CNAME FETCH-STORE ! %if OPND1_FLAG=ARNAME %and (LHSADDRFIRST=YES %or KK=2) %start ! ! EXPAND UP NAMES BUT NOT LHS ! ! ASSIGNMENT NAMES ! P = OPND1_D; CNAME(KK) ! OPND1 = NAMEOPND ! %finish ! %if JJ>=128 %and OPND2_FLAG=ARNAME %then %start ! P = OPND2_D ! CNAME(2) ! OPND2 = NAMEOPND ! %finish ! %if OPND1_FLAG=ARNAME %then %start ! P = OPND1_D ! CNAME(KK) ! OPND1 = NAMEOPND ! %finish %if constform#0 %and OPND1_FLAG<2 %and (JJ<128 %or OPND2_FLAG<2) %then %c CTOP(JJ,MASK,XTRA,OPND1,OPND2) %if JJ#0 %then %start; ! CODE REQUIRED OP TRIPLE CURR TRIP = NEW TRIP CURRT == TRIPLES(CURR TRIP) CURRT_DPTH = 0; ! LEAVE DEPTHS TO BE WORKED OUT IN%c OPT PASS CURRT_CNT = 0 CURRT_FLAGS = 1!(C>>1&128) CURRT_OPERN = JJ CURRT_OPTYPE <- OPND1_PTYPE %if 12<=JJ<=16 %start; ! UNARY(TYPECHANGE)OPN CURRT_OPTYPE <- XTRA; XTRA = 0 %finish %else %if %c OPND1_PTYPE&7=1 %and OPND1_PTYPE&255>20=1 %then %c CURRT_FLAGS <- CURRT_FLAGS!DONT OPT CURRT_X1 = XTRA CURRT_OPND1 = OPND1 %if 1<=128 %then %start CURRT_OPND2 = OPND2 %if 1<ANYMORE FINISH: ! %if EXPOPND_FLAG=ARNAME %then %start ! P = EXPOPND_D ! CNAME(2) ! EXPOPND = NAMEOPND ! %finish PTYPE = EXPOPND_PTYPE TYPE = PTYPE&7; PREC = PTYPE>>4 P = SAVEP ASLIST(BOT)_LINK = ASL ASL = HEAD HEAD = 0; BOT = 0 %return %routine PSEVAL !*********************************************************************** !* PERFORMS A PSEUDO EVALUATION ON THE EXPRESSION TO DETERMINE * !* THE POSITION OF ANY TYPE CHANGES AND THEN INSERTS * !* THESE UNARY OPERATIONS * !*********************************************************************** %routine %spec AMEND(%record (RD) %name OPND, %integer OP) %routine %spec COERCET(%integer RULES) %routine %spec COERCEP(%integer RULES) %integer TMPHEAD,INHEAD,C,JJ,NEXT %record (RD) %name OPND1 %record (RD) OPND2,RPOP %record (LISTF) %name CELL PRINT LIST(HEAD) %and IMPABORT %unless ASLIST(BOT)_LINK=0 RPOP = 0 TMPHEAD = 0 INHEAD = HEAD ! %while INHEAD#0 %cycle CELL == ASLIST(INHEAD) NEXT = CELL_LINK RPOP <- CELL; ! COPY BEFOR ADJUSTING PTYPE JJ = RPOP_FLAG; ! FLAG %if JJ<10 %start; ! AN OPERAND ! %if RPOP_PTYPE>>4&15=128 %start; ! BINARY OPERATOR POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA) OPND1 == ASLIST(TMPHEAD); ! MAPPING SAVES POP&PUSH C = CORULES(JJ-128) %if JJ=REXP %and OPND2_PTYPE&7=2 %then C = X'F2' ! REAL TO THE REAL %if C&15#0 %then COERCET(C&15) %if C>>4&15#0 %then COERCEP(C>>4&15) %else OPND1 == ASLIST(TMPHEAD) %if JJ=MODULUS %start %if OPND1_PTYPE&7=1 %and RPOP_D&7=2 %then COERCET(3) %if OPND1_PTYPE>>4&15>4&15 %then %c AMEND(OPND1,LNGTHN) %if OPND1_PTYPE>>4&15>RPOP_D>>4&15 %then %c AMEND(OPND1,SHRTN) %else %if jj<19 %then opnd1_ptype=opnd1_ptype+ptypech(jj) %finish %finish OPND1_XTRA = INHEAD; ! IN CASE(FURTHER)TYPE CHANGE %finish INHEAD = NEXT %repeat ! ! FINAL COERCION ON RESULT ! POP(TMPHEAD,OPND2_S1,OPND2_D,OPND2_XTRA) PRINT LIST(HEAD) %and IMPABORT %unless TMPHEAD=0 %if CONDFORM=0 %start %if MODE&7=1 %and OPND2_PTYPE&7=2 %then FAULT(25,0,0) %if OPND2_PTYPE&7=1 %and MODE&7=2 %then AMEND(OPND2,IFLOAT) C = MODE>>4&15; ! TARGET PREC AMEND(OPND2,SHRTN) %while C>4&15 AMEND(OPND2,LNGTHN) %while C>OPND2_PTYPE>>4&15 %finish PRINTLIST(HEAD) %if PARM_DCOMP#0 %and PARM_Z#0 BOT = ASLIST(BOT)_LINK %while ASLIST(BOT)_LINK#0 %return %routine AMEND(%record (RD) %name OPND, %integer OP) !*********************************************************************** !* ADDS IN AN OPERATION TO CHANGE THE TYPE OR PREC OF OPND * !* On E machines we can not elide uneceesary changes * !*********************************************************************** %record (RD) RPOP %if 1<=32BITS, OPND2 TO BE 'STANDARD' * !* RULES=15 BOTH OPERANDS TO THE LARGEST PRECISION * !*********************************************************************** %integer PREC1,PREC2,TPREC,OPER %record (RD) %name OPND %record (RD) RPOP RPOP = 0 %if RULES=6 %then COERCEP(4) %and RULES = 2 PREC1 = OPND1_PTYPE>>4&15 PREC2 = OPND2_PTYPE>>4&15 %if RULES=5 %or RULES=1 %start; ! ASSIGN PREC1 = CELL_S2>>4&15; ! ORIGINAL PREC FOR ARRAY ASSIGN %if PREC2>PREC1 %start %cycle %if RULES=1 %then OPER = SHRTN %else OPER = JAMSHRTN AMEND(OPND2,OPER) PREC2 = PREC2-1 %repeat %until PREC1=PREC2 %return %finish %else RULES = 1; ! IN CASE LENGTHEN NEEDED %finish %if PREC1MINAPT %then AMEND(OPND,SHRTN) %return %finish %if PREC1>4&15%then%else * !* CTO=0 JUMP TO FARLAB MUST BE PLANTED IF COND UNCONDITIONAL * !* CTO#0 JUMP MAY BE OMITTED * !* IU=1 FOR %if =2 FOR UNLESS. FARLAB TO GO ON UI2 * !* THE ROUTINE MAKES FOUR PASSES THROUGH THE CONDITION * !* PASS 1 ANALYSES THE STRUCTURE AND DECIDES TO BRANCH ON TRUE * !* (TF=2) OR ON FALSE (TF=1) FOR EACH COMPARISON * !* PASS 2 WORKS OUT WHERE THE BRANCHES OF PASS 1 SHOULD GO TO * !* PASS 3 ASSIGNS LABEL NUMBERS * !* PASS 4 EVALUATES COMPARISIONS AND PLANTS THE CODE * !* * !* ON ENTRY P POINTS TO IN * !* RESULT=0 CONDITION COMPILED * !* RESULT=1 UNCONDITIONALLY TO 1ST ALTERNATIVE * !* RESULT=2 UNCONDITIONALLY TO 2ND ALTERNATIVE(FARLAB) * !*********************************************************************** !%routinespec WRITE CONDLIST %routine %spec SKIP SC(%integer REVERSED) %routine %spec SKIP COND(%integer REVERSED) %integer %fn %spec CCOMP %routine %spec JUMP(%integer MASK,LAB,FLAGS) %routine %spec NOTE JUMP(%integer LAB) %routine %spec LAB UNUSED(%integer LAB) %routine %spec OMIT TO(%integer LAB) ! ! FCOMP HAS BC MASKS FOR EACH STRING COMPARATOR. ! THE FIRST 7 ARE TO BRANCH IF TRUE WITH NORMAL COMPARISON ! THE SECOND SEVEN ARE TO BRANCH IF TRUE WITH BACKWARDS COMPARISON ! ! %integer PIN,PP,II,L,CPTR,CMAX,LL,BITMASK,LLA %record %format CF(%byte %integer TF,CMP1,CMP2,LABU,LVL,JMP,REV, JUMPED, %integer LABNO,SP1,SP2,sp3) %record (CF) %array CLIST(0:30) %record (CF) %name C1,C2 ! ! PASS 1. ANALYSES THE CONDITION ! PIN = P; ! SAVE INITIAL AR POINTER CPTR = 1; L = 3; ! LEVEL=3 TO ALLOW 2 LOWER C1 == CLIST(CPTR); ! SET UP RECORD FOR FIRST CMPARSN C1 = 0 {GT:} ! Would be nice to apply de-morgan's law below and invert the actual ! conditional tests, eg ! a=1 %and b>fred ! -> a#1 %or b<=fred ! ! Since Imp80 has no %predicates, we don't need to re-insert any "!"s ! at a lower level, except for conditional string resolution, i.e. ! a->a.("->").b ! -> (%not a->a.("->").b) ! ! If we add this as a general mechanism, then when translating to ! C we can clean up 'unless' and 'repeat until' statements, which map ! to C's if and while statements. ! ! Also it would be useful in my %if %then %monitor ! extension, which maps to assert(!()) ! ! NOTE: ** it would appear SKIP SC(1) and SKIP COND() ! do exactly what I want here! ! ! %if iu=2 %then outstring("(!") outsym('(') %if iu=2 %then %start SKIP SC(1); ! SKIP THE 1ST CMPARSN SKIP COND(1); ! AND ANY %and/%or CLAUSES %else SKIP SC(0); ! SKIP THE 1ST CMPARSN SKIP COND(0); ! AND ANY %and/%or CLAUSES %finish outstring(") ") ! %if iu=2 %then outsym(')') %result=0 %routine SKIP SC(%integer REVERSED) !*********************************************************************** !* REVERSED=1 FOR RECURSIVE CALL IN %not(SC) * !* SKIPS OVER A SIMPLE CONDITION. P ON ALT OF * !*********************************************************************** ! ! In Imp to C translator we do NOT generate jumps so the logic ! for REVERSED which changes the jump destinations does not ! do anything. Instead we must explicity apply de-morgan's ! law to the operands and operators. I am in the process ! of adding that code now. SKIP COND is done already %conststring(5) %array CMP(0:10)=" ??? ","==",">=",">", "!=","<=","<","!=","?->??", "==","!=" %conststring(6) %array REVCMP(0:10)=" ??? ","!=","<","<=", "==",">",">=","==","!?->??", "!=","==" %switch SCALT(1:4) %integer ALT,TE1,TE2,PRECP,TYPEp,finalp,rexp ALT = A(P); P = P+1 ->SCALT(ALT) SCALT(1): ! C1_SP1 = P te1=tsexp(TE2) typep=type; precp=prec p = c1_sp1 { tsexp may not reset p } SKIP EXP C1_CMP1 = A(P) C1_REV = 3*REVERSED P = P+1; C1_SP2 = P SKIP EXP %if A(P)=2 %then P = P+1 %else %start C1_CMP2 = A(P+1); ! DEAL WITH 2ND HALF OF D-SIDED P = P+2; C1_SP3=P; SKIP EXP %finish finalp=p ! outsym('(') %unless a(finalp)=3 %if typep=5 %start p=c1_sp1 %if c1_cmp1=8 %start outstring("imp_resolve(") p=p+5; cname(2) outsym(',') p=c1_sp2; cres(1) %if REVERSED=1 %then %start outstring(")!=0"); ! De-Morgan's law %else outstring(")==0") %finish %if c1_cmp2#0 %then outstring("untranslateable cond") %else %if c1_cmp2#0 %then outsym('(') outstring("strcmp(") cstrexp(0) outsym(',') p=c1_sp2; cstrexp(0) outsym(')') %if REVERSED=1 %then %start outstring(REVcmp(c1_cmp1)); ! de-morgan's law %else outstring(cmp(c1_cmp1)) %finish outsym('0') %if c1_cmp2#0 %then %start %if REVERSED=1 %then %start outstring(") || ("); ! De-Morgan's Law %else outstring(") && (") %finish p=c1_sp2; cstrexp(0) outsym(',') p=c1_sp3 cstrexp(0) outsym(')') %finish %finish %else %if c1_cmp2#0 %then outsym('(') p=c1_sp1 REXP = 2-A(P+1+FROM AR2(P+1)) %if rexp#0 %then outsym('(') %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256) %if rexp#0 %then outsym(')') %if REVERSED=1 %then %start outstring(REVcmp(c1_cmp1)); ! DeMorgan's law %else outstring(cmp(c1_cmp1)) %finish p=c1_sp2 REXP = 2-A(P+1+FROM AR2(P+1)) %if rexp#0 %then outsym('(') %if c1_cmp1>8 %then p=p+5 %and cname(4) %else csexp(precp<<4!typep!256) %if rexp#0 %then outsym(')') %if c1_cmp2#0 %start %if REVERSED=1 %then %start outstring(") || (") %else outstring(") && (") %finish %if rexp#0 %then outsym('(') p=c1_sp2; csexp(precp<<4!typep) %if rexp#0 %then outsym(')') %if REVERSED=1 %then %start outstring(REVcmp(c1_cmp1)); ! DeMorgan's law %else outstring(cmp(c1_cmp2)) %finish p=c1_sp3 REXP = 2-A(P+1+FROM AR2(P+1)) %if rexp#0 %then outsym('(') csexp(precp<<4!typep) %if rexp#0 %then outsym(')') outsym(')') %finish %finish p=finalp ! outsym(')') %unless a(finalp)=3 %return SCALT(2): ! '('')' outsym('(') L = L+1 SKIP SC(REVERSED) SKIP COND(REVERSED) L = L-1 outsym(')') %return SCALT(3): ! %not(SC) {GT:}!outstring("!(") ! now that SKIP SC and SKIP COND reverse properly, ! we do not need to negate here as well... SKIP SC(REVERSED!!1) !outsym(')') %return SCALT(4): %if REVERSED=1 %then outstring("/* what is a pseudo-boolean? - is the conditio accidentally inverted? */"); csexp(x'51'); ! single pseudo boolean expr %end; ! OF ROUTINE SKIP SC %routine SKIP COND(%integer REVERSED) !*********************************************************************** !* SKIPS OVER * !*********************************************************************** %integer ALT,ALTP ALT = A(P); ! 1=%and,2=%or,3=NULL P = P+1 %if ALT\=3 %then %start; ! NULL ALTERNATIVE NOTHING TO DO %until ALTP=2 %cycle; ! UNTIL NO MORE S C1_LVL = L; C1_TF = ALT C1_TF = C1_TF!!(3*REVERSED) {GT: experimenting with reversing} %if REVERSED=1 %then %start ! Apply de-morgan to operators %if alt=1 %then outstring(" || ") %else outstring(" && ") %else %if alt=1 %then outstring(" && ") %else outstring(" || ") %finish CPTR = CPTR+1 C1 == CLIST(CPTR); C1 = 0 SKIP SC(REVERSED) ALTP = A(P); P = P+1 %repeat %finish %end !%routine WRITE CONDLIST !%conststring(5) %array CM(0:10)=" "," ="," >="," >", ! " #"," <="," <"," \="," ->", ! " =="," \==" ! PRINTSTRING(" ! NO TF C1 C2 LABU LVL JMP REV LABNO JUMPED !") ! %cycle CPTR=1,1,CMAX ! C1==CLIST(CPTR) ! WRITE(CPTR,2) ! WRITE(C1_TF,4) ! PRINTSTRING(CM(C1_CMP1)) ! PRINTSTRING(CM(C1_CMP2)) ! WRITE(C1_LABU,6) ! WRITE(C1_LVL,5) ! WRITE(C1_JMP,4) ! WRITE(C1_REV,4) ! WRITE(C1_LABNO,7) ! WRITE(C1_JUMPED,6) ! NEWLINE ! %repeat !%end %end; ! OF CCOND %integer %fn REVERSE(%integer MASK) !*********************************************************************** !* REVERSE THE MASK FOR A JCC(MASK<=15),JAT(>15) OR JAF(>31) * !*********************************************************************** %if MASK=0 %or MASK=15 %then %result = MASK!!15 %result = MASK!!X'8F' %end %integer %fn ENTER LAB(%integer LAB,FLAGS) %result=0 %end %routine ENTER JUMP(%integer TFMASK,LAB,FLAGS) %end %routine REMOVE LAB(%integer LAB) %end %integer %fn CREATE AH(%integer MODE, %record (RD) %name EOPND,NOPND) !*********************************************************************** !* CREATES AN ARRAYHEAD IN THE ESTACK BY MODIFYING THE * !* HEAD ALREADY THERE AS FOLLOWS:- * !* MODE=0 (ARRAYMAPPING) ETOS-4&5 HAS 32BIT ADDR OF FIRST ELEMNT* !* MODE=1 (ARRAYS IN RECORDS)ETOS-4&5 HAS 32BIT RELOCATION FACTOR* !*********************************************************************** %integer JJ JJ = BRECTRIP(AHADJ,AHEADPT,0,EOPND,NOPND) TRIPLES(JJ)_X1 = PTYPE<<4!MODE %result = JJ %end; ! OF ROUTINE CREATE AH %routine CSNAME(%integer Z) !*********************************************************************** !* COMPILE A SPECIAL NAME - PTYPE=10006 (=%routine %label) * !* THEIR TRUE PTYPE IS IN GLOBAL ARRAY TAGS_S2. * !* SNINFO HAS A FOUR BYTE RECORD FOR EACH NAME (%bi FLAG,PTR, * !* %si XTRA). THE TOP BITS OF FLAG CATEGORISE AS FOLLOWS:- * !* 2**7 SET FOR IMPLICITLY SPECIFIED CONSTRUCT A %spec * !* 2**6 SET FOR IOCP CALL * !* 2**5 SET FOR BUILT IN MAPPING FUNCTIONS * !* 2**4 SET IF AD-HOC CODE PLANTED BY THIS ROUTINE * !* 2**3 SET IF FIRST PARAMETER IS OF %name TYPE * !* 2**2-2**0 HOLD NUMBER OF PARAMS * !* * !* THE FULL SPECS ARE AS FOLLOWS:- * !* 0=%routine SELECT INPUT(%integer STREAM) * !* 1=%routine SELECT OUTPUT(%integer STREAM) * !* 2=%routine NEWLINE * !* 3=%routine SPACE * !* 4=%routine SKIP SYMBOL * !* 5=%routine READ STRING(%stringname S) * !* 6=%routine NEWLINES(%integer N) * !* 7=%routine SPACES(%integer N) * !* 8=%integerfn NEXT SYMBOL * !* 9=%routine PRINT SYMBOL(%integer SYMBOL) * !* 10=%routine READ SYMBOL(%name SYMBOL) * !* 11=%routine READ(%name NUMBER) * !* 12=%routine WRITE(%integer VALUE,PLACES) * !* 13=%routine NEWPAGE * !* 14=%integerfn ADDR(%name VARIABLE) * !* 15=%longrealfn ARCSIN(%longreal X) * !* 16=%integerfn INT(%longreal X) * !* 17=%integerfn INTPT(%lonrgreal X) * !* 18=%longrealfn FRACPT(%longreal X) * !* 19=%routine PRINT(%longreal NUMBER,%integer BEFORE,AFTER) * !* 20=%routine PRINTFL(%longreal NUMBER,%integer PLACES) * !* 21=%realmap REAL(%integer VAR ADDR) * !* 22=%integermap INTEGER(%integer VAR ADDR) * !* 23=%longrealfn MOD(%longreal X) * !* 24=%longrealfn ARCCOS(%longreal X) * !* 25=%longrealfn SQRT(%longreal X) * !* 26=%longrealfn LOG(%longreal X) * !* 27=%longrealfn SIN(%longreal X) * !* 28=%longrealfn COS(%longreal X) * !* 29=%longrealfn TAN(%longreal X) * !* 30=%longrealfn EXP(%longreal X) * !* 31=%routine CLOSE STREAM(%integer STREAM) * !* 32=%byteintegermap BYTE INTEGER(%integer VAR ADDR) * !* 33=%integerfn EVENTINF * !* 34=%longrealfn RADIUS(%longreal X,Y) * !* 35=%longrealfn ARCTAN(%longreal X,Y) * !* 36=%byteintegermap LENGTH(%stringname S) * !* 37=%routine PRINT STRING(%string(255) MESSAGE) * !* 38=%integerfn NL * !* 39=%longrealmap LONG REAL(%integer VAR ADDR) * !* 40=%routine PRINT CH(%integer CHARACTER) * !* 41=%routine READ CH(%name CHARACTER) * !* 42=%stringmap STRING(%integer VAR ADDR) * !* 43=%routine READ ITEM(%stringname ITEM) * !* 44=%string(1)%fn NEXT ITEM * !* 45=%byteintegermap CHARNO(%stringname STR,%integer CHARREQD) * !* 46=%string(1)%fn TOSTRING(%integer SYMBOL) * !* 47=%string(255)%fn SUBSTRING(%stringname S,%integer BEG,END) * !* 48=%recordmap RECORD(%integer REC ADDR) * !* 49=%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT) * !* 50=%integerfn SIZEOF(%name X) * !* 51=%integerfn IMOD(%integer VALUE) * !* 52=%longrealfn PI * !* 53=%integerfn EVENTLINE * !* 54=%longintegermap LONGINTEGER(%integer ADR) * !* 55=%longlongrealmap LONGLONGREAL(%integer ADR) * !* 56=%longintgerefn LENGTHENI(%integer VAL) * !* 57=%longlongrealfn LENGTHENR(%longreal VAL) * !* 58=%integerfn SHORTENI(%longinteger VAL) * !* 59=%longrealfn SHORTENR(%longlongreal VAL) * !* 60=%integerfn NEXTCH * !* 61=%halfintegermap HALFINTEGER(%integer ADDR) * !* 62=%routine PPROFILE * !* 63=%longrealfn FLOAT(%integer VALUE) * !* 64=%longintegerfn LINT(%longlongreal X) * !* 65=%longintegerfn LINTPT(%longlongreal X) * !* 66=%shortintegermap SHORTINTEGER(%integer N) * !* 67=%integerfn TRUNC(%longreal X) * !*********************************************************************** %integer %fn %spec OPTMAP %switch ADHOC(0:67) %const %string(80) %array SMDETAILS(0:NO OF SNS) = %c /* 0 */ "%routine SELECT INPUT(%integer STREAM)", /* 1 */ "%routine SELECT OUTPUT(%integer STREAM)", /* 2 */ "%routine NEWLINE", /* 3= */ "%routine SPACE", /* 4= */ "%routine SKIP SYMBOL", /* 5= */ "%routine READ STRING(%stringname S)", /* 6 */ "%routine NEWLINES(%integer N)", /* 7 */ "%routine SPACES(%integer N)", /* 8 */ "%integerfn NEXT SYMBOL", /* 9= */ "%routine PRINT SYMBOL(%integer SYMBOL)", /* 10 */ "%routine READ SYMBOL(%name SYMBOL)", /* 11 */ "%routine READ(%name NUMBER)", /* 12 */ "%routine WRITE(%integer VALUE,PLACES)", /* 13 */ "%routine NEWPAGE", /* 14= */ "%integerfn ADDR(%name VARIABLE)", /* 15 */ "%longrealfn ARCSIN(%longreal X)", /* 16 */ "%integerfn INT(%longreal X)", /* 17 */ "%integerfn INTPT(%lonrgreal X)", /* 18 */ "%longrealfn FRACPT(%longreal X)", /* 19 */ "%routine PRINT(%longreal NUMBER,%integer BEFORE,AFTER)", /* 20 */ "%routine PRINTFL(%longreal NUMBER,%integer PLACES)", /* 21 */ "%realmap REAL(%integer VAR ADDR)", /* 22 */ "%integermap INTEGER(%integer VAR ADDR)", /* 23 */ "%longrealfn MOD(%longreal X)", /* 24 */ "%longrealfn ARCCOS(%longreal X)", /* 25 */ "%longrealfn SQRT(%longreal X)", /* 26 */ "%longrealfn LOG(%longreal X)", /* 27 */ "%longrealfn SIN(%longreal X)", /* 28 */ "%longrealfn COS(%longreal X)", /* 29 */ "%longrealfn TAN(%longreal X)", /* 30 */ "%longrealfn EXP(%longreal X)", /* 31 */ "%routine CLOSE STREAM(%integer STREAM)", /* 32 */ "%byteintegermap BYTE INTEGER(%integer VAR ADDR)", /* 33 */ "%integerfn EVENTINF", /* 34= */ "%longrealfn RADIUS(%longreal X,Y)", /* 35 */ "%longrealfn ARCTAN(%longreal X,Y)", /* 36 */ "%byteintegermap LENGTH(%stringname S)", /* 37 */ "%routine PRINT STRING(%string(255)", /* 38 */ "%integerfn NL", /* 39= */ "%longrealmap LONG REAL(%integer VAR ADDR)", /* 40 */ "%routine PRINT CH(%integer CHARACTER)", /* 41 */ "%routine READ CH(%name CHARACTER)", /* 42 */ "%stringmap STRING(%integer VAR ADDR)", /* 43 */ "%routine READ ITEM(%stringname ITEM)", /* 44 */ "%string(1)", /* 45 */ "%byteintegermap CHARNO(%stringname STR,%integer CHARREQD)", /* 46 */ "%string(1)", /* 47 */ "%string(255)", /* 48 */ "%recordmap RECORD(%integer REC ADDR)", /* 49 */ "%arraymap ARRAY(%integer A1ADDR,%arrayname FORMAT)", /* 50 */ "%integerfn SIZEOF(%name X)", /* 51 */ "%integerfn IMOD(%integer VALUE)", /* 52 */ "%longrealfn PI", /* 53= */ "%integerfn EVENTLINE", /* 54= */ "%longintegermap LONGINTEGER(%integer ADR)", /* 55 */ "%longlongrealmap LONGLONGREAL(%integer ADR)", /* 56 */ "%longintgerefn LENGTHENI(%integer VAL)", /* 57 */ "%longlongrealfn LENGTHENR(%longreal VAL)", /* 58 */ "%integerfn SHORTENI(%longinteger VAL)", /* 59 */ "%longrealfn SHORTENR(%longlongreal VAL)", /* 60 */ "%integerfn NEXTCH", /* 61= */ "%halfintegermap HALFINTEGER(%integer ADDR)", /* 62 */ "%routine PPROFILE", /* 63= */ "%longrealfn FLOAT(%integer VALUE)", /* 64 */ "%longintegerfn LINT(%longlongreal X)", /* 65 */ "%longintegerfn LINTPT(%longlongreal X)", /* 66 */ "%shortintegermap SHORTINTEGER(%integer N)", /* 67 */ "%integerfn TRUNC(%longreal X)" %const %integer %array SNINFO(0:NO OF SNS)= %c X'41080001',X'41090001',X'408A0001',X'40A00001', X'40010001',X'800D0000',X'11010001',X'11010001', X'10020024',X'41030001',X'19030001',X'80130001', X'80170014',X'408C0001',X'19050024',X'80010002', X'11040024',X'11040024',X'80010005',X'80090006', X'80060007',X'2100003E',X'2100003E',X'11060024', X'80010008',X'80010009',X'8001000A',X'8001000B', X'8001000C',X'8001000D',X'8001000E',X'8015000F', X'2100003E',X'100D0024',X'80030010',X'80030011', X'1907003E',X'41070001',X'10080024',X'2100003E', X'41050001',X'19030001',X'2100003E',X'19030001', X'10020024',X'1A07003E',X'11090024',X'800F0012', X'110A0018',X'120B1000',X'80130013',X'11060024', X'100C0024',X'100D0024',X'2100003E'(2), X'110E0024'(4), X'10020024',X'2100003E',X'100F0001',X'11100024', X'11110024',X'11110024',X'2100003E',X'11040024' %const %string (13) %array SNXREFS(0:20)= %c "s#readstring", "s#read", "s#iarcsin", "s#int", "s#intpt" , "s#fracpt", "s#print" , "s#printfl", "s#iarccos","sqrt" , "log" , "sin", "cos" , "tan" , "exp" , "s#closestream", "s#iradius","atan2","imp_substring","s#sizeof", "s#write" ! ! SNPARAMS HOLDS NUMBER AND PTYPE OF FORMAL PARAMETER FOR IMPLICITLY ! SPECIFIED EXTERNAL ROUTINES. A POINTER IN SNINFO MEANS THAT NO ! DUPLICATES NEED TO BE RECORDED. ! %if PARAMS BWARDS=YES %then %start %const %integer %array SNPARAMS(0:25)=0{NO PARAMS}, 8<<16!1,LRLPT{%LONGREAL X}, 16<<16!2,8<<16!LRLPT,LRLPT{%LONGREAL X,Y}, 12<<16!2,12<<16!LRLPT,4<<16!X'51'{%LONGREAL X,%INTEGER I}, 16<<16!3,8<<16!LRLPT,4<<16!X'51',X'51'{%LONGREAL X,%INTEGER I,J}, 8<<16!1,X'435'{%STRINGNAME S}, 16<<16!3,8<<16!X'435',4<<16!X'51',X'51'{%STRINGNAME S,%INTEGER I,J}, 8<<16!1,X'400'{%NAME X}, 4<<16!1,X'51'{%INTEGER I}, 8<<16!2,4<<16!X'51',X'51'{%INTEGER I,J} %finish %else %start %const %integer %array SNPARAMS(0:25)=0{NO PARAMS}, 8<<16!1,LRLPT{%LONGREAL X}, 16<<16!2,LRLPT,8<<16!LRLPT{%LONGREAL X,Y}, 12<<16!2,LRLPT,8<<16!X'51'{%LONGREAL X,%INTEGER I}, 16<<16!3,LRLPT,8<<16!X'51',12<<16!X'51'{%LONGREAL X,%INTEGER I,J}, 8<<16!1,X'435'{%STRINGNAME S}, 16<<16!3,X'435',8<<16!X'51',12<<16!X'51'{%STRINGNAME S,%INTEGER I,J}, 8<<16!1,X'400'{%NAME X}, 4<<16!1,X'51'{%INTEGER I}, 8<<16!2,X'51',4<<16!X'51'{%INTEGER I,J} %finish ! %const %byte %integer %array WRONGZ(0:15)=27,29,23,29,29,23,82,109(5), 23,27,109(2) %routine %spec RTOS %integer %fn %spec CIOCP(%integer N, %record (RD) %name PARAM) %record (LISTF) %name LCELL %record (LISTF) PCELL %record (RD) OPND,OPERATOR %record (TRIPF) %name CURRT %string (31) SNXREF %integer ERRNO,FLAG,POINTER,PIN,SNNO,SNNAME,NAPS,SNPTYPE,JJ,XTRA, IOCPEP,B,D,SNINF,P0,OPHEAD,ERRVAL,EXPHEAD,EXPBOT,formatname,NOPS SNNAME = FROM AR2(P) SNNO = K; ! INDEX INTO SNINFO TESTAPP(NAPS); ! COUNT ACTUAL PARAMETERS PIN = P; P = P+2 SNPTYPE = ACC SNINF = SNINFO(SNNO) XTRA = SNINF&X'FFFF' POINTER = (SNINF>>16)&255 FLAG = SNINF>>24 %if snptype&255=x'61' %and 1<errexit ! ! THE IMPLICITLY SPECIFIED ROUTINE ARE THE EASIEST OF ALL TO DEAL WITH. ! JUST SET UP THE EXTERNAL SPEC & PARAMETERS. THEN A RECURSIVE CALL ! OF CNAME THEN FINDS THE ROUTINE UNDER ITS TRUE COLOURS AND COMPILES ! THE CALL. ALL CALLS EXCEPT THE FIRST ARE DEALT WITH DIRECTLY BY CNAME. ! ALL NONTRIVIAL ROUTINES SHOULD BE DEALT WITH IN THIS MANNER ! XTRA HAS INDEX INTO ARRAY OF EXTERNAL NAMES SO THAT THESE ! CAN EASILY BE CHANGED. ! ->adhoc(snno) adhoc(47): ! substring outstring("imp_substring(") p=p+1; cstrexp(0); outsym(',') p=p+1; csexp(x'51'); outsym(',') p=p+1; csexp(x'51'); outsym(')'); p=p+1; ->OKEXIT adhoc(24): ! arccos adhoc(25): ! sqrt adhoc(26): ! log adhoc(27): ! sin adhoc(28): ! cos adhoc(29): !tan adhoc(30): ! exp SNXREF = SNXREFS(XTRA) P0 = SNPARAMS(POINTER) %if TARGET=PERQ %or TARGET=ACCENT %then %start JJ = ADDR(SNXREF) D = LENGTH(SNXREF) MOVE BYTES(D+1,JJ,0,ADDR(A(0)),WORKA_ARTOP) JJ = ADDR(A(WORKA_ARTOP))-ADDR(A(WORKA_DICTBASE)) WORKA_ARTOP = (WORKA_ARTOP+D+4)&(-4) %finish %else CXREF(SNXREF,3*PARM_DYNAMIC,P0<<16!P0>>16,JJ) ! JJ SET WITH REF DISPLACEMENT OPHEAD = 0 K = OPHEAD; D = 1 %while D<=P0&15 %cycle B = SNPARAMS(POINTER+D) PTYPE = B&X'FFFF' UNPACK %if NAM=0 %then ACC = BYTES(PREC) %else ACC = 8 %if PTYPE=X'35' %then ACC = 256; !STRING BY VALUE PCELL = 0; ! SET UP PARAMETER DESC VIA RECORD PCELL_PTYPE <- PTYPE; ! FOR CONSISTENCY ON BYTE SWOPPED%c HOSTS PCELL_SNDISP = B>>16 PCELL_ACC <- ACC %if PARAMS BWARDS=YES %then %c PUSH(OPHEAD,PCELL_S1,PCELL_S2,0) %else %c INSERTAT END(OPHEAD,PCELL_S1,PCELL_S2,0) D = D+1 %repeat %if P0>0 %then ASLIST(OPHEAD)_S3 = P0; ! INSERT NO OF PARAMS ! UPPER PART OF P0(TOTAL PARAMSPACE) ! APPARENTLY NOT NEEDED AS NO BODIES ! ARE PROVIDED. LCELL == ASLIST(TAGS(SNNAME)) LCELL_PTYPE = SNPTYPE LCELL_UIOJ = 1<<4!14; ! I=1 & J=14 LCELL_SNDISP <- JJ; ! RT ENTRY DISPLACEMENT LCELL_ACC = BYTES(SNPTYPE>>4&15) LCELL_SLINK = OPHEAD LCELL_KFORM = 0; ! KFORM(=FORMAT INFO) P = PIN; CNAME(Z); ! RECURSIVE CALL P = P-1; %return; ! DUPLICATES CHECK OF ADHOC(6):ADHOC(7): ! NEWLINES(=6) & SPACES(=7) %if parm_arr=0 %start %if snno=6 %then outstring("_imp_newlines(") %else outstring("_imp_spaces(") p=p+1; csexp(x'51') outsym(')') p=p+1 ->OKEXIT %finish p=p+1 %if tsexp(jj)>0 %and jj>0 %start {GT:} outstring("fprintf(out_file, "); outsym('"') %for xtra=1,1,jj %cycle %if snno=6 %then outstring("\n") %else outstring(" ") %repeat outsym('"'); outsym(')') %else p=PIN+3 outstring("{ for (_imptempint=1; _imptempint<=") csexp(x'51') outstring("; _imptempint++) fprintf(out_file, "); outsym('"') %if snno=6 %then outstring("\n") %else outstring(" ") outsym('"') outstring(");}") %finish P = P+1 ->OKEXIT ADHOC(37): ! printstring %if parm_arr=0 %then %start outstring("_imp_printstring(") %finishelsestart {GT:} outstring("fprintf(out_file, "); outsym('"'); outstring("%s") outsym('"'); outstring(", ") %finish p=p+1 cstrexp(0) outstring(")") P=P+1; ->OKEXIT adhoc(2): ! newline %if parm_arr=0 %start outstring("_imp_newlines(1)") %else {GT:} outstring("fprintf(out_file, "); outsym('"'); outstring("%s") outsym('"'); outstring(", "); outsym('"'); outsym('\') outsym('n'); outsym('"');outsym(')') %finish P=P+1; ->OKEXIT adhoc(3): ! space %if parm_arr=0 %start outstring("_imp_spaces(1)") %else {GT:} outstring("fprintf(out_file, "); outsym('"'); outstring("%s") outsym('"'); outstring(", "); outsym('"'); outsym(' ') outsym('"'); outsym(')') %finish P=P+1; ->OKEXIT adhoc(21): ! real adhoc(22): ! integer adhoc(61): ! halfinteger adhoc(66): ! shortinteger adhoc(39): ! longreal adhoc(32): ! byteinteger adhoc(54):adhoc(55): ! long int & longlongreal outstring("(*(") outtype(snptype&255,0) outstring(" *)(") p=p+1; csexp(x'51') outstring("))") P=P+1; ->OKEXIT adhoc(42): ! string outstring("((char *)") p=p+1; csexp(x'51') outstring(")") P=P+1; ->OKEXIT adhoc(45): ! charno {GT: Needs special handling for charno(s,0); also for LHS = ..} %if z#2 %then warn(10,0) p=p+1; cstrexp(0) outsym('[') p=p+1; csexp(x'51') outstring("-1]") p=p+1 ->OKexit ADHOC(36): ! length {GT: Also needs special treatment on LHS } %if z#2 %then warn(10,0) outstring("strlen(") p=p+1; cstrexp(0) outstring(")") P=P+1; ->OKEXIT adhoc(46): ! tostring outstring("imp_tostring(") p=p+1; csexp(x'51') outstring(")") P=P+1; ->OKEXIT ADHOC(9): adhoc(40): ! printsymbol & printch %if parm_arr=0 %start outstring("_imp_printsymbol(") %else {GT:} outstring("fprintf(out_file, "); outsym('"') outstring("%c") outsym('"'); outstring(", "); %finish p=p+1; csexp(x'51') outstring(")") P = P+1 ->OKEXIT ADHOC(12): ! write %if parm_arr=0 %start outstring("_imp_write(") p=p+1; csexp(x'51'); outsym(',') p=p+1; csexp(x'51'); outsym(')') p=P+1; ->OKEXIT %finish p=p+1; skip exp; p=p+1; jj=tsexp(xtra) p=PIN+2 %if jj#0 %start outstring("fprintf(out_file, "); outsym('"'); outstring("%") outint(imod(xtra)+1); outstring("d"); outsym('"'); outstring(",") %else outstring("fprintf(out_file, "); outsym('"'); outstring(" %d"); outsym('"'); outstring(",") %finish p=p+1; csexp(x'51') outstring(")") p=PIN+2; skip app p=p-1; ->OKEXIT ADHOC(19): ! print %if parm_arr=0 %start outstring("_imp_print(") p=p+1; csexp(x'62'); outsym(',') p=p+1; csexp(x'51'); outsym(',') p=p+1; csexp(x'51'); outsym(')') %else outstring("fprintf(out_file, "); outsym('"'); outstring(" %f"); outsym('"'); outstring(",") p=p+1; csexp(x'62') outstring(")") %Finish p=PIN+2; skip app p=p-1; ->OKEXIT ADHOC(20): ! printfl %if parm_arr=0 %start outstring("_imp_printf(") p=p+1; csexp(x'62'); outsym(',') p=p+1; csexp(x'51'); outsym(')') %else outstring("fprintf(out_file, "); outsym('"'); outstring(" %e"); outsym('"'); outstring(",") p=p+1; csexp(x'62') outstring(")") %finish p=PIN+2; skip app p=p-1; ->OKEXIT ADHOC(0): ! SELECT INPUT %if parm_arr=0 %start outstring("_imp_selectinput(") p=p+1; csexp(x'51'); outsym(')') p=p+1; ->OKEXIT %finish ! if C i-o we can not handle this so fall thru {GT:} outstring("selectinput(") p=p+1; csexp(x'51'); outstring(")") p=p+1; ->OKEXIT ADHOC(1): ! SELECT OUTPUT %if parm_arr=0 %start outstring("_imp_selectoutput(") p=p+1; csexp(x'51'); outsym(')') p=p+1; ->OKEXIT %finish ! if C i-o we can not handle this so fall thru {GT:} outstring("selectoutput(") p=p+1; csexp(x'51'); outstring(")") p=p+1; ->OKEXIT ADHOC(*): ! NEXTSYMBOL(=8) & NEXTITEM(=44) ! ALSO ANY WITH NO C EQUIVALENTS {GT:} outstring("/* Call to "); outstring(SMDETAILS(snno)); outstring (" - please modify pass2.i to handle it */") skip app; p=p-1; -> OKEXIT ADHOC(64):ADHOC(65): ! LINT(=64) AND LINTPT(=65) %unless TYPEFLAG(10)&255=X'61' %and TYPEFLAG(12)&255>=X'62' %then %c ERRNO = 99 %and ->ERREXIT ! NEED LONGINTS&LLREALS outstring("((long int) floor(") p=p+1 CSEXP(typeflag(12)&255); ! LONGLONGREAL MODE or longreal if defaulted %if SNNO=64 %then outstring("+0.5") outstring("))") P = P+1 P0 = X'61'; ->OKEXIT ADHOC(16):ADHOC(17): ! INT(=16) AND INTPT (=17) outstring("((int) floor(") p=p+1 CSEXP(LRLPT) %if SNNO=16 %then outstring("+0.5") outstring("))") P = P+1 ->OKEXIT ADHOC(67): ! trunc outstring("((int)(") p=p+1 CSEXP(LRLPT) outstring("))") P = P+1 ->OKEXIT {GT:} ADHOC(10): ! READ SYMBOL ADHOC(41): ! READ CH P = P+6; CNAME(1); outstring(" = fgetc(in_file)") P = P+2; ->OKEXIT ADHOC(14): ! ADDR(=14) P = P+6; CNAME(4); ! FETCH ADDRESS MODE P = P+2; ->OKEXIT ADHOC(23): ! MOD(=23) outstring("fabs(") p=p+1 csexp(x'62') outstring(")") P = P+1 ->OKEXIT ADHOC(51): ! imod outstring("abs(") p=p+1 csexp(x'51') outstring(")") P = P+1 ->OKEXIT ADHOC(52): ! PI(=52) ADHOC(38): ! NL(=38). THIS FN IS PICKED OFF P = P+1 ->OKEXIT; ! ERROR EG NL=A+B ADHOC(48): ! RECORD(=48) p=p+1 %if tsexp(jj)=1 %and jj=0 %start outstring("NULL") %else %if z#4 %start outsym('(') ! outsym('('); outtype(x'33',lhformatname) ! outsym('*') ! outsym(')') %finish p=PIN+3 CSEXP(X'51') P = P+1 outsym(')') %finish DISP = 0; BASE = 0; ACCESS = 3 OLDI = 0; ACC = X'FFFF' SNPTYPE = SNPTYPE+X'1C00'; ! ADD MAP BITS PTYPE = SNPTYPE; UNPACK %return ADHOC(49): ! ARRAY(=49) p=p+1 skip exp ERRNO = 22; ERRVAL = 2 ->ERREXIT %unless A(P+4)=4 %and A(P+5)=1 P = P+6; formatname=fromar2(p) copytag(formatname,NO) p=p+4 ->ERREXIT %unless A(P)=2 xtra=p+2 outstring("(("); outtype(ptype&255,lhformatname) outstring("*)(") p=PIN+3 CSEXP(X'51'); ! ADDR(A(0)) TO NEST outstring("))") copytag(formatname,NO) P = xtra %return ADHOC(13): ! EVENTINF(=33) & EVENTLINE D = CURRINF_ONINF FAULT(16,0,SNNAME) %if D=0 D = D+4 %if SNNO#33 BASE = RBASE; ACCESS = 0 DISP = D; SNPTYPE = SNPTYPE+X'1C00'; ! ADD MAP BITS ->OKEXIT !ADHOC(14): ! LENGTHEN AND SHORTEN D = (SNNO&3)*8 JJ = X'62517261'>>D&255 %if 1<OKEXIT ADHOC(15): ! PPROFILE(IGNORED UNLESS PARM SET) JJ = UCONSTTRIP(PPROF,X'51',0,PROFAAD) %unless PARM_PROF=0 ->OKEXIT !ADHOC(16): ! FLOAT CSEXP(LRLPT) NAMEOPND = EXPOPND P = P+1 OKEXIT: ! NORMAL EXIT PTYPE = SNPTYPE; UNPACK ACC = BYTES(PREC) %return ERREXIT: ! ERROR EXIT FAULT(ERRNO,ERRVAL,SNNAME) NAMEOPND = 0; NAMEOPND_PTYPE = X'51' BASE = 0; DISP = 0; ACCESS = 0; AREA = 0 PTYPE = SNPTYPE; UNPACK P = PIN+2; SKIP APP P = P-1; %return %integer %fn CIOCP(%integer EP, %record (RD) %name PARAM) !*********************************************************************** !* CALL IOCP PASSING A PARAMETER !* RETURNS THE TRIPLE NO OF THE CALL !*********************************************************************** %record (RD) OPND OPND_PTYPE = MINAPT; OPND_FLAG = SCONST OPND_D = EP %result = BRECTRIP(IOCPC,MINAPT,DONT OPT,OPND,PARAM) %end %routine RTOS !*********************************************************************** !* PLANTS CODE TO CONVERT A SYMBOL IN EXPOPND TO A ONE * !* CHARACTER STRING IN A TEMPORARARY VARIABLE. * !*********************************************************************** %integer KK,JJ %if EXPOPND_FLAG<=1 %start KK = ITOS1 CTOP(KK,JJ,0,EXPOPND,NAMEOPND) %if KK=0 %then NAMEOPND = EXPOPND %and %return %finish JJ = URECTRIP(ITOS1,X'35',0,EXPOPND) NAMEOPND_PTYPE = X'35'; NAMEOPND_FLAG = REFTRIP NAMEOPND_D = JJ %end %end; ! OF ROUTINE CSNAME %routine CANAME(%integer Z,ARRP, %record (RD) %name HDOPND) !*********************************************************************** !* BS & DP DEFINE THE POSITION OF THE ARRAY HEAD * !* ARRP=1 FOR ARRAYS,2 FOR VECTORS,3 FOR ARRAYS IN RECORDS * !* BASIC DISP = DISPMNT OF A(0) FOR VECTORS OR ARRAYS IN RECORDS * !*********************************************************************** %integer HEAD1,BOT1,NOPS,ELSIZE,PTYPEP,JJ,SOLDI,KK,PP,TYPEP,LB, ARRNAME,Q,PRECP,NAMINF,DVD,DVDP,PRIVOPS %record (RD) VMYOP,RPOP %record (TAGF) %name LCELL %integer %array HEADS,BOTS(0:12) NOPS = 0; HEAD1 = 0; BOT1 = 0 PP = P; TYPEP = TYPE JJ = J; PTYPEP = PTYPE; PRECP = PREC; SOLDI = OLDI %if TYPE<=2 %then ELSIZE = BYTES(PRECP) %else ELSIZE = ACC %if ELSIZE>4095 %or (TYPE=5 %and NAM#0) %then ELSIZE = 0 DVD = SNDISP; ! LOCATION OF DV IF CONSTANT VMYOP_FLAG = 0; VMYOP_XB = 0 ARRNAME = FROM AR2(P); ! NAME OF ENTITY NAMINF = TAGS(ARRNAME) FAULT(87,0,ARRNAME) %if ARR=3; ! ARRAYFORMAT USED AS ARRAY ! NAMINF = -2 %and DVD = 0 %if ARRP>2; ! ARRAYS IN RECORDS %if DVD>0 %then VMYOP_PTYPE = X'51' %and VMYOP_D = DVD %else %c VMYOP = HDOPND TEST APP(Q); ! COUNT NO OF SUBSCRIPTS ! ! CHECK CORRECT NO OF SUBSCRIPTS PROVIDED. HOWEVER ENTITIES DECLARED ! AS %ARRAYNAME HAVE NO DIMENSION . THIS SECTION SETS THE ! DIMENSION FROM THE FIRST USE OF THE NAME. ! %if JJ=0 %then %start; ! 0 DIMENSIONS = NOT KNOWN LCELL == ASLIST(TCELL) LCELL_UIOJ = LCELL_UIOJ!Q; ! DIMSN IS BOTTOM 4 BITS OF TAG JJ = Q %finish %if JJ=Q#0 %then %start; ! IN LINE CODE ! ! FOR IN-LINE CODE WE SET UP A CHAIN OF REVERSE POLISH OPERATIONS TO ! EVALUATE THE VARIOUS SUBSCRIPTS,MULTIPLY BY THE MULTIPLIERS AND ! ADD THEM TOGETHER. ! ! ! NOW PROCESS THE SUBSCRIPTS CALLING TORP TO CONVERT THE EXPRESSIONS ! TO REVERSE POLISH AND ADDING THE EXTRA OPERATIONS. ! P = PP+3 %cycle KK = 1,1,JJ; ! THROUGH THE SUBSCRIPTS heads(kk)=p; skip exp P = P+1 %repeat pp=p; outstring(" [") DVDP=DVD+3*jj %cycle KK = jj,-1,1 p=heads(kk); csexp(x'51') LB=Ctable(DVDP) %if DVD#0 %start { we know how to adjust bounds } %if LB=x'80000000' %start outstring("-(") p=Ctable(DVDP+1); csexp(x'51'); outsym(')') %finish %else %if lb>0 %start outsym('-'); outint(LB) %finish %else %if LB=0 %start ! outint(LB) %finish %else %if LB<0 %start outsym('+'); outint(-LB) %finish %else warn(13,0) %finish outstring("] [") %unless kk=1 DVDP=DVDP-3 %repeat p=pp; outsym(']') %finish %else %start RPOP = 0; RPOP_FLAG = SCONST BINSERT(HEAD1,BOT1,RPOP_S1,0,0) %if JJ>Q %then FAULT(20,JJ-Q,ARRNAME) %else %c FAULT(21,Q-JJ,ARRNAME) P = P+2; SKIP APP %finish SOLDI = OLDI ACCESS = 3 ACC = ELSIZE; PTYPE = PTYPEP; UNPACK; J = JJ %if TYPE=5 %and NAM>0 %then MLOPND = HDOPND OLDI = SOLDI; ! FOR NAME==A(EL) VALIDATION %return %end; ! OF ROUTINE CANAME %routine namepreamble(%integer z,fname) !*********************************************************************** !* puts any unary operators on front of the name * !* assumes ptype has been set and unpacked * !*********************************************************************** %integer typep,qq,subs,pp typep=type pp=p %if typep=3 %then qq=copy record tag(subs) %and p=pp %if z=3 %and type#5 %and (nam=0 %or arr#0) %then outsym('&') %if z=4 %and type#5 %and (nam=0 %or arr#0) %then outstring("(int)&") %if z=4 %and (type=5 %or (nam#0 %and arr=0)) %then outstring("(int)") %if (z=1 %or z=2) %and ((nam#0 %and arr=0=rout) %orc (nam>=2 %and rout=1{mapping fn call })) %and type#5 %c %and %not(typep=3 %and qq=0){ NOT RECORD WITHOUT SUBNAME} %then outsym('*') %if z=7 %and typep=3 %and qq=0 %and nam#0 %and arr=0 %thenc outsym('*') { record pointer without subname } outname(fname) %if typep=3 %then copy tag(fname,no) %end !* %routine CNAME(%integer Z) !*********************************************************************** !* THIS IS THE MAIN ROUTINE FOR PROCESSING NAMES.CANAME,CSNAME * !* AND CRNAME ARE ONLY CALLED FROM HERE,THE NAME (AND ANY PARAMS * !* OR SUBNAMES) ARE ACCESSED BY P WHICH IS ADVANCED. * !* Z SPECIFIES ACTION AS FOLLOWS:- * !* Z=0 COMPILE A ROUTINE CALL * !* Z=1 ARRANGE A 'STORE' OPERATION FROM ESTACK * !* Z=2 FETCH NAME TO ESTACK * !* Z=3 GET 32 BIT ADDRESS(48BIT FOR BYTES) FOR PASSING BY NAME * !* Z=4 SET 20 BIT ADDRESS(36BIT FOR BYTES) OF NAME IN REG * !* Z=5 AS Z=2 * !* Z=6 STORE ETOS (CONTAINS POINTER) INTO POINTER VARIABLE * !* Z=7->10 NOT NOW USED * !* Z=11 FETCH 32 BIT ADDRESS OF ARRAYHEAD * !* Z=12 FETCH ARRAYHEAD TO ESTACK * !* Z=13 GET 4 WORD ROUTINE DISCRIPTOR * !* (INTERNAL ROUTINES FIRST CREATE THE DISCRIPTOR) * !* * !*********************************************************************** %integer JJ,KK,LEVELP,DISPP,NAMEP,PP,SAVESL,FNAME %record (RD) TOPND %switch S,FUNNY(11:13),SW(0:8) PP = P FNAME = A(P)<<8+A(P+1) %if Z=1 %or Z=6 %then STNAME = FNAME copy tag(Fname,YES); ! DECLARE IF UNKNOWN AT THIS POINT SAVESL = ACC JJ = J; JJ = 0 %if JJ=15 NAMEP = FNAME LEVELP = I; DISPP = K FAULT(43,0,FNAME) %if %c LITL=1 %and ROUT=0=NAM %and (Z=1 %or Z=3 %or (Z=4 %and ARR=0)) ->NOT SET %if TYPE=7 %if (Z=0 %and (ROUT#1 %or 0#TYPE#6)) %or (Z=13 %and ROUT=0) %then %c FAULT(27,0,FNAME) %and ->NOT SET ->FUNNY(Z) %if Z>=10 ->RTCALL %if ROUT=1 namepreamble(z,fname) ->SW(TYPE) SW(6): FAULT(5,0,FNAME) ->NOT SET SW(4): !RECORD FORMAT NAME FAULT(87,0,FNAME) NOT SET: ! NAME NOT SET namepreamble(z,fname) SW(7): BASE = I; DISP = K; ACCESS = 0 NAMEOPND = 0; NAMEOPND_PTYPE = X'51' PTYPE = X'51'; UNPACK P = P+2 %if a(p)=1 %start {%if z=1 %or z=3 %or z=4 %then jj='[' %else} jj='(' outsym(jj) p=p+1; csexp(x'51') %while a(p)=1 %cycle outsym(','); p=p+1; csexp(x'51') %repeat outsym(jj+1+jj>>6) { ')' or ']' } %finish p=p+1 ->CHKEN FUNNY(11): ! SET 32 BIT ADRESS OF ARRAYHEAD FUNNY(12): ! MOVE ARRAYHEAD TO ESTACK %if PTYPE=SNPT %then CSNAME(12) %and ->CHKEN namepreamble(z,fname) ->SW(3) %if TYPE=3 %and (ARR=0 %or A(P+2)=1) %if A(P+2)=2 %then P = P+3 %else NO APP NAMEOPND_FLAG = DNAME NAMEOPND_D = FNAME NAMEOPND_XTRA = 0 S(12): S(11): ! ARRAYS IN RECORDS BY NAME NAMEOPND_PTYPE = AHEADPT ->CHKEN FUNNY(13): ! LOAD ADDR FOR RT-TYPE %if PTYPE=SNPT %then CSNAME(Z) %and P = P+1 %and ->CHKEN namepreamble(z,fname) JJ = UNAMETRIP(RTFP,RTPARAMPT,0,FNAME) NAMEOPND_PTYPE = RTPARAMPT; NAMEOPND_FLAG = REFTRIP NAMEOPND_D = JJ NAMEOPND_XTRA = 0 %if A(P+2)=2 %then P = P+3 %else NO APP ->CHKEN RFUN: ! RECORD FUNCTIONS EXPOPND = NAMEOPND RMAP: ! RECORD MAPS COPY TAG(NAMEP,NO); ! SET KFORM ETC P = P-3 NAMEP = -1 CRNAME(Z,3,0,0,NAMEP) ->RBACK SW(3): ! RECORD CRNAME(Z,2*NAM,I,K,NAMEP) RBACK: ->S(Z) %if Z>=10 ->STRINREC %if TYPE=5 %and Z#6 ->NOT SET %if TYPE=7 NAMEOP(Z,BYTES(PREC),NAMEP) STNAME = NAMEP %if Z=1 %or Z=6 ->CHKEN SW(5): ! TYPE =STRING ! ! ALL STRING OPERATIONS ARE ON THE RELEVANT DESCRIPTOR. Z=2 &Z=5 ! REQUIRE A CURRENT LENGTH(IE MODIFIED) DESCRIPTOR. OTHER OPERATIONS ! REQUIRE THE MAX LENGTH DESCRIPTOR (IE UNMODIFIED HEADER) ! %if Z=6 %then ->SW(1) ->STRARR %if ARR>=1 %if A(P+2)=2 %then P = P+3 %else NO APP BASE = I; ACCESS = 2*NAM; DISP = K SMAP: MLOPND = 0 %if NAM#1 %then %start MLOPND_PTYPE = X'51' MLOPND_D = SAVESL-1 %else MLOPND_PTYPE = X'61' MLOPND_FLAG = LOCALIR MLOPND_D = I<<16!K %finish NAMEOP(Z,4,NAMEP) ->CHKEN STRARR: ! STRINGARRAYS & ARRAYNAMES TOPND = 0 TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME TOPND_D = FNAME CANAME(Z,ARR,TOPND) ->SMAP %unless Z=3 %and NAM#0 ! MLOPND LEFT SET BY CANAME NAMEOP(3,4,NAMEP) ->CHKEN STRINREC: ! STRINGS IN RECORDS SAVESL = ACC ->SMAP %unless Z=3 %and NAM#0 %and ARR#0 ! MLOPND SET BY CANAME & SET LEFT SET%c BY CENAME NAMEOP(3,4,NAMEP) ->CHKEN ! ! SECTION TO DEAL WITH ALL NAMES INVOLVING ROUTINE CALL ! RTCALL: ! FIRST CHECK %if TYPE=0 %and Z#0 %then FAULT(23,0,FNAME) %and ->NOT SET ! RT NAME IN EXPRSN %if PTYPE=SNPT %then %start CSNAME(Z); ! SPECIAL NAME ->BIM %if ROUT=1 %and NAM>1 %and Z#0 ->CHKEN %finish namepreamble(z,fname) CRCALL(FNAME); P = P+1; ! DEAL WITH PARAMS ->CHKEN %if PTYPE&15=0 ->UDM %if NAM>1; ! MAPS %unless Z=2 %or Z=5 %or Z=3=TYPE %start; ! FUNCTIONS FAULT(29,0,FNAME); BASE = 0 ACCESS = 0; DISP = 0 %finish ->RFUN %if TYPE=3 ->CHKEN UDM: ! USER DEFINED MAPS DISP = 0 ACCESS = 3 BASE = 0 EXPOPND = NAMEOPND ->RMAP %if TYPE=3 BIM: ! BUILT IN MAPS NAMEP = -1 STNAME = -1 %if TYPE=5 %then SAVESL = 256 %and ->SMAP KK = Z; KK = 2 %if Z=5 NAMEOP(Z,BYTES(PREC),NAMEP) ->CHKEN SW(0): ! %name PARAMETERS NO TYPE ! ALLOW FETCH ADDR OPERATIONS ! AND SPECIAL FOR BUILTIN MAPS %unless 3<=Z<=4 %then %start FAULT(90,0,FNAME); TYPE = 1 %finish SW(1): ! TYPE =INTEGER SW(2): ! TYPE=REAL %if ARR=0 %or (Z=6 %and A(P+2)=2) %then %start BASE = I; ACCESS = 2*NAM DISP = K %if A(P+2)=2 %then P = P+3 %else NO APP %finish %else %start TOPND = 0 TOPND_PTYPE = AHEADPT; TOPND_FLAG = DNAME TOPND_D = FNAME CANAME(Z,ARR,TOPND) NAM = 0 %finish NAMEOP(Z,BYTES(PREC),NAMEP) ->CHKEN ! CHKEN: %while A(P)=1 %cycle FAULT(69,FROMAR2(P+1),FNAME) outsym('_'); outname(fromar2(P+1)) P = P+3; SKIP APP %repeat P = P+1 %end %routine NAMEOP(%integer Z,SIZE,NAMEP) %end %routine CRCALL(%integer RTNAME) !*********************************************************************** !* COMPILE A ROUTINE OR FN CALL * !* THE PROCEDURE CONSIST OF THREE PARTS:- * !* A) PLANT THE PARAMETER (IF ANY) * !* B) ENTER THE ROUTINE OR FN * !* C) FORGET ANY REGISTERS WHICH HOLD ENTITIES THAT CAN BE * !* ALTERED BY THE CALLED PROCEDURE. * !*********************************************************************** %integer II,III,QQQ,JJ,JJJ,NPARMS,PT,LP,PSIZE,TWSP,PARMNO,ERRNO, FPTR,TYPEP,PRECP,NAMP,TL,CLINK,PSPECED,OUTP,PPTYPE,DVD,DVDP,LB,KK %record (RD) OPND,OPND1,OPND2 %record (LISTF) %name LCELL PT = PTYPE; JJJ = J; TL = OLDI TWSP = 0; FPTR = 0 LP = I; CLINK = K TYPEP = TYPE; PRECP = PREC; NAMP = NAM %if CLINK=0 %then PSPECED = 0 %else PSPECED = ASLIST(CLINK)_S3&255 ! %begin %integer %array ARP(0:PSPECED) %switch FPD(0:3) ! NOW CHECK THAT THE RIGHT NUMBER OF PARAMETERS HAVE BEEN PROVIDED ! ALSO NOTE THE POINTERS TO ACTUAL PARAMETERS ALLOWING FOC 'C' COMPATABILITY ! P = P+2 NPARMS = 0 %while A(P)=1 %cycle P = P+1 %if NPARMSOVER %finish ! II = UNAMETRIP(PRECL,PT&255,0,RTNAME) PARMNO = 0 outsym('(') ->FIRST PARM ! BAD PARM: ! BAD PARAMETER FAULT IT %if PARAMS BWARDS=Yes %then II=pspeced-parmno+1 %else ii=parmno FAULT(22,II,RTNAME) NEXT PARM: CLINK = LCELL_LINK outsym(',') %unless clink=0 FIRSTPARM: ->ENTRY SEQ %if CLINK=0; ! DEPART AT ONCE IF NO PARAMS LCELL == ASLIST(CLINK) PSIZE = LCELL_ACC&X'FFFF' PARMNO = PARMNO+1 P = ARP(PARMNO) PTYPE = LCELL_PTYPE UNPACK II = TYPE; III = PREC JJ = (NAM<<1!ARR)&3 ->BAD PARM %unless %c (JJ=0 %and ROUT=0) %or JJ=2 %or (A(P+3)=4 %and %c A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2) OPND_PTYPE <- PTYPE; OPND_FLAG = DNAME OPND_D = RTNAME OPND_XTRA = PARMNO<<24!CLINK ! ! RT TYPE PARAMS, PASS 4 WORDS AS SET UP BY QCODE INSTRN LVRD ! %if ROUT=1 %then %start II = PTYPE; P = P+5 CNAME(13); ! SET UP 4 WDS IN ACC ->BAD PARM %if II&255#PTYPE&255; ! PREC&TYPE SIMILAR P = P+1 FPTR = FPTR+RTPARAMSIZE ->NEXT PARM %finish ->FPD(JJ) FPD(0): ! VALUE PARAMETERS %if TYPE=3 %start; ! RECORDS BY VALUE II = TSEXP(III); ! CHECK FOR ZERO AS RECORD VALUE %if II=1 %and III=0 %start -> bad parm %finish %else %start P = ARP(PARMNO); ! RESET NEEDED AFTER TSEXP ->BAD PARM %unless %c A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2 P = P+5 CNAME(6) P = P+1 JJ = 1 EXPOPND = NAMEOPND ->BAD PARM %unless ACC=PSIZE %finish FPTR = FPTR+PSIZE %if TARGET=EMAS %then FPTR = FPTR+8; ! TIRESOME BACK%c COMPATIBILITY ! WITH EMAS IMP ON RECORD VALUES %finish %else %if TYPE=5 %then %start %if STRVALINWA=YES %start; ! USING WORK AREA (2900) CSTREXP(0) PUSH(TWSP,VALUE,0,0); ! REMEBER WA FPTR = FPTR+PTRSIZE(X'35') pptype = x'51' %if ptrsize(x'35')>4 %then pptype = x'61' opnd1 = 0; opnd2 = 0 opnd2_flag = sconst; opnd2_ptype = x'51' opnd2_d = lcell_acc-1 opnd1_flag = localir; opnd1_ptype = x'35' opnd1_d = rbase<<16!value opnd1_flag = reftrip; opnd1_ptype = pptype ->next parm %finish %else %start CSTREXP(0) FPTR = FPTR+ACC %finish %finish %else %start CSEXP(III<<4!II) FPTR = FPTR+BYTES(III) %finish FPTR = (FPTR+MINPARAMSIZE-1)&(-MINPARAMSIZE) ->NEXT PARM ! FPD(2): ! NAME PARAMETERS PPTYPE = X'51'; ! PTYPE OF RESULTANT POINTER %if PTRSIZE(PTYPE&255)>4 %then PPTYPE = X'61' %if II#0 %start; ! NOT A GENERAL NAME QQQ = 0 %if A(P+3)=4 %and A(P+4)=1 %and A(P+FROMAR2(P+1)+1)=2 %start P = P+5 REDUCE TAG(YES) %if II=TYPE %and III=PREC %and (LITL#1 %or NAM#0) %and %c (ROUT=0 %or NAM=2) %then QQQ = 1 %else P = P-5 %finish %if QQQ#0 %then CNAME(3) {TRUE REF} %else %start ! EXPRESSION BY REFERENCE ->BAD PARM %unless JJJ=14 %or LP=0 ->BAD PARM %if II=3 %if II=5 %start; ! STRING EXPRESSION CSTREXP(0) PUSH(TWSP,VALUE,0,0) QQQ = VALUE OPND2_D = 255 %finish %else %start GET WSP(QQQ,BYTES(III)>>2) CSEXP(LCELL_PTYPE&255) OPND2_D = BYTES(III) %finish OPND2_FLAG = SCONST OPND2_PTYPE = X'51' OPND1_FLAG = LOCALIR OPND1_PTYPE = LCELL_PTYPE&255 OPND1_D = RBASE<<16!QQQ OPND1_XTRA = 268; ! size of area needed for stack dowm m-cs %if II#5 %then %c NAMEOPND_FLAG = REFTRIP NAMEOPND_PTYPE = PPTYPE NAMEOPND_D = QQQ %finish JJ = PTRSIZE(III<<4!II) FPTR = FPTR+JJ %finish %else %start ->BAD PARM %unless %c A(P+3)=4 %and A(P+4)=1 %and A(P+1+FROMAR2(P+1))=2 P = P+5 FNAME = FROM AR2(P) REDUCE TAG(NO) OPND2_PTYPE = X'51'; OPND2_FLAG = SCONST OPND2_D = ACC<<16!PTYPE OPND2_XTRA = 0 %if TYPE=0 %start; ! NAME AS GENERAL NAME NAMEOPND_PTYPE <- PTYPE; NAMEOPND_FLAG = DNAME NAMEOPND_D = FNAME NAMEOPND_XTRA = X'80000000' %finish %else %if NAM#0 %and TYPE=5 %start CNAME(3) %finish %else CNAME(4) EXPOPND_PTYPE = X'61'; EXPOPND_FLAG = REFTRIP EXPOPND_XTRA = 0 FPTR = FPTR+PTRSIZE(0) %finish P = P+1 ->NEXT PARM FPD(1): FPD(3): ! ARRAY NAME (&VALUE) ! ! FOR ARRAYNAME PARAMETERS THE NO OF DIMENSIONS OF THE ARRAY IS ! DEDUCED FROM THE FIRST CALL AND STORED IN STREAM3 OF THE PARAMETER ! LIST. ON ANY SUBSEQUENT CALL ONLY ARRAYS OF THE SAME DIMENSION CAN ! BE PASSED ! P = P+5 reduce tag(NO) DVD = SNDISP %if DVD#0 %then outsym('&'); CNAME(12) P = P+1 ->BAD PARM %unless 1<=ARR<=2 %and II=TYPE %and III=PREC QQQ = ASLIST(TCELL)_UIOJ&15; ! DIMENSION OF ACTUAL(IF KNOWN) JJ = LCELL_UIOJ&15; ! DIMENSION OF FORMAL %if JJ=0 %then JJ = QQQ %and LCELL_UIOJ = LCELL_UIOJ!JJ %if QQQ=0 %then QQQ = JJ %and %c ASLIST(TCELL)_UIOJ = ASLIST(TCELL)_UIOJ!JJ ->BAD PARM %unless JJ=QQQ %if DVD#0 %start { have info to adjust basepoint } DVDP=DVD+3*jj %cycle KK = jj,-1,1 LB=Ctable(DVDP) outsym('[') %if LB=x'80000000' %start outstring("-(") p=Ctable(DVDP+1); csexp(x'51'); outsym(')') %finish %else %if lb>0 %start outsym('-'); outint(LB) %finish %else %if LB<=0 %start {outsym('+');} outint(-LB) %finish outstring("] ") DVDP=DVDP-3 %repeat %finish FPTR = FPTR+AHEADSIZE ->NEXT PARM ENTRY SEQ: ! CODE FOR RT ENTRY outsym(')') %while TWSP>0 %cycle POP(TWSP,QQQ,JJ,III); ! ONLY IF STR VALS & EMAS RETURN WSP(QQQ,268) %repeat %if STRRESINWA=YES %and NAMP<=1 %and (TYPEP=3 %or %c TYPEP=5) %start GET WSP(QQQ,268); ! AUTOMATIC RETURN OPND2_PTYPE <- PT OPND2_FLAG = LOCALIR OPND2_D = RBASE<<16!QQQ OPND2_XTRA = 268 Opnd_ptype<-pt; opnd_flag=dname opnd_d=rtname; opnd_xtra=(pspeced+1)<<24 FPTR = FPTR+PTRSIZE(X'35') %finish II = UNAMETRIP(RCALL,PT&255,0,RTNAME) TRIPLES(II)_OPND1_XTRA = FPTR; ! PASS PARAM SIZE TOTAL CURRINF_NMDECS = CURRINF_NMDECS!2 ROUT = 1; TYPE = TYPEP; NAM = NAMP PREC = PRECP; PTYPE = PT ! ! RECOVER THE RESULT OF FNS & MAPS. OFTEN NOCODE WILL BE NEEDED ! %if PT&255#0 %start %if NAM>=2 %then II = RCRMR %else II = RCRFR II = UNAMETRIP(II,PT&255,0,RTNAME) %if STRRESINWA=YES %then TRIPLES(II)_OPND1_XTRA = QQQ ! WORK AREA OFFSET NAMEOPND_PTYPE = PT&255; NAMEOPND_FLAG = REFTRIP NAMEOPND_D = II NAMEOPND_XTRA = 0 %finish OVER: P = OUTP %end; ! OF INNER BLOCK %end %integer %fn TSEXP(%integer %name VALUE) %switch SW(1:3) %integer PP,KK,SIGN,CT TYPE = 1; PP = P P = P+3 SIGN = A(P) ->TYPED %unless SIGN=4 %or A(P+1)=2 ->SW(A(P+1)) SW(1): ! NAME P = P+2; REDUCE TAG(NO) %if ptype&x'ff0f'=x'4001' %start { any const int } %if a(p+2)=2 %and a(p+3)=2 %and a(p+4)=2 %then %start value=midcell p=p+5 %if sign#2 %then %result = 2 value=-value; %result=-2 %finish %finish ->TYPED SW(2): ! CONSTANT CT = A(P+2); TYPE = CT&7 ->TYPED %unless CT=X'41' %and SIGN#3 KK = FROMAR2(P+3) ->TYPED %unless a(p+5)=2 VALUE = KK P = P+6 %if SIGN#2 %then %result = 1 VALUE = -VALUE; %result = -1 SW(3): ! SUB EXPRN TYPED:P = PP; %result = 0 %end !* %integerfn tsc %integer value,res,PP %switch sw(1:4) !printstring("tsc with p="); write(p,5); newline PP=p ->sw(a(p)) sw(1): p=p+1 res=tsexp(value) %if res=0 %then %result=0 p=p+1 !printstring("tcond part2 with p="); write(p,5); newline res=tsexp(value) %if res=0 %then %result=0 p=p+1 %if a(p-1)=1 %then %result=0 %RESULT=1 SW(2): p=p+1; res=tcond !printstring("returns from tcond with res & p "); write(res,1); write(p,5); newline %result=res SW(3): P=P+1 %result=tsc sw(4): ! boolean %result=tsexp(value) %end %integerfn tcond !*********************************************************************** !* Check for a simple compile time condition. PP to First exp * !*********************************************************************** %integer value,res,PP !printstring("tcond with p="); write(p,5); newline PP=p res=tsc %if res=0 %then %result=0 %if a(p)=3 %then p=p+1 %and %result=1 %until a(p)=2 %cycle p=p+1; res=tsc %if res=0 %then %result=0 %repeat p=p+1 %result=1 %end %routine SKIP EXP !*********************************************************************** !* SKIPS OVER THE EXPRESSION POINTED AT BY P. USED FOR ERROR * !* RECOVERY AND TO EXTRACT INFORMATION ABOUT THE EXPRESSION. * !*********************************************************************** %integer OPTYPE,PIN,J,precp PIN = P P = P+3; ! TO P<+'> %cycle; ! DOWN THE LIST OF OPERATORS OPTYPE = A(P+1); ! ALT OF P P = P+2 %if OPTYPE=0 %or OPTYPE>3 %then IMPABORT %if OPTYPE=3 %then SKIP EXP; ! SUB EXPRESSIONS ! %if OPTYPE=2 %then %start; ! OPERAND IS A CONSTANT J = A(P)&7; ! CONSTANT TYPE %if J=5 %then P = P+A(P+1)+2 %else %start precp=A(P)>>4 %if precp=3 %then precp=4 P = P+1+BYTES(precp) %finish %finish ! %if OPTYPE=1 %then %start; ! NAME P = P-1 P = P+3 %and SKIP APP %until A(P)=2; ! TILL NO ENAME P = P+1 %finish ! P = P+1 %if A(P-1)=2 %then %exit; ! NO MORE REST OF EXP %repeat %end; ! OF ROUTINE SKIP EXP %routine SKIP APP !*********************************************************************** !* SKIPS ACTUAL PARAMETER PART * !* P IS ON ALT OF P AT ENTRY * !*********************************************************************** %integer PIN PIN = P P = P+1 %and SKIP EXP %while A(P)=1 P = P+1 %end %routine NO APP !*********************************************************************** !* Deals with unexpected parameters * !*********************************************************************** P = P+2 %if A(P)=1 %then %start; ! PRESENT FAULT(17,0,FROM AR2(P-2)) outsym('[') %while a(p)=1 %cycle p=p+1 csexp(x'51') %if a(p)=1 %then outsym(',') %repeat p=p+1; outsym(']') %finish %else P = P+1; ! P NOW POINTS TO ENAME %end %routine TEST APP(%integer %name NUM) !*********************************************************************** !* THIS ROUTINE COUNTS THE NUMBER OF ACTUAL PARAMETERS * !* WHICH IT RETURNS IN NUM. * !*********************************************************************** %integer PP,Q Q = 0; PP = P; P = P+2; ! P ON NAME AT ENTRY %while A(P)=1 %cycle; ! NO (MORE) PARAMETERS P = P+1; Q = Q+1 SKIP EXP %repeat P = PP; NUM = Q %end %routine SET LINE !*********************************************************************** !* UPDATE THE STATEMENT NO * !*********************************************************************** %integer I,offset %return %if RLEVEL=0; ! AMONG CONDITIONAL GLOBAL DECS offset=CURRINF_DIAGINF+2 %if target=ORN %or 1<>16=0 LCELL == ASLIST(TCELL) %if LCELL_UIOJ>>8&63=LEVEL %or kk=currinf_m-1 %then %start ! FAULT(7,0,KK) LCELL_UIOJ <- LCELL_UIOJ&X'C000'!Q; ! COPY USED BITS ACCROSS %finish %else %start I = ASL; %if I=0 %then I = MORE SPACE LCELL == ASLIST(I) ASL = LCELL_LINK LCELL_LINK = TCELL!CURRINF_NAMES<<18 LCELL_UIOJ = Q TAGS(KK) = I CURRINF_NAMES = KK %finish LCELL_PTYPE <- PTYPE LCELL_ACC <- ACC LCELL_SNDISP <- SNDISP LCELL_KFORM = KFORM LCELL_SLINK <- SLINK %end %routine COPY TAG(%integer TNAME,DECLARE) !*********************************************************************** !* A TAG IS A LIST CELL POINTED AT BY TAGS(NAME) * !* S1 HAS PTYPE<<16!USEBITS(2)!TEXT LEVEL(OLDI6)!RTLEVE(4)!DIMEN * !* S2 HAS SECONDARY DISP(SIGNED)<<16! ACC OR ITEM SIZE IN BYTES * !* S3 HAS PRIMARY DISP(K)<<16!KFORM WHICH IS POINTER TO FORMAT * !* SIDE CHAIN FOR ITEMS OF TYPE RECORD * !* LINK HAS PTR TO TAG OF NAME HIDDEN WHEN THIS ONE DECLARED * !*********************************************************************** %record (TAGF) %name LCELL TCELL = TAGS(TNAME) %if TCELL=0 %then %start; ! NAME NOT SET TYPE = 7; PTYPE = X'57'; PREC = 5 %if DECLARE=YES %start FAULT(16,0,TNAME) STORE TAG(TNAME,LEVEL,RBASE,0,0,4,N,0) N = N+4 COPY TAG(TNAME,NO); ! TO SET USE BITS %return %finish ROUT = 0; NAM = 0; ARR = 0; LITL = 0; ACC = 4 I = -1; J = -1; K = -1; OLDI = -1; kform = -1 %finish %else %start LCELL == ASLIST(TCELL) PTYPE = LCELL_PTYPE&X'FFFF' USEBITS = LCELL_UIOJ>>14&3 OLDI = LCELL_UIOJ>>8&63 I = LCELL_UIOJ>>4&15 J = LCELL_UIOJ&15 LCELL_UIOJ <- LCELL_UIOJ!X'8000' MIDCELL = LCELL_S2 SNDISP = LCELL_SNDISP&X'FFFF'; ! Sign extension on some hosts ACC = LCELL_ACC&X'FFFF' K = LCELL_SLINK&X'FFFF'; ! Sign extension on some hosts KFORM = LCELL_KFORM LITL = PTYPE>>14&3; ! SIGNEXTENSION ON 16 BIT MACHINES ROUT = PTYPE>>12&3 NAM = PTYPE>>10&3 ARR = PTYPE>>8&3 PREC = PTYPE>>4&15 TYPE = PTYPE&15 %finish %end %routine REDUCE TAG(%integer DECLARE) !*********************************************************************** !* AS COPY TAG FOR NAME AT A(P) EXCEPT:- * !* 1) SPECIAL NAMES HAVE THEIR CORRECT PREC & TYPE SUBSTITUTED * !* 2) RECORD ELEMENTS HAVE THE SUBNAME PARTICULARS RETURNED * !*********************************************************************** %integer SUBS,QQ,PP COPY TAG(FROMAR2(P),DECLARE) %if PTYPE=SNPT %then %start PTYPE = ACC; UNPACK %if k=42 {string} %then acc = 256 %else %if %c k=48 {record} %then acc = x'7fff' %else ACC = BYTES(PREC) %finish; ! TO AVOID CHECKING PARAMS %if TYPE=3 %then %start PP = P; QQ = COPY RECORD TAG(SUBS); P = PP %finish %end ! LAYOUT OF PTYPE ! ****** ** ***** ! PTYPE REQUIRES 16 BITS TO DEFINE A VARIABLE AND CAN BE REGARDED AS ! AS TWO BYTEINTEGERS:= ! UPPER ONE(UPTYPE):= LITL<<6!ROUT<<4!NAM<<2!ARR ! LOWER ONE(PTYPE) :=PREC<<4!TYPE ! OFTEN (EG IN EXPOP) ONLY THE LOWER PART IS REQUIRED AS FUNCTIONS ! ETC ARE PREFETCHED AND STACKED. ! LITL:= 1=CONST,2=EXTERNAL,3=EXTRINSIC(OR DYNAMIC), 0=NONE OF THESE ! ROUT:= 1 FOR ROUTINE OR FN OR MAP, =0 NONE OF THESE ! NAM := 2 FOR MAPS AND 'REFREFS',=1 FOR NAMES ,=0 DIRECTLY ADDRESSED ! ARR :=1 FOR ARRAYS =0 SCALARS ! PREC IS DESCRIPTOR SIZE CODE FOR EACH PRECISION:- ! :=0 BITS,=3 BYTES, =5 WORDS, =6 D-WRDS, =7,QUAD WRDS ! TYPE:= THE VARIABLE TYPE ! :=0 (TYPE GENERAL),=1 INTEGER, =2 REAL, =3 RECORD ! :=4 (RECORDFORMAT),=5 STRING, =6 LABEL/SWITCH. =7 NOT SET ! %routine UNPACK LITL = PTYPE>>14 ROUT = PTYPE>>12&3 NAM = PTYPE>>10&3 ARR = PTYPE>>8&3 PREC = PTYPE>>4&15 TYPE = PTYPE&15 %end %routine PACK(%integer %name PTYPE) PTYPE = (((((LITL&3)<<2!ROUT&3)<<2!NAM&3)<<2!ARR&3)<<4!PREC&15) %c <<4!TYPE&15 %end %end; ! OF ROUTINE CSS %integer %fn NEWTRIP !*********************************************************************** !* SETS UP A NEW TRIPLE AND LINKS IT IN !*********************************************************************** %record (TRIPF) %name CURRT %integer I CURRT == TRIPLES(NEXT TRIP) I = NEXT TRIP %if I>=WORKA_LAST TRIP %then i=1{FAULT(102,WORKA_WKFILEK,0)} NEXT TRIP = i +1 CURRT = 0 CURRT_BLINK = TRIPLES(0)_BLINK TRIPLES(0)_BLINK = I TRIPLES(CURRT_BLINK)_FLINK = I %result = I %end %integer %fn UCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST) !*********************************************************************** !* SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND * !*********************************************************************** %record (TRIPF) %name CURRT %integer CELL CELL = NEW TRIP CURRT == TRIPLES(CELL) CURRT_OPERN = OPERN CURRT_OPTYPE <- OPTYPE CURRT_FLAGS <- FLAGS CURRT_OPND1_PTYPE = X'51' CURRT_OPND1_D = CONST %result = CELL %end %integer %fn ULCONSTTRIP(%integer OPERN,OPTYPE,FLAGS,CONST1,CONST2) !*********************************************************************** !* SETS UP A UNARY TRIPLE WITH CONSTANT OPERAND * !*********************************************************************** %record (TRIPF) %name CURRT %integer CELL CELL = NEW TRIP CURRT == TRIPLES(CELL) CURRT_OPERN = OPERN CURRT_OPTYPE <- OPTYPE CURRT_FLAGS <- FLAGS CURRT_OPND1_PTYPE = X'61' CURRT_OPND1_D = CONST1 CURRT_OPND1_XTRA = CONST2 %result = CELL %end %integer %fn UNAMETRIP(%integer OPERN,OPTYPE,FLAGS,NAME) !*********************************************************************** !* SETS UP A UNARY TRIPLE WITH ONE NAME OPERAND * !*********************************************************************** %record (TAGF) %name TAGINF %record (TRIPF) %name CURRT %integer CELL TAGINF == ASLIST(TAGS(NAME)) CELL = NEW TRIP CURRT == TRIPLES(CELL) CURRT_OPERN = OPERN CURRT_OPTYPE <- OPTYPE CURRT_FLAGS <- FLAGS CURRT_OPND1_PTYPE = TAGINF_PTYPE CURRT_OPND1_FLAG = DNAME CURRT_OPND1_D = NAME CURRT_OPND1_XTRA = 0 %result = CELL %end %integer %fn UTEMPTRIP(%integer OPERN,OPTYPE,FLAGS,TEMP) !*********************************************************************** !* SETS UP A UNARY TRIPLE WITH LOCAL TEMPORARY OPND * !*********************************************************************** %integer CELL %record (TRIPF) %name CURRT CELL = NEWTRIP CURRT == TRIPLES(CELL) CURRT_OPERN = OPERN CURRT_OPTYPE <- OPTYPE CURRT_FLAGS <- FLAGS CURRT_OPND1_PTYPE = OPTYPE; CURRT_OPND1_FLAG = LOCALIR CURRT_OPND1_D = TEMP %result = CELL %end %routine KEEPUSECOUNT(%record (RD) %name OPND) !*********************************************************************** !* KEEPS PUSE AND CNT UP TO DATE * !*********************************************************************** %record (TRIPF) %name REFT REFT == TRIPLES(OPND_D) %if REFT_CNT=0 %then %start ! printstring("setting puse ") ! write(opnd_d,4); write(triples(0)_blink,4); write(reft_puse,3) ! newline REFT_PUSE = TRIPLES(0)_BLINK %finish REFT_CNT = REFT_CNT+1 %end %integer %fn URECTRIP(%integer OPERN,OPTYPE,FLAGS, %record (RD) %name OPND1) !*********************************************************************** !* SETS UP A BINARY TRIPLE WITH COMPLETE OPERANDS PROVIDED * !*********************************************************************** %integer CELL %record (TRIPF) %name CURRT CELL = NEWTRIP CURRT == TRIPLES(CELL) CURRT_OPERN = OPERN CURRT_OPTYPE <- OPTYPE CURRT_FLAGS <- FLAGS CURRT_OPND1 = OPND1 %if 1<>31; ! TOP BIT SET FOR MANUAL RETURN ! OTHERWISE NOTE IN TWSP LIST ! FOR AUTOMATIC RETURN SIZE = SIZE<<1>>1 %if SIZE>4 %then SIZE = 0 POP(CURRINF_AVL WSP(SIZE),J,K,L) %if K<=0 %then %start; ! MUST CREATE TEMPORARY %if size=4 %then l=rnding(128+x'72') %else %if Size=2 %c %then l=rnding(128+x'62') %else l=3 n=(n+L)&(\l) K = N %if SIZE=0 %then N = N+268 %else N = N+SIZE<<2 %finish PLACE = K PUSH(TWSPHEAD,K,SIZE,0) %unless F#0 %end %routine RETURN WSP(%integer PLACE,SIZE) !*********************************************************************** !* RETURNS WORKSPACE TO ORDERED FREE LIST. ADDRESSABLE CELLS * !* ARE PUT AT THE TOP. NON-ADDRESSABLE ON THE BACK * !*********************************************************************** %integer CELL IMPABORT %unless PLACE<=N %and PLACE&1=0 %if SIZE>4 %then SIZE = 0 CELL = CURRINF_AVL WSP(SIZE) %while CELL>0 %cycle IMPABORT %if ASLIST(CELL)_S2=PLACE CELL = ASLIST(CELL)_LINK %repeat %if PLACE<511 %then PUSH(CURRINF_AVL WSP(SIZE),0,PLACE,0) %else %c INSERT AT END(CURRINF_AVL WSP(SIZE),0,PLACE,0) %end %routine REUSE TEMPS %integer JJ,KK,QQ %while TWSPHEAD#0 %cycle POP(TWSPHEAD,JJ,KK,QQ) RETURN WSP(JJ,KK) %repeat %end %integer %fn FROMAR2(%integer PTR) %result = A(PTR)<<8!A(PTR+1) %end %integer %fn FROMAR4(%integer PTR) %integer I MOVE BYTES(4,ADDR(A(0)),PTR,ADDR(I),0) %result = I %end P2END: ! EXITS AFTER COMPILATION %end; ! OF SUBBLOCK CONTAINING PASS2 %end %end %of %file