!
! 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<<REFTRIP!1<<INDIRECT!1<<VIAPTR
CONSTINTEGER REFER NEEDED=1<<INDIRECT!1<<VIAPTR
!
! NOW THE DEFINITIONS OF ONE OPERAND TRIPLES <128
!
CONSTINTEGER RTHD=1; ! ROUTINE-BLOCK HEADING
CONSTINTEGER RDSPY=2; ! ROUTINE ENTRY SET DISPLAY
CONSTINTEGER RDAREA=3; ! ROUTINE LEAVE DIAGNOSTIC SPACE
CONSTINTEGER RDPTR=4; ! SET DIAGNOSTIC POINTER
CONSTINTEGER RTBAD=5; ! ROUTINE-FN BAD EXIT
CONSTINTEGER RTXIT=6; ! "%RETURN"
CONSTINTEGER XSTOP=7; ! EXECUTE "%STO"
CONSTINTEGER NOTL=10; ! LOGICAL NOT
CONSTINTEGER LNEG=11; ! LOGICAL NEGATE
CONSTINTEGER IFLOAT=12; ! CONVERT INTEGER TO REAL
CONSTINTEGER MODULUS=13; ! AS USED BY IMOD&RMOD
CONSTINTEGER SHRTN=14; ! SHORTEN TO LOWER PRECISION
CONSTINTEGER LNGTHN=15; ! LENGTHEN TO HIGHER PRECISION
CONSTINTEGER JAMSHRTN=16; ! SHORTEN FOR JAM TRANSFER
CONSTINTEGER NULLT=18; ! FOR REDUNDANT TRIPLES
CONSTINTEGER PRELOAD=19; ! PREFETCH FOR OPTIMISATION REASONS
CONSTINTEGER SSPTR=21; ! STORE STACK POINTER
CONSTINTEGER RSPTR=22; ! RESTORE STACK POINTER
CONSTINTEGER ASPTR=23; ! ADVANCE STACK PTR
CONSTINTEGER DARRAY=24; ! DECLARE ARRAY(IE STORE HD)
CONSTINTEGER SLINE=25; ! UPDATE LINE NO
CONSTINTEGER STPCK=26; ! CHECK FOR ZERO STEPS
CONSTINTEGER FORPRE=27; ! PREAMBLE FOR "FOR"
CONSTINTEGER FORPOST=28; ! POSTAMBLE FOR "FOR"
CONSTINTEGER FORPR2=29; ! FOR SECOND PREAMBLE
CONSTINTEGER PRECL=30; ! PREPARATION FOR CALL
CONSTINTEGER RCALL=31; ! THE CALL
CONSTINTEGER RCRFR=32; ! RECOVER FN RESULT
CONSTINTEGER RCRMR=33; ! RECOVER MAP RESULT
CONSTINTEGER GETAD=35; ! GET ADDRESS OF NAME
CONSTINTEGER RTOI1=36; ! REAL TO INTEGER AS INT
CONSTINTEGER RTOI2=37; ! REAL TO INTEGER INTPT
CONSTINTEGER ITOS1=38; ! INTEGER TO STRING AS TOSTRING
CONSTINTEGER MNITR=39; ! %MONITOR
CONSTINTEGER PPROF=40; ! PRINT PROFILE
CONSTINTEGER RTFP=41; ! TURN RT INTO FORMAL PARAMETER
CONSTINTEGER ONEV1=42; ! ON EVENT 1 PRIOR TO TRAP
CONSTINTEGER ONEV2=43; ! ON EVENT 2 AFTER TRAP
CONSTINTEGER DVSTT=44; ! START OF DOPE VECTOR
CONSTINTEGER DVEND=45; ! END OF DV EVALUATE TOTSIZE ETC
CONSTINTEGER FOREND=46; ! END OF FOR LOOP
CONSTINTEGER DMASS=47; ! assign via bim warning to opt only
CONSTINTEGER RTOI3=48; ! real to integer as TRUNC
!
! CODES FOR USER WRITTEN ASSEMBLER. NATURALLY THESE ARE NOT
! MACHINE INDEPENDENT
!
CONSTINTEGER UCNOP=50; ! FOR CNOPS
CONSTINTEGER UCB1=51; ! ONE BYTE OPERATIONS
CONSTINTEGER UCB2=52; ! FOR 2 BYTE OPERATIONE
CONSTINTEGER UCB3=53; ! FOR 3 BYTE OPERATIONS
CONSTINTEGER UCW=54; ! FOR WORD OPERATIONS
CONSTINTEGER UCBW=55; ! FOR OPC,BYTEWORD OPERATIONE
CONSTINTEGER UCWW=56; ! FOR OPC,WORD,WORD OPERAIONS
CONSTINTEGER UCLW=57; ! FOR LONGWORD OPERATIONS
CONSTINTEGER UCB2W=58; ! FOR OPC,B1,B2,WORD OPERATIONS
CONSTINTEGER UCNAM=59; ! FOR ACESS TO NAMES FROM ASSEMBLER
!
! NOW THE BINARY OPERATIONS
!
CONSTINTEGER ADD=128; ! ADDITION
CONSTINTEGER SUB=129; ! SUBTRACTION
CONSTINTEGER NONEQ=130; ! INTEGER NONEQUIVALENCE
CONSTINTEGER ORL=131; ! LOGICAL OR
CONSTINTEGER MULT=132; ! MULTIPLICATION
CONSTINTEGER INTDIV=133; ! INTEGER DIVISION
CONSTINTEGER REALDIV=134; ! REAL DIVISION
CONSTINTEGER ANDL=135; ! LOGICAL AND
CONSTINTEGER RSHIFT=136; ! LOGICAL RIGHT SHIFT
CONSTINTEGER LSHIFT=137; ! LOGICAL LEFT SHIFT
CONSTINTEGER REXP=138; ! REAL EXPONENTIATION
CONSTINTEGER COMP=139; ! COMPARISONS
CONSTINTEGER DCOMP=140; ! FIRST PART OF DSIDED(NEEDED?)
CONSTINTEGER VMY=141; ! VECTOR MULTIPLY
CONSTINTEGER COMB=142; ! COMBINE (IE ADD OF LA) ON VMY RESULTS
CONSTINTEGER VASS=143; ! VARAIABLE ASSIGN WITH CHECKING
CONSTINTEGER VJASS=144; ! VARIABLE JAMMED ASSIGN
CONSTINTEGER IEXP=145; ! INTEGER EXPONENTIAITION
CONSTINTEGER BADJ=146; ! BASE ADJUST ARRAY INDEX
CONSTINTEGER AINDX=147; ! INDEX ARRAY(COMBINE BS&IX)
CONSTINTEGER IFETCH=148; ! NO LONGER USED
CONSTINTEGER LASS=149; ! ASSIGN LOCAL TEMPORARY
CONSTINTEGER FORCK=150; ! VALIDATE FOR
CONSTINTEGER PRECC=151; ! PRELIMINARY CONNCATENATION
CONSTINTEGER CONCAT=152; ! CONCATENATION
CONSTINTEGER IOCPC=153; ! CALL IOCP
CONSTINTEGER PASS1=154; ! PRIMARY PARAMETER ASSIGNMENT
CONSTINTEGER PASS2=155; ! PARAMETER PASSING POINTER PARAMS
CONSTINTEGER PASS3=156; ! PARAMETERPASSING ARRAY PARAMETERS
CONSTINTEGER PASS4=157; ! PASS A FORMAL PROCEDURE
CONSTINTEGER PASS5=158; ! PASS AN UNTYPE(%NAME) PARAMETER
CONSTINTEGER PASS6=159; ! PASS STRFN OR RECFN RESULT AREA
CONSTINTEGER BJUMP=160; ! BACKWARDS JUMPS
CONSTINTEGER FJUMP=161; ! FORWARD JUMPS
CONSTINTEGER REMLB=162; ! REMOVE LAB FROM LABELIST
! NEEDS TO BE TRIPLE IF COMBINED
! LABEL LIST IS USED
CONSTINTEGER TLAB=163; ! TO ENTER A LABEL
CONSTINTEGER DCLSW=164; ! DECLARE A SWITCH ARRAY
CONSTINTEGER SETSW=165; ! SET A SWITCH TO "CA"
CONSTINTEGER GOTOSW=166; ! GO TO A SWITCH LABEL
CONSTINTEGER STRASS1=167; ! STRING GENERAL ASSIGNMET
CONSTINTEGER STRASS2=168; ! STRING FIXED LENGTH ASSNMENT
CONSTINTEGER STRJT=169; ! STRING JAM TRANSFER
CONSTINTEGER AHASS=170; ! ASSIGNMENT OF ARRAYHEADS
CONSTINTEGER PTRAS=171; ! ASSIGNMENT OF POINTERS
CONSTINTEGER MAPRES=172; ! ASSIGN MAPPING FN RESULT
CONSTINTEGER FNRES=173; ! ASSIGN FN RESULT
CONSTINTEGER SCOMP=174; ! STRING COMPARISON
CONSTINTEGER SDCMP=175; ! FIRST PART OF STRING D-SIDED
CONSTINTEGER PRES1=176; ! PRE RESOLUTION 1
CONSTINTEGER PRES2=177; ! PRE RESOLUTION 2
CONSTINTEGER RESLN=178; ! STRING RESOLUTION
CONSTINTEGER RESFN=179; ! RESOLUTION FINALE
CONSTINTEGER SIGEV=180; ! SIGNAL EVENT
CONSTINTEGER RECASS=181; ! WHOLE RECORD ASSIGNMENT
CONSTINTEGER AAINC=182; ! ARRAY ADDRESS ADJUST FOR
! RECORD RELATIVE TO ABSOLUTE
CONSTINTEGER AHADJ=183; ! MODIFY HEAD FOR MAPPING
CONSTINTEGER CTGEN=184; ! CREATE TYPE GENERAL PARAMETER
CONSTINTEGER GETPTR=185; ! POINTER FOR PASSING BY NAME
CONSTINTEGER SINDX=186; ! INDEX STRING IE CHARNO
! SAME AS AINDX FOR ALL TARGETS
! BUT PNX !
CONSTINTEGER ZCOMP=187; ! COMPARISONS WITH ZERO
! GENERATED BY OPTIMISER
CONSTINTEGER CLSHIFT=188; ! CONSTANT LOGICAL SHIFT
! GENERATED BY OPTIMISER
CONSTINTEGER CASHIFT=189; ! CONSTANT ARITHMETIC SHIFT
! GENERATED BYOPTIMISER
CONSTINTEGER DVBPR=190; ! GENERATE DV ENTRY FOR BOUND PAIR
CONSTINTEGER RSTORE=191; ! REGISTER TO STORE OPERATION
CONSTINTEGER MULTX=192; ! MULTIPLY AND EXTEND PRECISION
!
! RECORDFORMAT FOR ALL THE OPTION AND FLAG VARAIBLES
!
! amended to remove non-alined longreal prior to bootstrapping to gould
!
RECORDFORMAT PARMF(INTEGER BITS1,BITS2,TTOPUT,
BYTEINTEGER LET,DYNAMIC,LINE,TRACE,ARR,DBUG,CHK,DIAG,OPT,FREE,
LIST,CPRMODE,COMPILER,Z,Y,PROF,INHCODE,DCOMP,FAULTY,X,STACK,MAP,QUOTES,S2,
INTEGER LPOPUT,SP0)
RECORDFORMAT LEVELF(INTEGER RBASE, DIAGINF, RAL, FLAG, L, M, NMDECS, ONWORD, ONINF,
LABEL, JROUND, UNATT FORMATS, PSIZE, ENTRYAD, DISPLAY, AUXSBASE,
NAMES, SNMAX,SN,RESSIZE,CLEVEL,SET, iblkid, EXITLAB, CONTLAB, S3,
INTEGERARRAY AVL WSP(0:4))
IF 1<<host&unsignedshorts=0 START
RECORDFORMAT RD((INTEGER S1 OR SHORT PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR SHORT H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((SHORTINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
SHORTINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((SHORTINTEGER PTYPE,(SHORT UIOJ OR BYTE XB,FLAG),
SHORT SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH ELSE START
RECORDFORMAT RD((INTEGER S1 OR HALF PTYPE,BYTE XB,FLAG),
((INTEGER D OR REAL R),
INTEGER XTRA OR HALF H0,H1,H2,H3 OR BYTE B0,B1,B2,B3,B4,B5,B6,B7))
RECORDFORMAT TAGF((HALFINTEGER PTYPE,UIOJ,SNDISP,ACC,SLINK,KFORM OR C
INTEGER S1,S2,S3),INTEGER LINK)
RECORDFORMAT TRIPF(BYTE OPERN,OPTYPE,CNT,DPTH,
HALFINTEGER FLAGS,PUSE,FLINK,BLINK,INTEGER X1,
RECORD(RD) OPND1,OPND2)
RECORDFORMAT LISTF((HALFINTEGER PTYPE,(HALF UIOJ OR BYTE XB,FLAG),
HALF SNDISP,ACC,SLINK,KFORM OR INTEGER S1,S2,S3),INTEGER LINK)
FINISH
RECORDFORMAT WORKAF(INTEGER NNAMES,CCSIZE,DSIZE,ASL MAX,ASL CUR BTM,CONST PTR,
CONST BTM,LASTTRIP,WKFILEAD,WKFILEK,FILE ADDR,RELEASE,AASL0,CONST LIMIT,
RTCOUNT,ARTOP,AMAINEP,DICTBASE,OPTCNT,INCLHEAD,S2,S3,S4,
INTEGERNAME LINE,N,S5,STRING(9)LADATE,
BYTEINTEGERARRAYNAME CC,A,LETT,
INTEGERARRAYNAME WORD,TAGS,CTABLE,
RECORD(LEVELF)ARRAYNAME LEVELINF,
INTEGERARRAY PLABS,PLINK(0:31),
RECORD(LISTF)ARRAYNAME ASLIST)
!
! TRIPF_FLAGS SIGNIFY AS FOLLOWS
CONSTINTEGER LEAVE STACKED=2****0; ! SET LEAVE RESULT IN ESTACK
CONSTINTEGER LOADOP1=2****1; ! OPERAND 1 NEEDS LOADING
CONSTINTEGER LOADOP2=2****2; ! OPERAND 2 NEEDS LOADING
CONSTINTEGER NOTINREG=2****3; ! PREVENT REG OPTIMISNG
! OF TEMPS OVER LOOPS&JUMPS
CONSTINTEGER USE ESTACK=2****4; ! KEEP DUPLICATE IN ESTACK
CONSTINTEGER USE MSTACK=2****5; ! PUT DUPLICAT ON MSTACK
CONSTINTEGER CONSTANTOP=2****6; ! ONE OPERAND IS CONSTANT(FOR FOLDING)
CONSTINTEGER COMMUTABLE=2****7; ! OPERATION IS COMMUTABLE
CONSTINTEGER BSTRUCT=2****12; ! Proc contains inner blks or RTs
CONSTINTEGER USED LATE=2****13; ! I-RESULT USED AFTER LAB OR A LONG WAY AHEAD
CONSTINTEGER ASS LEVEL=2****14; ! ASSEMBLER LEVEL OPERATION
CONSTINTEGER DONT OPT=2****15; ! DONT DUPLICATE THIS RESULT
! USED FOR BYTE PTR & OTHER SODS!
!
RECORDFORMAT EMASFHDRF(INTEGER ENDRA,STARTRA,FBYTESIZE,W3,W4,W5,W6,W7)
! FORMAT FOR ARRAY HEADS
! %END %OF %FILE "ERCC07.TRIMP_TFORM1S"
const integer SNPT=X'1006'; ! SPECIALNAME PTYPE
const integer UNASSPAT=X'80808080'
const integer LABUSEDBIT=X'01000000'
const integer LABSETBIT=X'02000000'
const integer MAXDICT=X'100'; ! PARM MAXDICT BIT
!
integer I,K,DUMMYFORMAT,P1SIZE,STARSIZE,ASL,ARSIZE,OLDLINE,NEXTP,SNUM,
RLEVEL,NMAX,PLABEL,LEVEL,PROFAAD,LAST INST,LINE,N,BFFLAG,RBASE,Q,R,
FNAME,STMTS,FILE SIZE,BIMSTR,MAX ULAB,SFLABEL,NEXTTRIP
integer name SSTL,USTPTR
integer curlinead,nextlinead,currentSSalt
string (31) MAINEP
!
external integer array CAS(0:12)
external record (PARMF) PARM
external record (WORKAF) WORKA
if HOST=IBM or HOST=AMDAHL or HOST=IBMXA or HOST=Vax start
external integer map spec COMREG alias "s#comregmap"(integer N)
finish else if HOST=Gouldor Host=M88k or Host=RS6 or Host=MIPS then Start
externalintegermapspec COMREG (integer N)
else
external integer map spec COMREG alias "s#comreg"(integer N)
finish
const integer BYTESPERKFORSOURCE=256; ! FRACTION OF KB IN WK FILE
! THATS IS ALLOCATE FOR SOURCE (&LPUT)
begin
record (EMASFHDRF) name SHDR,WHDR
worka = 0
WORKA_FILE ADDR = COMREG(46); ! SOURCE FILE IF CLEAN
PARM = 0
PARM_BITS1 = COMREG(27)
PARM_BITS2 = COMREG(28)! MAXDICT
PARM_TTOPUT = COMREG(40)
PARM_LPOPUT = COMREG(23)
WORKA_WKFILEAD = COMREG(14)
COMREG(24) = 16; ! failure as return code
WHDR == RECORD(WORKA_WKFILEAD)
WORKA_WKFILEK = WHDR_FBYTESIZE>>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)
recordformat 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 i<opline_length-1 andc
('a'<=opline_l(i+1)<='z' or 'A'<=opline_l(i+1)<='Z' orc
'0'<=opline_l(i+1)<='9' or opline_l(i+1)='_') andc
('a'<=opline_l(i)<='z' or 'A'<=opline_l(i)<='Z' orc
'0'<=opline_l(i)<='9' or opline_l(i)='_')
if opline_l(i+1)='*' and opline_l(i)='/' then i=i-1
if opline_l(i+1)='/' and opline_l(i)='*' then i=i+1
if opline_l(i+1)='*' and opline_l(i+2)='/' then i=i+2
!printstring("locate2 "); write(opline_l(i),4); write(opline_l(i+1),4); newline
result=i+1
finish
repeat
result=opline_length
end
routine curly check(integer mode)
owninteger last linead
integer i,at
!printstring("checking curly"); write(nextlinead,6); write(curlinead,6)
!write(last linead,6); printsymbol(byteinteger(curlinead));
!printsymbol(byteinteger(curlinead+1)); printsymbol(byteinteger(curlinead+2));
!printsymbol(byteinteger(curlinead+3)); printsymbol(byteinteger(curlinead+4));newline
! %if nextlinead=curlinead %start
! i=curlinead
! i=i+1 %while byteinteger(i)=' '
! %if byteinteger(i)='{' %then warn(12,0)
! %finish
if nextlinead>curlinead 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<LB OR 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): ! <CMARK> <COMMENT TEXT>
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<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 then outsep
->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<<next stmntalt&(1<<6!1<<4!1<<18!1<<9)#0 then outsep
BEND: end
FORCE TRIPS if PARM_OPT=0
->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 CNT<NPARAMS
PTYPE = PTYPEP
if STRRESINWA=YES start; ! NEEDS FN RESULT DESC
unless 3#PTYPE&X'F0F'#5 then N = N+PTRSIZE(X'35')
! STR FNS RESULT PARAM IS STACKED
CURRINF_RESSIZE = N
finish
N = N+ALPHA; ! allow for link bytes on unix(etc)
if TARGET=PNX then start
IMPABORT if N&7#0
finish
! AS XTRA PARM JUST BEFORE DISPLAY
RDISPLAY(RTNAME)
BEND: end
Force trips if parm_opt=0; ! Problems if procname redeclared
! as new proc before entry code planted
->cssexit2
!
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)
integerfn 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 <RESTOFOWNDEC> 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<<TYPE&B'100110'#0 start; ! INTEGER & REAL & STRING
if EXTRN#0 then start
TAGDISP = PINITOWN(PTYPE,ACC,FCOPND,NAMTXT)
finish else TAGDISP = 0
finish
STORE TAG(K,LEVEL,0,J,SNDISP,ACC,TAGDISP,KFORM)
if EXTRN=0=NAM and 1<<TYPE&B'100110'#0 start
! CONST = LITERAL
LCELL == ASLIST(TAGS(K))
lcell_s1=lcell_S1!(copnd_ptype&8)<<16
LCELL_S2 = COPND_D
LCELL_S3 = COPND_XTRA
if TYPE=5 then start
LCELL_S2 = WORKA_ARTOP
WORKA_ARTOP = (WORKA_ARTOP+COPND_XTRA+4)&(-4)
finish
finish
P = MARK
repeat
->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
begin
shortinteger savedp, savedp2, savedptype
integer i;
integer count; count = 0
!GT: This is where arrays are declared. We want to adjust the base of
! each array if the lower bound is non-0 so that accesses to the array
! can use the natural bounds (which in Imp are not forced to start at 0)
! Ideally we would allow static declarations to remain static declarations,
! but this does not work for multi-dimensional arrays so these too will
! come off the heap for now
! Also dynamic arrays simply are not converted correctly at the moment, so
! this code takes care of that too.
! We must plant code at the end of each procedure to free the heap arrays
! Note if we use a mark/release scheme this can be very cheap.
! Remember to initialise if members given, and to initialise to zero otherwise
! (can be done in the allocate heap space procedure)
if format=0 start
savedptype = ptype&255
outextern(EXTRN)
outtype(savedptype,savekform)
for ii=dimen,-1,1 cycle
outsym('*') for i = 1,1,ii
outname(k);
outsym('_') and outint(ii) if ii#dimen
outsym(',') if ii#1
repeat
outsym(';'); outsym(NL)
outextern(EXTRN)
outstring("int ");
for ii=dimen,-1,1 cycle
outname(k);
outstring("_dim_")
outint(ii)
outsym(',') if ii#1
repeat
outsym(';'); outsym(NL)
for ii=dimen,-1,1 cycle
outname(k);
outsym('_') and outint(ii) if ii#dimen
p=ctable(savesndisp+3*ii+2)
savedp = p
outstring(" = (")
outtype(savedptype,savekform)
outsym('*') for i = 1,1,ii
outstring(")malloc(((")
csexp(x'51'); outsym(')')
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
outstring(") * sizeof(");
outtype(savedptype,savekform)
outsym('*') for i = 1,1,ii-1
outstring(") );"); outsym(NL);
if ctable(savesndisp+3*ii)=x'80000000'start
outname(k);
outsym('_') and outint(ii) if ii#dimen
outstring(" -= ");
p=ctable(savesndisp+3*ii+1)
csexp(x'51')
finish else if ctable(savesndisp+3*ii)#0 start
outname(k);
outsym('_') and outint(ii) if ii#dimen
outstring(" -= ");
outint(ctable(savesndisp+3*ii))
finish; ! otherwise based at 0 already
outsym(';'); outsym(NL);
outstring("for ("); outname(k)
outstring("_dim_"); outint(ii);
outstring(" = ")
if ctable(savesndisp+3*ii)=x'80000000'start
p=ctable(savesndisp+3*ii+1)
csexp(x'51')
finish else if ctable(savesndisp+3*ii)#0 start
outint(ctable(savesndisp+3*ii))
finish else outint(0);
outstring("; "); outname(k)
outstring("_dim_"); outint(ii);
outstring(" <= ")
csexp(x'51')
outstring("; "); outname(k)
outstring("_dim_"); outint(ii);
outstring("++) {"); outsym(NL);
repeat
for ii=1,1,dimen cycle
if ii#1 then start
outname(k);outsym('_') and outint(ii) if ii#dimen
outstring("["); outname(k)
outstring("_dim_"); outint(ii);
outstring("] = "); outname(k)
outsym('_'); outint(ii-1)
outstring(";"); outsym(NL)
finish else start
outstring("/* Assign initialised elements if any */"); outsym(NL)
finish
outsym('}'); outsym(NL)
repeat
outsym('{'); outsym(NL); ! for static decl after code!
outextern(EXTRN)
outtype(savedptype,savekform)
outname(k); outstring("_data[] ")
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 start
P = PP+1
count = INIT SPACE(QQ,SLENGTH)
finish
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)
/* if no init declarations, don't do this... */
outsym(NL);
outstring("int "); outname(k); outstring("_inels = 0;"); outsym(NL);
ACC = SACC; PTYPE = TYPEP; UNPACK
PP=p
%for ii=dimen,-1,1 %cycle
p=ctable(savesndisp+3*ii+2)
outstring("for ("); outname(k)
outstring("_dim_"); outint(ii);
outstring(" = ")
savedp = p;
! outstring(" /* 1:")
! csexp(x'51')
! outstring(" */ ")
%if ctable(savesndisp+3*ii)=x'80000000'%start
p=ctable(savesndisp+3*ii+1)
csexp(x'51')
%finish %else %if ctable(savesndisp+3*ii)#0 %start
outint(ctable(savesndisp+3*ii))
%finish %else outint(0);
outstring("; "); outname(k)
outstring("_dim_"); outint(ii);
outstring(" <= ")
p = savedp;
csexp(x'51')
outstring("; "); outname(k)
outstring("_dim_"); outint(ii);
outstring("++) {"); outsym(NL);
outstring("if (")
outname(k)
outstring("_inels == "); outint(count); outstring(") break;");outsym(NL)
%if ctable(savesndisp+3*ii)=x'80000000'%start
p=ctable(savesndisp+3*ii+1)
! outstring(" /* 2:")
! csexp(x'51')
! outstring(" */ ")
%finish
%repeat
outname(k)
%for ii=dimen,-1,1 %cycle
outstring("["); outname(k); outstring("_dim_")
outint(ii)
outstring("]")
%repeat
outstring(" = ")
outname(k)
outstring("_data[")
outname(k)
outstring("_inels++];"); outsym(NL)
%for ii=dimen,-1,1 %cycle
outstring("}"); outsym(NL);
%repeat
outsym('}'); outsym(NL); ! End of static init
%end; ! of tweak to make arrays based at non-0
->BEND
%integerfn 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
%integer nels out
nels out = 0
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
nels out = nels out + RF
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("}")
%result = nels out
%end
%routine XTRACT CONST(%integer CONTYPE,CONPREC)
!***********************************************************************
!* P POINTS TO P<+'> OF <+'><OPERNAD><RESTOFEXPR> 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 i<nextlinead cycle
outsym(byteinteger(i))
i=i+1
repeat
->CSSEXIT
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<FORMTAREF>::=(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<ARRAYINREC ROUNDING then c
RL = ARRAYINREC ROUNDING
cycle
ROUND
D1 = 0
SN(Q);! INC = INC+R
Q = Q+3
repeat until A(Q-1)=2; ! TILL NAMELIST NULL
P = P+1; Q = P+1
repeat until A(P-1)=2; ! UNTIL <RESTOFARRAYLIST> 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 <RESTOFRFDEC> 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 thenstart
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<<LEVEL
!
! NOW PLANT AN ERROR EXIT FOR FNS AND MAPS - CONTROL SHOULD BE RETURNED
! VIA %result= AN SHOULD NEVVER REACH THE %end INSTRUCTION
!
if KKK&X'3FFF'>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<KP<=MAX ULAB then FAULT(11,ASLIST(J)_S3&X'FFFF',KP)
CLEAR LIST(J)
finish else start
if I&LABUSEDBIT=0 and KP<MAX ULAB then WARN(3,KP)
finish
repeat
!
NMAX = (NMAX+7)&(-8)
CURRINF_SNMAX = NMAX
!
! FOR ROUITNE CHECK PARAMETER LIST FOR ARRAY PARAMETERS AND PASS
! BACK ANY INFORMATION ON DIMENSIONALAITY GLEANED DURING THE BODY
!
JJ = CURRINF_M-1; ! RT NALE
if JJ>=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<<host&unsignedshorts=0 start
record format HEADF(short RTLINE,LINEOFF,OFLAGS,ENV,
DISPLAY,RTFLAGS,(integer IDHEAD or string (11) RTNAME))
record format VARF(short FLAGS,DISP, string (11) VNAME)
finish else start
record format HEADF(half integer RTLINE,LINEOFF,OFLAGS,
ENV,DISPLAY,RTFLAGS,
(integer IDHEAD or string (11) RTNAME))
record format VARF(half integer FLAGS,DISP,
string (11) VNAME)
finish
record (HEADF) name DHEAD
record (VARF) name VAR
record (LISTF) name LCELL,scell
record(swdataform)name swdata
const integer LARRROUT=X'F300'
record (TAGF) T
integer DPTR,LNUM,ML,KK,JJ,Q,DEND,BIT,S4,LANGD,RULES,II
const integer DLIMIT=700
integer array DD(0:DLIMIT); ! BUFFER FOR SEGMENT OF SST
!
! FILL ALL OUTSTANDING REFERENCES TO THIS DIAGS BLOCK
!
BIT = 1<<LEVEL
LANGD = KKK>>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<=JJ<X'3FFF' cycle
LCELL == ASLIST(TAGS(JJ))
T = LCELL
! printstring("undeclaring"); printstring(printname(jj)); newline
! OBTAIN NEXT NAME FORM DECLNS
!
! GET ONLY THE MINIMUM OF DETALS NECESSARY
!
S4 = LCELL_LINK
PTYPE = T_PTYPE; TYPE = PTYPE&15
!
! FAULT ALL UNUSED NAMES EXCEPT CONSTINTEGERS&REALS
!
if (TYPE>2 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
DPTR<DLIMIT-3 and (1<=TYPE<=3 or TYPE=5) start
Q = ADDR(WORKA_LETT(WORD(JJ))); ! ADDRESS OF NAME
if I=0 then II = 1 else II = 0; ! GLA OR LNB BIT
VAR == RECORD(ADDR(DD(DPTR)))
VAR_FLAGS <- swopof(X'41',PTYPE<<4!II<<2)
if ((PARAMS BWARDS=YES and k<currinf_display) or (STACK DOWN=YES and k>Currinf_display))c
and PTYPE&X'C00'=0 and II=0 and c
(TYPE=3 or TYPE=5) start; ! VALUE RECS&STRS
if K<Currinf_display then rules=2 else rules=1
KK=rounding length(ptype,rules)
K = (K+T_ACC+kk)&(¬KK)
finish
VAR_DISP <- swopof(X'41', K)
if target=eamd and I#0 Then var_disp=k+64; ! frig so standard diags work
LOCAL NAME <- STRING(Q); ! TEXT OF NAME FROM DICTIONARY
LNUM = LENGTH(LOCAL NAME)
VAR_VNAME = LOCAL NAME; ! MOVE IN NAME
if HOST#TARGET and PARM_TRACE#0 then c
CHANGE SEX(ADDR(DD(0)),4*DPTR+4,LNUM+1)
DPTR = DPTR+(LNUM+8)>>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<ADECLN> IN *
!* *
!* P<ADECLN>=<NAMELIST> <BPAIR> <RESTOFDECLN> *
!* P<BPAIR> = '('<EXPR>':'<EXRR><RESTOFBP>*')' *
!* *
!* 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<TYPE>='%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 <QNAME'> *
!* P<QNAME'>='%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<RT>=%routine
TYPEP = LITL<<14!X'1000'
P = P+4; ! IGNORING ALT OF P(SPEC') and hole
finish else start; ! P<RT>=<TYPE><FNORMAP>
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<<target&emachine#0 then c
CXREF(STRING(AXNAME),3*PARM_DYNAMIC!EXTRN,PCHKWORD,JJ)
! %system & %external =STATIC
! UNLESS PARM DYNAMIC SET
! %dynamic = DYNAMIC
if TARGET=PERQ or TARGET=ACCENT then c
JJ = AXNAME-ADDR(A(WORKA_DICTBASE))
finish else start
if TARGET=PERQ or TARGET=ACCENT then c
JJ = WORKA_RTCOUNT and WORKA_RTCOUNT = WORKA_RTCOUNT+1
finish
if M=0 and RLEVEL=0 start
if PARM_CPRMODE=0 then PARM_CPRMODE = 2
if PARM_CPRMODE#2 then FAULT(56,0,KK)
finish
J = 15-M&1; PTYPE = TYPEP
STORE TAG(KK,LEVEL,RBASE,j,JJ,SACC,OPHEAD,SKFORM)
end
routine CFPLIST(integer name OPHEAD,NPARMS)
!***********************************************************************
!* COMPILE A FORMAL PARAMETER PART INTO A LIST OF PARAMETER TYPES *
!* P(FPP)='('{(HOLE)(FPDEL)(NAMELIST)(MARK)}*')',0. *
!* *
!* THE LIST OF PARAMETER LOOKS LIKE:- *
!* S1 = PTYPE FOR PARAM<<16!LNAME<<12!DIMENSION(DIMEN DEDUCED LATER)*
!* LNAME IS PARAMS LOCAL NAME *
!* S2 = PARAMETER OFFSET(SNDISP) <<16 ! ACC *
!* S3 = 0 (RESERVED FOR FPP OF RTS) *
!* *
!* ON ENTRY P IS AT ALT OF FPP (WHICH MAY BE NULL) *
!***********************************************************************
integer OPBOT,PP,INC,RL,RSIZE,CELL,PSIMPLE
record (LISTF) name LCELL
OPHEAD = 0; OPBOT = 0
NPARMS = 0; ! ZERO PARAMETERS AS YET
PSIMPLE = 1; ! NO COMPLEX PARAMS YET
while A(P)=1 cycle; ! WHILE SOME(MORE) FPS
PP = P+1+FROMAR2(P+1); ! TO NEXT FPDEL
P = P+3; ! TO ALT OF FPDEL
CFPDEL; ! GET TYPE & ACC FOR NEXT GROUP
PSIMPLE = 0 unless c
PTYPE=X'51' or (ROUT=ARR=0 and NAM=1 and 0<TYPE<=3)
if rout#0 Start
INC = RT PARAM SIZE
RL = ROUNDING LENGTH(RTPARAMPT,2)
finish else if ARR=1 then start
INC = AHEADSIZE;
RL = ROUNDING LENGTH(AHEADPT,2)
finish else if NAM=1 then start
INC = PTRSIZE(PTYPE&X'7F')
RL = PTRROUNDING(PTYPE&X'7F'+256)
finish else if STRVALINWA=YES and PTYPE=X'35' then start
INC = PTRSIZE(X'35')
RL = PTRROUNDING(256+X'35')
finish else if RECVALINWA=YES and PTYPE=X'33' then start
INC = PTRSIZE(X'33')
RL = PTRROUNDING(256+X'33')
finish else if TARGET=EMAS and PTYPE=X'33' then start
INC = ACC+8; ! ALLOW FOR DESCRPTR FOR IMP80%c
COMPATABILITY
RL = 3; ! STRICTLY ROUNDING LENGTH(X'33',2)
finish else INC = ACC and RL = ROUNDING LENGTH(PTYPE,2)
until A(P-1)=2 cycle; ! DOWN <NAMELIST> 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 RSIZE<MINPARAMSIZE %and %c
! LCELL_PTYPE&7<=2 %then INC = INC+MINPARAMSIZE-RSIZE
! ! MAINTAIN BYTES &SHORTS IN BTM
! ! OF WORDS FOR 2900&IBM ARCHITECTURE
! LCELL_SNDISP <- INC; ! THE PARAMETER OFFSET
! INC = INC+RSIZE
! OPBOT = LCELL_LINK
! %repeat
INC = (INC+RL+SFRAME MISALIGN)&(¬RL)-SFRAME MISALIGN
P = P+1
PRINT LIST(OPHEAD) if PARM_Z#0
PP = INC<<16!NPARMS
if (TARGET=IBM or TARGET=IBMXA or TARGET=AMDAHL) then c
PP = PP!PSIMPLE<<15
if NPARMS>0 then ASLIST(OPHEAD)_S3 = PP
PRINTLIST(OPHEAD) if PARM_Z#0
end
routine CFPDEL
!***********************************************************************
!* SET UP PTYPE & ACC FOR A FORMAL PARAMETER DEFINITION *
!* P<FPDEL>=<TYPE><%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<<target&riskmc#0 then N=(N+display rounding)&(¬display rounding)
CURRINF_DISPLAY = N
if DISPLAY NEEDED=YES start
N = N+DISPLAY C1*RLEVEL+DISPLAY C0; ! RESERVE DISPLAY SPACE
finish
TRIPNO = UCONSTTRIP(RDSPY,X'51',0,CURRINF_DISPLAY)
finish
!
! IF IN DIAGNOSTIC MODE PLANT CODE TO SAVE THE LINE & ROUTINE NO OF
! THE CALLING ROUTINE AND SET UP THE NEW BLOCK/ROUTINE IDENT NO.
!
if PARM_TRACE#0 start
if KK>=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<<Target & Riskmc#0; ! extra word here on risks
CURRINF_DIAGINF = N
N = N+4
!
! For risk and some others it is better to use words for line & diag pointers
! if half word access is slow.
!
if target=ORN or 1<<target&riskmc#0 then N=N+4
finish
finish
TRIPNO = UCONSTTRIP(RDPTR,X'51',0,LEVEL)
finish
OLDLINE = 0
SET LINE
!
! NORMALLY CODE IS PLANTED HERE TO CHECK PARAMETERS BUT I CANNOT
! SEE HOW TO DO THIS ON PERQ ARCHITECTURE. IT MAY BE IN THE QCODE ANYHOW
!
!
! CLAIM (THE REST OF) THE STACK FRAME
!
if KK>=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 <cond> %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 ELSEALT<NULL ELSE then PLABEL = PLABEL-1 and ELSELAB = PLABEL
P = MARKE+1
! CONDITIONAL&MERGE OR REPLACE
->ESW(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'<UI>
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<<ALT#0 then L3 = SFLABEL-1 and SFLABEL = L3
!
! UPDATE THE LINE NUMBER FOR ALTS 1 TO 3 ONLY
!
if 1<=ALT<=3 then SET LINE
!
! ENTER THE FIRST LABEL FOR ALL ALTS EXCEPT 3 & 6
!
! %if B'0110111'&1<<ALT#0 %then ELRES = ENTER LAB(L1,0)
->SW(ALT)
SW(0): ! %cycle
PP = FROM AR4(P)+10; ! TO UNTIL CLAUSE IF ANY
if A(PP)=1 start; ! %repeat %until <COND>
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'<RPOP_D<=X'7FFF' then c
RPOP_FLAG = 0 and PTYPE = MINAPT
REAL = 1 if TYPE=2
P = P+2; ->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<<TARGET&LINTAVAIL=0) or c
(D=7 and c=2 and 1<<TARGET&LLREALAVAIL=0) then FAULT(99,0,0)
if D>=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<MINAPT then c
CURRT_OPTYPE = MINAPT
! PREVENT OPTIMISING BYTE ARRAY SCALE
! AS THESE CREATE EXTRA WORD
! WHICH DEFEATS ALGORITHMS
if (TARGET=PERQ or TARGET=ACCENT or TARGET=PNX) and c
JJ=39 and XTRA>>20=1 then c
CURRT_FLAGS <- CURRT_FLAGS!DONT OPT
CURRT_X1 = XTRA
CURRT_OPND1 = OPND1
if 1<<OPND1_FLAG&BTREFMASK#0 then KEEP USE COUNT(OPND1)
if JJ>=128 then start
CURRT_OPND2 = OPND2
if 1<<OPND2_FLAG&BTREFMASK#0 then KEEP USE COUNT(OPND2)
finish
OPND1_FLAG = 8
OPND1_PTYPE = CURRT_OPTYPE
OPND1_D = CURR TRIP
finish
STK(STPTR) = OPERAND(COMM)
STPTR = STPTR+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<MINAPREC %then RPOP_PTYPE%c
=RPOP_PTYPE&X'FF0F'!(MINAPREC<<4)
PUSH(TMPHEAD,RPOP_S1,RPOP_D,INHEAD)
finish else start; ! AN OPERATOR
if JJ>=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<RPOP_D>>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<OPND2_PTYPE>>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<<target&Emachine=0 and OP=LNGTHN and OPND_PTYPE&255<MINAPT then c
OPND_PTYPE <- OPND_PTYPE&X'FF00'!MINAPT and return
RPOP = 0
RPOP_FLAG = OP
if OP=IFLOAT and OPND_PTYPE&255<MINAPT then c
OPND_PTYPE = MINAPT
OPND_PTYPE = OPND_PTYPE+PTYPECH(OP)
if 1<<target&Llrealavail=0 and op=ifloat c
and Opnd_ptype&255=X'72' then OPnd_ptype=opnd_ptype-x'10'
! float longinteger when longlongreal not available
INSERT AFTER(OPND_XTRA,RPOP_S1,OPND_PTYPE,0)
NOPS = NOPS+1
end
routine COERCET(integer RULES)
!***********************************************************************
!* RULES=1 BOTH OPERANDS INTEGER ELSE ERROR *
!* RULES=2 FORCE BOTH OPERAND TO BE OF TYPE REAL *
!* RULES=3 OPND1 ONLY TO BE REAL(FOR **) *
!* RULES=4 OPND2 TO BE OPND 1(ASSIGNMENT) *
!* RULES=15 BOTH OPERANDS TO BE OF LARGEST TYPE *
!***********************************************************************
integer PT1,PT2
record (RD) RPOP
RPOP = 0; RPOP_FLAG = 12; ! FLOAT
PT1 = OPND1_PTYPE&7;
PT2 = OPND2_PTYPE&7; if PT2=7 then PT2=1
if RULES=4 then PT1 = CELL_S2&7; ! ORIGINAL PT FOR ARRAYS%c
ETC
if PT1=7 then PT1=1
if (RULES=1 or RULES=15 or RULES=4) and PT1=1=PT2 then c
return
if RULES=1 or (RULES=4 and PT1=1) then c
FAULT(24,0,0) and return
if PT1=1 then AMEND(OPND1,IFLOAT)
if PT2=1 and (RULES=2 or RULES=4 or RULES=15) then c
AMEND(OPND2,IFLOAT)
end
routine COERCEP(integer RULES)
!***********************************************************************
!* RULES DEFINE COERCION AS FOLLOWS: *
!* RULES=1 FORCE OPND2 TO BE OPND1(ASSIGNMENT) *
!* RULES=2 OPERAND 1 TO BE 'STANDARD' INTEGER *
!* RULES=4 OPERAND 2 TO BE 'STANDARD' INTEGER *
!* RULES=5 AS RULES=1 BUT FOR <- ASSIGNMENT *
!* RULES=6 BOTH OPERANDS TO BE 'STANDARD' INTEGER *
!* RULES=7 OPND1>=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 PREC1<MINAPREC then c
PREC1 = MINAPREC and c
OPND1_PTYPE <- OPND1_PTYPE&X'FF0F'!(MINAPREC<<4)
if PREC2<MINAPREC then c
PREC2 = MINAPREC and c
OPND2_PTYPE <- OPND2_PTYPE&X'FF0F'!(MINAPREC<<4)
if RULES=7 start; ! FORCE SHIFT INTO 32 BIT MIN REG
RULES = 4
if PREC1=4 then AMEND(OPND1,LNGTHN) and PREC1 = 5
finish
if 2<=RULES<=4 start
if RULES<=2 then OPND == OPND1 else OPND == OPND2
if OPND_PTYPE&X'FF'>MINAPT then AMEND(OPND,SHRTN)
return
finish
if PREC1<PREC2 then c
TPREC = PREC2 and OPND == OPND1 else c
TPREC = PREC1 and OPND == OPND2
OPER = OPND_PTYPE
AMEND(OPND,LNGTHN) while OPND_PTYPE>>4&15<TPREC
end
end
end; ! OF ROUTINE EXPOP
integer fn CCOND(integer CTO,IU,FARLAB,JFLAGS)
!***********************************************************************
!* COMPILES <IU><SC><RESTOFCOND>%then<UI1>%else<UI2> *
!* 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 <SC> IN<HOLE><SC><RESTOFCOND> *
!* 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 <cond> %then %monitor
! extension, which maps to assert(!(<cond>))
!
! 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<SC> *
!***********************************************************************
!
! 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): ! <EXP><COMP><EXP><SECONDSIDE>
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): ! '('<SC><RESTOFCOND>')'
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 <RESTOFCOND> *
!***********************************************************************
integer ALT,ALTP
ALT = A(P); ! 1=%and<ANDC>,2=%or<ORC>,3=NULL
P = P+1
if ALT¬=3 then start; ! NULL ALTERNATIVE NOTHING TO DO
until ALTP=2 cycle; ! UNTIL NO MORE <SC>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<<Target&LINTAVAIL=0 then c
errno=99 and ->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 <ENAME>
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(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(4): ! SKIP SYMBOL
outstring("(void)fgetc(in_file)")
P = P+2 { DON'T KNOW HOW MUCH TO ALTER P BY }; ->OKEXIT
ADHOC(8): ! NEXT SYMBOL
P = P+6;
CNAME(1);
outstring("ungetc(fgetc(in_file), in_file)")
P = P+2; ->OKEXIT
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<<TARGET&LLREALAVAIL=0 and JJ=X'72' then JJ = X'62'
if 1<<TARGET&LINTAVAIL=0 and JJ=X'61' then JJ = X'51'
CSEXP(JJ)
P = P+1
NAMEOPND = EXPOPND
->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
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
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 %<TYPE>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 }
!GT: remove the correction for the lower bound from array accesses
! because we now do the correction at the point of declaration
if LB=x'80000000' start
!GT: outstring("-(")
!GT: p=Ctable(DVDP+1); csexp(x'51'); outsym(')')
finish else if lb>0 start
!GT: outsym('-'); outint(LB)
finish else if LB=0 start
! outint(LB)
finish else if LB<0 start
!GT: 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 NPARMS<PSPECED start
if PARAMS BWARDS=YES then c
ARP(PSPECED-NPARMS) = P else ARP(NPARMS+1) = P
finish
NPARMS = NPARMS+1
SKIP EXP
repeat
OUTP = P
if PSPECED#NPARMS then start
! WRONG NO OF PARAMETERS GIVEN
if PSPECED=0 then ERRNO = 17 else start
if NPARMS<PSPECED then ERRNO = 18 else ERRNO = 19
finish
FAULT(ERRNO,IMOD(PSPECED-NPARMS),RTNAME)
SKIP APP; P = P-1
NAMEOPND = 0; NAMEOPND_PTYPE = X'51'; ! ENSURE SENSIBLE%c
RESULT TRIPLE
->OVER
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<OPERAND>
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<APP> 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; ! <APP> 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<<target&riskmc#0 Then Offset=Offset+2
I = UCONSTTRIP(SLINE,X'41',0,LINE<<16!Offset)
if PARM_PROF#0 then start
I = PROFAAD+4+4*LINE
finish
end
routine STORE TAG(integer KK,LEVEL,RBASE,J,SNDISP,ACC,SLINK,KFORM)
integer Q,I,TCELL
record (TAGF) name LCELL
TCELL = TAGS(KK)
!
! above line to stop local and routine having the same name
!
Q = LEVEL<<8!RBASE<<4!J
IMPABORT unless (KFORM!ACC)>>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<<OPND1_FLAG&BTREFMASK#0 then KEEPUSECOUNT(OPND1)
result = CELL
end
integer fn BRECTRIP(integer OPERN,OPTYPE,FLAGS,
record (RD) name OPND1,OPND2)
!***********************************************************************
!* 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
CURRT_OPND2 = OPND2
if 1<<OPND1_FLAG&BTREFMASK#0 then KEEP USE COUNT(OPND1)
if 1<<OPND2_FLAG&BTREFMASK#0 then KEEP USE COUNT(OPND2)
result = CELL
end
routine GET WSP(integer name PLACE, integer SIZE)
!***********************************************************************
!* FIND OR CREATE A TEMPORARY VARIABLE OF 'SIZE' WORDS *
!***********************************************************************
integer J,K,L,F
F = SIZE>>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