BEGIN MODE TAGLIST = REF STRUCT (INT tag, TAGLIST next) , MODEPT = REF MODESC , PRIMODE = REF STRUCT (INT type,length) , REFMODE = REF STRUCT (MODEPT deref, deflex) , MNODE = STRUCT (MODEPT first, MLIST next) , MLIST = REF MNODE , ROWS = REF STRUCT (INT dim # dim<0: FLEX #, MODEPT comp mode) , PROCMODE = REF STRUCT (MLIST params, MODEPT result) , STRUCTMODE = REF STRUCT (TAGLIST tags, MLIST fields) , HDDEF = STRUCT(MODEPT hd) , MODEKIND = UNION (PRIMODE, REFMODE, ROWS, PROCMODE, STRUCTMODE, MLIST #union# ,VOID #undefined#, HDDEF, MODEPT) , ID = STRUCT ( INT name,range ) , MODESC = STRUCT ( INT place #in table#, MODEKIND mode , INT line, ID ident ) , MLIST empty mlist=NIL, MODEPT no mode=NIL, TAGLIST no tags=NIL ; OP + = (REF MLIST u) BOOL: (u:=next OF u)ISNT empty mlist , + = (REF TAGLIST t) BOOL: (t:=next OF t)ISNT no tags ; INT max modes=93; INT no name=-1, no range=0 , LOC [max modes] MODEPT mode, LOC [-1:max modes-1] MODEPT mode hash , LOC INT first union,last mode:=0, LOC INT last hash:=-1 ; FOR i FROM -1 TO max modes-1 DO mode hash[i]:=NIL OD ; OP LENGTH = (MLIST mm)INT: ( LOC INT l:=0; LOC MLIST m:=mm ; WHILE m ISNT empty mlist DO +m; l+:=1 OD; l ) ; PROC prim = (MODEPT m)PRIMODE: (mode OF m|(PRIMODE p): p) , refmode = (MODEPT m)REFMODE: (mode OF m|(REFMODE r): r) , rows = (MODEPT m)ROWS: (mode OF m|(ROWS r): r) , proc = (MODEPT m)PROCMODE: (mode OF m|(PROCMODE p): p) , struct = (MODEPT m)STRUCTMODE: (mode OF m|(STRUCTMODE s): s) , union = (MODEPT m)MLIST: (mode OF m|(MLIST u): u) , head to = (MODEPT m)HDDEF: (LOC HDDEF h; hd OF h:=m; h) ; PROC kind code = (MODEKIND m)INT: ( m | (PRIMODE p): type OF p , (REFMODE): 11, (ROWS):12, (PROCMODE):13, (STRUCTMODE): 14, (MLIST):15 ) ; OP = = (ID a,b)BOOL: name OF a=name OF b & range OF a=range OF b ; PROC new mode = (INT hash key,MODEKIND m) MODEPT: BEGIN ( (last mode+:=1)>=max modes | error("Mode table overflow") ) ; mode hash[hash key]:=mode[last mode]:=HEAP MODESC:= (last mode,m,line nr,(no name,no range)) END ; PROC new mode decl = (INT name,range)VOID: BEGIN LOC INT h:=(14*name+92*range)MOD max modes ; WHILE mode hash[h] ISNT no mode DO h:=(h+31)MOD max modes OD ; MODEPT m=new mode(h,EMPTY); ident OF m:= (name,range) ; last hash:=-1 # last hash should never be user defined mode # END ; PROC get mode = (INT name,range) MODEPT: IF range<0 THEN INT x=range+prim offset; make prim(x OVER 256, x MOD 256) ELSE LOC INT h:=(14*name+92*range)MOD max modes, LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO ( ident OF x=ID(name,range) | GO TO found ); h:=(h+31)MOD max modes OD ; error("System error get mode"); ~ EXIT found: x FI ; PROC assign mode = (MODEPT dest,value)VOID: CASE mode OF dest IN (VOID): # normal case: assigning to undefined mode # CASE line OF dest:=line nr; mode OF value IN (VOID): (mode OF dest:=value; mode OF value:=head to(dest)) #pair# , (HDDEF h): (mode OF dest:=hd OF h; mode OF value:=head to(dest)) , (MODEPT m): (mode OF dest:=m; mode OF value:=dest) # insert in list # OUT mode OF dest:=mode OF value # very normal case: RHS is defined # ; IF value IS mode hash[last hash] THEN # optimise by discarding most recent mode; repoint mode hash # IF value ISNT mode[last hash-:=1] THEN print(("Strange last mode!!",newline)) ELSE mode hash[last hash]:=dest; last hash:=-1 FI FI ESAC , (HDDEF h): # definition of last mode in cycle # CASE line OF dest:=line nr; mode OF value IN (VOID): (mode OF dest:=value; mode OF value:=h) #new head after dest# , (HDDEF hh): (mode OF dest:=hd OF hh; mode OF value:=h) #splice# , (MODEPT m): (mode OF dest:=m; mode OF value:=hd OF h) #splice# OUT LOC MODEPT p:=dest,q:=hd OF h ; WHILE mode OF p:=mode OF value; q ISNT dest DO q:=(mode OF (p:=q) | (MODEPT m): m) OD ESAC , (PRIMODE p): print(("In line ",whole(line nr,0) ," illegal redefinition of primitive mode ", mode name[type OF p] ,".", newline)) OUT print(("In line ",whole(line nr,0) ," redefinition of mode ",hash tab[name OF ident OF dest] ," in line ",whole(line OF dest,0),".", newline)) ESAC ; PROC make prim = (INT type,length)MODEPT: BEGIN LOC INT h:=(61*type+length)MOD max modes, LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (PRIMODE p): (type OF p=type AND length OF p=length | GOTO found ) ESAC ; h:=(h+37) MOD max modes OD ; new mode(h,HEAP STRUCT(INT type,length):=(type,length)) EXIT found: x END ; PROC make ref = (MODEPT m)MODEPT: BEGIN LOC INT h:=(17*place OF m+43)MOD max modes, LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (REFMODE r): (deref OF r IS m | GOTO found ) ESAC ; h:=(h+23) MOD max modes OD ; new mode(h,HEAP STRUCT(MODEPT deref,deflex):=(m,no mode)) EXIT found: x END ; PROC make row = (INT dim,MODEPT m)MODEPT: BEGIN LOC INT h:=(58*dim+12*place OF m+77)MOD max modes, LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (ROWS r): (dim OF r=dim AND (comp mode OF r IS m) | GOTO found ) ESAC ; h:=(h+89) MOD max modes OD ; new mode(h,HEAP STRUCT(INT dim,MODEPT comp mode):=(dim,m)) EXIT found: x END ; PROC mlist cons = (MODEPT h, MLIST t)MLIST: HEAP MNODE:=(h,t) ; PROC mlist snoc = (MLIST h, MODEPT t)MLIST: BEGIN LOC MLIST head:=h; LOC REF MLIST p:=head ; WHILE p ISNT empty mlist DO +p OD ; REF MLIST(p):=HEAP MNODE:=(t,empty mlist); head END ; PROC list hash = (MLIST modes,INT code)INT: IF modes IS NIL THEN code ELSE LOC INT h:=code, LOC MLIST p:=modes ; WHILE h:=(7*h+13*place OF first OF p)MOD max modes; +p DO~OD; h FI ; OP = = (MLIST a,b)BOOL: IF (a:=:NIL) OR (b:=:NIL) THEN a :=: b ELSE LOC MLIST p:=a,q:=b ; WHILE ( MODEPT(first OF p) IS first OF q | +p AND +q | FALSE ) DO~OD ; p :=: q # IS empty mlist # FI ; PROC make proc = (MLIST params,MODEPT result)MODEPT: BEGIN LOC INT h:=(list hash(params,19)+68*place OF result)MOD max modes , LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (PROCMODE p): ( params OF p=params AND (result OF p IS result) | GOTO found ) ESAC ; h:=(h+44) MOD max modes OD ; new mode(h,HEAP STRUCT(MLIST params,MODEPT result):=(params,result)) EXIT found: x END ; PROC tag cons = (INT h, TAGLIST t)TAGLIST: HEAP STRUCT (INT tag, TAGLIST next):=(h,t) ; PROC tags hash = (TAGLIST tags,INT code)INT: IF tags:=:NIL THEN code ELSE LOC INT h:=code, LOC TAGLIST p:=tags ; WHILE h:=(7*h+13*tag OF p)MOD max modes; +p DO~OD; h FI ; OP = = (TAGLIST a,b)BOOL: ( LOC TAGLIST p:=a, q:=b ; WHILE ( tag OF p = tag OF q | +p AND +q | FALSE ) DO~OD; p:=:q ) ; PROC make struct = (TAGLIST tags,MLIST fields)MODEPT: BEGIN LOC INT h:=(tags hash(tags,47)+list hash(fields,11))MOD max modes , LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (STRUCTMODE s): ( tags OF s=tags AND fields OF s=fields | GOTO found ) ESAC ; h:=(h+71) MOD max modes OD ; new mode(h,HEAP STRUCT(TAGLIST tags,MLIST fields):=(tags,fields)) EXIT found: x END ; PROC make union = (MLIST moods)MODEPT: BEGIN LOC INT h:=list hash(moods,1), LOC MODEPT x ; WHILE (x:=mode hash[h]) ISNT no mode DO CASE mode OF x IN (MLIST u): ( u=moods | GOTO found ) ESAC ; h:=(h+39) MOD max modes OD ; new mode(h,moods) EXIT found: x END ; PROC is void = (MODEPT m)BOOL: (mode OF m | (PRIMODE p): type OF p=void | FALSE ) ; PROC has void = (MLIST l)BOOL: ( LOC MLIST p:=l ; WHILE p ISNT empty mlist DO IF is void(first OF p) THEN GO TO true FI OD ; FALSE EXIT true: TRUE ) ; PROC simple mode checks = BOOL: BEGIN LOC INT i:=0, LOC BOOL failure:=FALSE, LOC MODEPT m, LOC INT dim ; WHILE ((i:=i+1)<=last mode) DO MODEPT mode i=mode[i]; line nr:=line OF mode i ; CASE mode OF mode i IN (REFMODE ref): CASE IF is void(m:=deref OF ref) THEN GO TO wrong mode FI ; mode OF m IN (ROWS row): IF MODEPT c=comp mode OF row; (dim:=dim OF row)<=0 # REF FLEX # THEN make ref(( dim=0 | c | make row(-dim,c) )) ELSE make ref(( dim=1 | c | make row(dim-1,c) )) ; CASE mode OF c IN (STRUCTMODE s): # ref-row-selection possible # ( LOC MLIST l:=fields OF s ; WHILE make ref(make row(dim,first OF l)); +l DO~OD ) ESAC FI , (STRUCTMODE s): # ref-selection possible # ( LOC MLIST l:=fields OF s; WHILE make ref(first OF l); +l DO~OD ) ESAC , (PROCMODE p): IF has void(params OF p) THEN GO TO wrong mode FI , (STRUCTMODE s): IF has void(fields OF s) THEN GO TO wrong mode FI , (ROWS row): BEGIN IF is void(m:=comp mode OF row) THEN GO TO wrong mode FI ; IF (dim:=dim OF row)=0 # FLEX # THEN LOC ROWS t ; ( (mode OF m | (ROWS r): dim OF (t:=r)>0 | FALSE) | row:=(-dim OF t,comp mode OF t) | GO TO wrong mode ) ELIF dim>1 THEN make row(dim-1,m) # slices possible # FI ; CASE mode OF m IN (STRUCTMODE s): # row-selection possible # ( LOC MLIST l:=fields OF s; WHILE make ref(first OF l); +l DO~OD ) ESAC END , (MLIST): ( print("Circularly defined mode "); print mode line(mode i) ; failure:= TRUE ) , (UNION(HDDEF,VOID)): ( undef mode: print("Undefined mode!?? "); print mode line(mode i) ; failure:=TRUE ) ESAC EXIT wrong mode: print("Forbiden mode "); print mode explicit(mode i) ; failure:=TRUE OD ; failure END ; PROC ravel = BOOL: BEGIN MODE ST=BITS , LOC [max modes] ST stat, LOC [max modes] INT defl , ST o=2r0, i=2r1, mask=2r11111 ; ST ravelled=i , yin=i SHL 1, yang=i SHL 2, deflexed=i SHL 3, reflexed=i SHL 4 ; PRIO &:= = 1 , OP &:= = (REF ST d,ST s)REF ST: d:=d AND s , +:= = (REF ST d,ST s)REF ST: d:=d OR s , -:= = (REF ST d,ST s)REF ST: d:=d AND ~s ; PROC all = (ST s, MLIST l)ST: ( LOC MLIST p:=l, LOC ST st:=s ; WHILE (st/=o AND (p ISNT empty mlist)) DO st &:= stat[place OF first OF p]; +p OD ; st ) ; PROC reflex = (REF MODEPT m)VOID: m:=mode[defl[place OF m]] ; FOR i TO last mode DO stat[i]:= CASE mode OF mode[i] IN (PRIMODE): mask # all possible attributes # , (REFMODE): ravelled OR yin OR deflexed , (PROCMODE p): ravelled OR yin OR deflexed OR ( params OF p:/=:empty mlist | yang | o ) , (STRUCTMODE): ravelled OR yang OR reflexed , (ROWS): ravelled OR reflexed , (MLIST): deflexed OUT print(("System error ravel.",newline)); ~ ESAC OD ; LOC BOOL changed, LOC INT unfinished, runs:=0 ; WHILE # changed AND unfinished>0 # changed:=FALSE; unfinished:=0; runs+:=1; LOC INT i:=0 ; WHILE LOC ST new st:=mask; (i+:=1)<=last mode DO IF (new st-:=stat[i])/=o # otherwise there is nothing to gain # THEN ( (stat[i]&reflexed)=o | new st -:= reflexed +:= deflexed ) ; CASE MODEPT m=mode[i]; mode OF m IN (REFMODE r): IF ((new st &:= stat[place OF deref OF r])&deflexed)/=o THEN reflex(deflex OF r:=deref OF r) FI , (PROCMODE p): IF LOC MLIST q:=params OF p ; ((new st:=all(new st&stat[place OF result OF p],q))&deflexed)/=o THEN # time to reflex p, replacing its components by deflexings # WHILE q:/=:empty mlist DO reflex(first OF q); +q OD ; reflex(result OF p) FI , (STRUCTMODE s): IF LOC MLIST f:=fields OF s ; ((new st:=all(new st,f))&deflexed)/=o THEN LOC MLIST head; LOC REF MLIST p:=head ; WHILE REF MLIST(p):=HEAP MNODE; reflex(first OF p:=first OF f) ; p:=next OF p; (f:=next OF f) ISNT empty mlist DO ~ OD ; INT j=defl[i]:=place OF make struct(tags OF s,head) ; ( mode[j] IS mode hash[last hash] # newly created struct mode # | line OF mode[j]:=line OF m; ident OF mode[j]:=ident OF m ) ; defl[j]:=j; stat[j]:=stat[i] FI , (ROWS r): IF INT c=place OF comp mode OF r; ((new st&:=stat[c])&deflexed)/=o THEN INT j=defl[i]:=place OF make row(ABS dim OF r,mode[defl[c]]) ; ( mode[j] IS mode hash[last hash] # newly created row mode # | line OF mode[j]:=line OF m; ident OF mode[j]:=ident OF m ) ; defl[j]:=j; stat[j]:=stat[i] FI , (MLIST u): ( IF ((new st:=all(new st,u))&ravelled)/=o # then expand moods # THEN LOC MLIST p:=u ; WHILE CASE mode OF first OF p IN (MLIST v): ( MLIST next=next OF p; MLIST(p):=v #copy 1st node# ; WHILE next OF p ISNT empty mlist #duplicate in front of p# DO p:=next OF p:=HEAP MNODE:=next OF p OD ; next OF p:=next #reattach old tail# ) ESAC ; +p DO ~ OD FI ; IF (new st&deflexed)/=o THEN LOC MLIST p:=u ; WHILE first OF p:=mode[defl[place OF first OF p]]; +p DO~OD FI ) ESAC ; IF new st/=o THEN ( (new st&deflexed)/=o | new st +:= reflexed ) ; stat[i] +:= new st; changed:=TRUE FI ; IF stat[i]/=mask THEN unfinished+:=1 FI FI OD ; changed AND unfinished>0 DO ~ OD ; print(("Mode check complete after ",whole(runs,0) ," run",(runs=1|""|"s"),".",newline)) ; IF unfinished>0 THEN print(("Ill structured mode",(unfinished>1|""|"s"),":",newline)) ; FOR i TO last mode DO IF ST x=stat[i]; x/=mask THEN print("Mode "); print mode(mode[i]); print((" defined at line ",whole(line OF mode[i],0)," lacks " ,((x&yin)/=o | "yang" |: (x&yang)/=o | "yin" | "yin and yang") ,".",newline)) FI OD FI ; unfinished>0 END ; PROC deflex = (MODEPT m)MODEPT: # call after deflex loops are ruled out # CASE mode OF m IN (ROWS r): make row(ABS dim OF r, deflex(comp mode OF r)) , (STRUCTMODE s): make struct(tags OF s, deflex list(fields OF s)) , (UNION(MODEPT,HDDEF)): (print(("System error deflex",newline)); ~) OUT m ESAC ; PROC deflex list = (MLIST l)MLIST: ( l IS NIL | l | HEAP MNODE:=(deflex(first OF l),deflex list(next OF l)) ) ; PROC cmp heads = # compare modes by their heads only # (MODEPT a,b) INT: # -1: ab # ( INT cmp = SIGN(kind code(a)-kind code(b)); cmp/=0 | cmp | CASE mode OF a IN (PRIMODE x): SIGN(length OF x-length OF prim(b)) , (ROWS x): SIGN(dim OF x-dim OF rows(b)) , (PROCMODE x): SIGN(LENGTH params OF x-LENGTH params OF proc(b)) , (STRUCTMODE x): ( STRUCTMODE y=struct(b); TAGLIST end=NIL ; LOC TAGLIST p:=tags OF x, q:=tags OF y ; WHILE ( tag OF p = tag OF q | +p AND +q | FALSE ) DO~OD ; (p:=:no tags) OR (q:=:no tags) | ABS(q:=:no tags)-ABS(p:=:no tags) |: hash tab[tag OF p]=4 , OP <> = (REF MODEPT x,y)VOID: ( x:/=:y | MODEPT m=x; x:=y; y:=m) ; PROC qs = (INT l,u, PROC(MODEPT,MODEPT)INT cmp)VOID: ( MODEPT split=mode[l], INT last less:=l-1, i:=l+1, first high:=u+1 ; WHILE (imode[i]; i+:=1 |: c>0 | mode[first high-:=1]<>mode[i] | i+:=1 ) OD ; ( last less>l | qs(l,last less,cmp) ) ; ( first high1 | qs(1,last mode,cmp heads) ) ; LOC INT i:=0, LOC REF REF CLASS p:=classes ; WHILE (i+:=1)<=last mode DO place OF mode[i]:=i ; IF cmp heads(mode[i],mode[i+1])=0 THEN LOC INT j:=i+1 ; WHILE place OF mode[j]:=i ; ( jb # CASE mode OF a IN (PRIMODE): 0 , (REFMODE x): deref OF x ? deref OF refmode(b) , (ROWS x): comp mode OF x ? comp mode OF rows(b) , (PROCMODE x): ( PROCMODE y = proc(b); INT c = result OF x? result OF y; c/=0 | c | cmp mlists(params OF x,params OF y) ) , (STRUCTMODE x): cmp mlists(fields OF x,fields OF struct(b)) , (MLIST x): IF LOC MLIST p:=x, q:=union(b), LOC INT cmp ; OP ! = (REF MLIST r)BOOL: # r->next different place; success # ( INT p=place OF first OF r ; WHILE ( +r | place OF first OF r=p | FALSE ) DO ~ OD ; r ISNT empty mlist ) ; WHILE ( (cmp:=first OF p?first OF q)=0 | !q AND !p | FALSE ) DO ~ OD ; cmp/=0 THEN cmp ELSE ABS(q:=:empty mlist)-ABS(p:=:empty mlist) FI ESAC ; PROC sort modes = BOOL: # return TRUE on failure # BEGIN LOC BOOL global changes:=TRUE, failure:=FALSE ; WHILE # global changes AND(classes:/=:none) # FOR i FROM first union TO last mode # sort the moods within unions # DO LOC MLIST head:=union(mode[i]) ; WHILE LOC BOOL changes:=FALSE, LOC REF MLIST rover:=head ; WHILE MLIST next=next OF rover; next ISNT NIL DO # bubble: push maximal element forward # IF first OF rover ? first OF next > 0 THEN # swap: # next OF rover:=next OF next; next OF next:=rover ; REF MLIST(rover):=next; changes:=TRUE FI ; rover := next OF rover OD ; changes DO ~ OD # bubble sort # ; mode OF mode[i]:=head # reinstall possibly modified head # OD # FOR i # ; global changes AND (classes ISNT none) DO global changes:=FALSE; LOC REF REF CLASS cur class:=classes ; # traverse the classes: # WHILE # cur class ISNT none: traverse the current class: # IF ( FOR i FROM first OF cur class + 1 TO last OF cur class DO IF cmp places(mode[i-1],mode[i])/=0 THEN GO TO different FI OD ; FALSE EXIT different: TRUE ) THEN qs(first OF cur class,last OF cur class,cmp places) ; global changes:=TRUE # Now split up the current class: # ; FOR i FROM first OF cur class + 1 TO last OF cur class DO IF cmp places(mode[i-1],mode[i])<0 THEN first OF (cur class:=next OF (REF REF CLASS(cur class):= HEAP CLASS:= (first OF cur class, i-1, cur class))):=i FI OD FI ; (cur class := next OF cur class) ISNT none DO ~ OD ; cur class := classes # adjust places, and remove singleton classes: # ; WHILE FOR i FROM first OF cur class TO last OF cur class DO place OF mode[i] := first OF cur class OD ; IF first OF cur class = last OF cur class THEN REF REF CLASS(cur class):=next OF cur class # link out # ELSE cur class:=next OF cur class FI :/=: none DO ~ OD OD # WHILE global changes... # ; IF classes ISNT none THEN print(( "Class",(next OF classes IS none | "" | "es") ," of equivalent modes found:",newline )) ; WHILE # classes ISNT none # FOR i FROM first OF classes TO last OF classes DO print("Mode "); print mode(mode[i]) ; print((" defined at line ", line OF mode[i],".",newline)) OD ; print(newline); (classes:=next OF classes)ISNT none DO ~ OD FI # now remove duplicate moods, and check for incest # ; FOR i FROM first union TO last mode DO MLIST u=union(mode[i]) ; LOC MLIST p:=u,next:=next OF u, LOC INT n:=1 ; ( next :=: empty mlist | print(("UNION must be united from at least 2 modes:",newline)) ; print mode line(mode[i]); GO TO fail ) ; WHILE ( place OF first OF p = place OF first OF next | next OF p := next OF next # link out # | p:=next # move on # ) ; +next DO ~ OD ; ( p :=: u # never moved on # | print(("All consitituents of UNION are equivalent:",newline)) ; print mode line(mode[i]); GO TO fail ) ; p:=u # Now scrutinise each mood for incestuous relations # ; WHILE # p ISNT empty mlist # (LOC MODEPT q:=first OF p ; DO # loop deprefs mood q until found OK, or incest is witnessed # CASE mode OF q IN (PROCMODE t): (params OF t IS empty mlist| q:=result OF t | GO TO next mood) , (REFMODE t): q:=deflex OF t OUT GO TO next mood ESAC ; LOC MLIST r:=u ; CASE mode OF q IN (MLIST uq): # find out if uq is subset of u # ( LOC MLIST s:=uq ; DO # s may still have duplicates # WHILE place OF first OF rplace OF first OF s | GOTO next mood ) ; WHILE place OF first OF r=place OF first OF s DO ( ~+s | GOTO incest) OD ; ( ~+r | GOTO next mood ) OD ) OUT # find out if q is a member of u # WHILE ( place OF first OF r=place OF q | GOTO incest ); +r DO~OD ESAC # only OUT case requires further depreffing # OD ; next mood: n+:=1); +p DO ~ OD EXIT incest: print(("Incestuous UNION (consituent ",n," causes problem):",newline)) ; print mode explicit(mode[i]) ; fail: failure:=TRUE OD # FOR i # ; failure END ; PROC print mode = (MODEPT m)VOID: IF INT n=name OF ident OF m; n/=no name THEN print(hash tab[n]) ELSE CASE mode OF m IN (PRIMODE p): ( INT t=length OF p; TO ABS t DO print((t>0|"LONG "|"SHORT ")) OD ; print(mode name[type OF p]) ) , (REFMODE r): (print("REF "); print mode(deref OF r)) , (ROWS r): ( LOC INT d:=dim OF r; IF d<=0 THEN print("FLEX "); d:=-d FI ; IF d>0 THEN print("["); TO d-1 DO print(",") OD; print("] ") FI ; print mode(comp mode OF r) ) , (PROCMODE p): ( print("PROC ") ; IF LOC MLIST pa:=params OF p; pa ISNT empty mlist THEN print("("); WHILE print mode(first OF pa); +pa DO print(",") OD ; print(") ") FI ; print mode(result OF p) ) , (STRUCTMODE s): ( print("STRUCT(") ; LOC MLIST f:=fields OF s, LOC TAGLIST tg:=tags OF s ; WHILE print mode(first OF f); print(" ",hash tab[tag OF tg]); +f DO +tg; print(",") OD ; print(")") ) , (MLIST u): ( print("UNION("); LOC MLIST p:=u ; WHILE print mode(first OF p); +p DO print(", ") OD; print(")") ) , (MODEPT): print("Circularly defined") , (HDDEF): print("Never defined!!") ESAC FI ; PROC print mode line = (MODEPT m)VOID: ( print mode(m) ; print((" ",(name OF ident OF m=no name|"first us"|"defin"),"ed in line " ,whole(line OF m,0),".",newline)) ) ; PROC print mode explicit = (MODEPT m)VOID: ( LOC MODESC top:=(place OF m,mode OF m,0,(no name,no range)); print mode line(top) ) ; PROC list modes = VOID: FOR i TO last mode DO print(("Mode ",whole(i,0)," = ")); INT n=name OF ident OF mode[i] ; IF n/=no name THEN print((hash tab[n]," = ")) FI ; print mode explicit(mode[i]) OD ; ~ END