|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 21504 (0x5400) Types: TextFile Names: »twritestd«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ. └─⟦4334b4c0b⟧ └─⟦162d2eb5b⟧ »talgprog« └─⟦this⟧
;ali time 3 0 mode list.yes lookup stdlist if ok.yes mode listing.yes writestdent=set 1 global writestdent writestdent=algol writestdent 1980-10-06 external integer procedure writestdent(t,options); integer array t; boolean array options; begin comment copyright Anders Lindgård, october 1978,1980; integer array ct,st(-6:10),t32,t33(1:10); boolean field bval; integer field ival,time1,time2; real field rval; long field lval; long field ctype,type; integer i,j,k,l,entrytype,rsentry,content,lastp,lastabs, noofext,noinit,startext,address,segmkind,exsegm,exaux, ext,char,extc,desc,descmode,pda,spda,lines,segm0,maxRS, cursegm,lastsegm,acontent; boolean f,segmf,details,test,var,externals, abswords,points,survey,printsegm, version,printnoofext,printprocess; integer array field segm; array field nf; array lname,auxname,sname,name(1:2); boolean procedure printtranslated(name,size); value size; integer size; array name; begin boolean w; integer i,j,p,res,word,relsegm,reladdr; integer array field rec; rec:=0; printtranslated:=false; res:=connectcuri(name); if res>0 or size<8 then begin unstackcuri; end else begin setposition(in,0,0); inrec6(in,512); if in.rec(1)=4 then begin comment algol or fortran; w:=false; i:=49; for i:=i+1 while -,w and i<=100 do begin j:=in.rec(i); if j=0 then begin w:=in.rec(i+1)=-8388608 and in.rec(i+2)=511; p:=i+3; end j=0; end loop; if w then begin printtranslated:=true; word:=in.rec(p); write(out,"nl",1,if word=0 then <:FORTRAN:> else <:ALGOL:>); j:=0; write(out,"sp",2,<:program :>,string name(increase(j))); if word=0 then word:=in.rec(p+6); relsegm:=word shift (-12) extract 12; reladdr:=word extract 12; if relsegm<6 or relsegm>size or reladdr<4 or reladdr>510 then write(out,"nl",1,"*",2,<:date not found:>) else begin setposition(in,0,relsegm); inrec6(in,512); p:=reladdr//2; write(out,"nl",1,<:translated:>,<< dd dd dd>,in.rec(p-1),in.rec(p),"nl",1); end date; end w; end 4; end connect; end printtranslated; procedure writename(txt,name); string txt; array name; begin integer i,j,char; boolean bad; integer array ch(1:12); for i:=1,2 do for j:=1 step 1 until 6 do ch((i-1)*6+j):=name(i) shift ((j-6)*8) extract 8; bad:=false; for i:=1 step 1 until 12 do begin bad:=bad or (ch(i)<32 and ch(i)>0) or ch(i)>127; end; bad:=bad or ch(1)<64; if bad then write(out,<:<10>:>,txt,<: nonsense:>) else begin write(out,<:<10>:>,txt,<: :>); for i:=1,i+1 while i<12 and ch(i)>0 do write(out, false add ch(i),1); end; end writename; procedure writeRS(no); value no; integer no; if no>0 and no<maxRS then write(out,<: :>,case no of ( <:** real:>,<:**integer:>,<:reserve in stack:>, <:take expression:>,<:goto point:>,<:end register expression:>, <:end UV expression:>,<:end address expression:>,<:init zones:>, <:release zones:>,<:goto computed:>,<:UV:>, <:last used:>,<:last of program:>,<:first of program:>, <:segment table base:>,<:index alarm:>,<:zone alarm:>, <:case alarm:>,<:syntax stop:>,<:general alarm:>, <:underflows:>,<:youngest zone:>,<:blocksread:>, <:mult alarm:>,<:in:>,<:out:>, <:reserve array:>,<:param alarm:>,<:saved stack ref, saved w3:>, <:end program conditions:>,<:stderror:>,<:check:>, <:inblock:>,<:outblock:>,<:parent message:>, <:overflows:>,<:console:>,<:trap base:>, <:program name:>,<:parent process:>,<:victim:>, <:long round:>,<:long mod:>,<:stop fortran:>, <:long to real:>,<:cut real:>,<:take expression fortran:>, <:dr1:>,<:dr2:>,<:UV0:>, <:label alarm:>,<:go to point fortran:>,<:field alarm:>, <:long multiply:>,<:long divide:>,<:RC8000:>, <:errorbits:>,<:cattail for lookup:>,<:last of segm table:>, <:(CSR,CZA):>,<:no of program segments:>,<:no of owns:>, <:name of virtual file:>,<:load words from virtual store:>,<:store words from virtual store:>, <:check save:>,<:name of program:>,<:alarmcause:>, <:trapmode:>,<:progmode:>,<:blocksout:>, <:first of segments:>, <:max last used:>,<:limit last used:>,<:temp last used:>, <:current activity:>,<:no of activities:>,<:base activity table:>, <:aref=sref activity block:>,<:abs address(top program):>, <:(sref,segtable) return activate/init act:>, <:rel return return activate/init act:>, <:entry check passivate:>,<:current activity no:>, <:current stack bottom:>,<:temp stack bottom:>, <:call passivate2:>,<:disable activity:>, <:enable activity:>,<:trapchain:>, <:alarm record:>,<:end action:>, <:continue:>,<:exit:>,<:dummy boolean in repeat:>, <:dummy integer in while:>,<:dummy zone (context):>,<:init context:>, <:RS own bytes:>,<:RS entries:>,<:RS segments:>,<:message address:>, <:own base:>, <: :>)); boolean procedure writetype(entrytype,name); value entrytype; integer entrytype; array name; begin boolean var; integer i,j,k,l; var:=entrytype>7; i:=k:=1; char:=char+( if entrytype<1 then write(out,<:**type :>,entrytype,<: :>) else if entrytype>=32 then write(out,<:FORTRAN :>,case entrytype-32+1 of ( <:32:>,<:SUBROUTINE :>,<:LOGICAL FUNCTION :>, <:INTEGER FUNCTION :>,<:FUNCTION :>,<:LONG FUNCTION :>, <:COMPLEX FUNCTION :>,<:DOUBLE PRECISION FUNCTION :>)) else if entrytype>14 then write(out,<:FORTRAN type :>,entrytype,<: :>) else write(out,case if var then entrytype-6 else entrytype of (<::>,<:boolean:>,<:integer:>,<:real:>,<:long:>,<:long real:>, <:complex:>,<:zone:>),if entrytype<>1 then <: :> else <::>, if var then <::> else <:procedure :>)); char:=char+write(out,string name(increase(i))); writetype:=-,var; end; procedure writepar(par); value par; long par; begin integer j,k,l; par:=par shift 6 shift (-6); if par<>0 then char:=char+write(out,<:(:>); for j:=0,-6,-12,-18,-24,-30,-36 do begin k:=par shift j extract 6; if k>0 then begin char:=char+write(out,if k<11 then <::> else if k<18 then <:value :> else if k<24 then <:address :> else if k=38 then <:switch :> else if k=39 then <:general :> else if k=40 then <:general address:> else if k=41 then <:undef:> else <::>); if k<38 then begin l:=(if k<11 then k else if k<18 then k-10 else if k<24 then k-16 else if k<31 then k-22 else k-30); char:=char+write(out,case l of(<::>,<:boolean:>,<:integer:>, <:real:>,<:long:>,<:long real:>,<:complex:>, <:zone:>,<:string:>,<:label:>)); if k>23 and k<31 then char:=char+write(out, if k>23 then <: :> else <::>,<:array:>); if k>30 then char:=char+write(out, if k>31 then <: :> else <::>,<:procedure:>); end; if j>-36 then begin char:=char+write(out,<:,:>); if char>50 then begin char:=write(out,<:<10> :>); lines:=lines+1; end; end; end k>0; end for; if par<>0 then write(out,<:);:>); end; cleararray(name); test:=false; points:=segmf:=f:=false; maxRS:=93+12; ctype:=type:=16; nf:=-8; for i:=1,2 do name(i):=t.nf(i); details:=options(1); survey:=options(2); test:=options(3); externals:=options(4); abswords:=options(6); points:=options(7); printsegm:=options(8); printnoofext:=options(10); printprocess:=options(11); details:=details or test; if details then survey:=points:=abswords:=externals:=true; printsegm:=printsegm or survey; printnoofext:=printnoofext or survey; printprocess:=printprocess or survey ; nf:=2; lastsegm:=if t(1)<0 then 0 else t(1); desc:=if t(1)>0 then 4 else t(1) extract 12; descmode:=if t(1)>0 then 0 else t(1) shift (-12) extract 11; content:=t(9) shift (-12); entrytype:=t(7) shift (-18); rsentry:=if entrytype>7 then t(7) extract 17 else 0; write(out,<:<10>:>); lines:=1; if t(1)<=0 and t(2)<>0 and rsentry=0 then begin for i:=1,2 do sname(i):=t.nf(i); i:=headandtail(sname,st); if i=0 and st(1)>0 then lastsegm:=st(1); spda:=description(sname); j:=1; if i<>0 and spda=0 then begin lines:=lines+1; write(out,<:**auxillary name not found :>, string sname(increase(j)),<:<10>:>) end else if content=4 or content>32 then segmf:=true; end else if t(1)<=0 then segmf:=rsentry=0 else begin segmf:=true; for i:=1,2 do sname(i):=name(i); for i:=-6 step 1 until 10 do st(i):=t(i); end; if content<>4 and content<=32 then begin comment file or filedescriptor; pda:=description(name); i:=1; if t(1)<=0 and content<>2 then write(out,<:filedescriptor :>); if content=2 or content=3 then begin if content=3 or -,printtranslated(sname,t(1)) then write(out,<:program :>); end else write(out,case content+1 of (<:text file:>,<:not used (reserved):>, <::>,<::>,<::>, <:stacked zone:>,<:program with logical blocks:>, <:dumped store area:>,<:program self contained:>, <:virtual store ALGOL:>,<:contract file:>, <:COBOL object program:>,<:undefined 12.:>,<:COBOL data file:>, <:undefined 14.:>,<:RC8000 paging system:>, <:undefined 16.:>,<:GIER simulator:>, <:undefined 18.:>,<:undefined 19.:>, <:bs-system file:>,<:sq-system file:>, <:isq-system file:>,<:system 80 file:>, <:undefined 24.:>,<:undefined 25.:>, <:undefined 26.:>,<:undefined 27.:>, <:undefined 28.:>,<:undefined 29.:>, <:free 30.:>,<:free 31.:>)); write(out,"sp",1,string name(increase(i))); if pda>0 and printprocess then write(out,<: ; process :>,pda); if content=3 or content=6 then begin lines:=lines+1; write(out,<:<10>entry :>,t(9) extract 12, <:, bytes to load :>,t(10)) end; if t(1)<=0 then begin lines:=lines+1; if content=2 and t(1)<0 then write(out,<:<10>entry in :>) else if content=2 and t(1)=0 then write(out,<:<10>doc :>) else if desc>20 then write(out,<:<10>:>,desc) else write(out,<:<10>:>,case desc//2+1 of(<:ip:>,<:2:>,<:bs:>,<:6:>, <:tw:>,<:tr:>,<:tp:>,<:lp:>,<:cr:>,<:mt:>,<:pl:>)); if desc=16 then write(out, case descmode//2+1 of( <:b:>,<:d:>,<:h:>,<:.6:>,<:.8:>,<:c:>,<:.12:>,<:.14:>)) else if descmode>8 then write(out,<:.:>,<<d>,descmode) else if desc=18 or (desc>8 and desc<14) then begin if descmode<12 then write(out, case descmode//2+1 of(<:o:>,<:e:>,<:n:>,<:f:>,<:t:>)) else write(out,<:.:>,<<d>,descmode); end; j:=1; if t(2)>0 then begin write(out,<: :>,string sname(increase(j))); if spda<>0 and printprocess then write(out,<: ; process :>,spda); if pda=0 and lookupentry(sname)>0 then write(out,<: ; does not exist :>); if content<>2 then begin lines:=lines+2; write(out,<:<10>file :>,t(7), <:<10>block :>,t(8)); end; end; end; end else if content=4 or content>=32 then begin comment algol procedure or variable; segm0:=if content=4 then 0 else content-32; var:=entrytype>7 and entrytype<15; char:=1; writetype(entrytype,name); if var then begin comment variable; write(out,"sp",10,<<-dddddddd>,t(-5),<:::>, <<d>,t(-4),<: key=:>,t(-6) extract (3)); for i:=1,2 do auxname(i):=t.nf(i); lookuptail(auxname,t32); j:=i:=1; lines:=lines+1; write(out,<:<10>entry :>); if rsentry=0 then write(out,<:in :>, string t.nf(increase(i)),<: on :>, string t32.nf(increase(j)),<: byte :>,t(6)) else if rsentry<maxRS and rsentry>0 then write(out,rsentry,<: in running system :>); end else begin comment procedure; writepar(t.type); write(out,"sp",3,<<-dddddddd>,t(-5),<:::>,<<d>,t(-4), <: key=:>,t(-6)extract 3); if t(2)<>0 then begin lines:=lines+1; for i:=1,2 do auxname(i):=t.nf(i); j:=lookuptail(auxname,t32); i:=1; acontent:= if j=0 and t32(1)<0 then t32(9) shift (-12) extract 12 else 0; if j>0 or (j=0 and t32(1)<0) then write(out,if t(1)>=0 then <:<10>doc :> else <:<10>entry in :>,string t.nf(increase(i))); if acontent>0 then segm0:=acontent-32; if content>=32 or (j=0 and acontent>=32) then begin if j=0 and t32(1)<0 then begin for i:=1,2 do auxname(i):=t32.nf(i); j:=lookuptail(auxname,t32); end; lastsegm:=0; i:=1; if j>0 then write(out,"*",3,<:main entry :>, string auxname(increase(i)),<: not present:>) else begin for i:=1,2 do sname(i):=auxname(i); lastsegm:=t32(1); j:=i:=1; write(out,"nl",1,if acontent>0 then <:main entry :> else <:entry in :>,string auxname(increase(i)), "sp",1,<:, :>,<<d>,t32(1),<: segments on :>,string t32.nf(increase(j))); end; end; end; if t(1)>0 and printsegm then begin lines:=lines+1; write(out,<:<10>segments :>,t(1)); end; if survey and t(1)>0 and t(1)<>t(10) shift (-12) then begin lines:=lines+1; write(out,<:<10>segments used for code :>,t(10) shift (-12)); end; if survey and t(10) extract 12>0 then begin lines:=lines+1; write(out,<:<10>total own bytes :>, t(10) extract 12); end; if survey then begin lines:=lines+1; write(out,<:<10>entry segment :>,<<d>, t(6) shift (-12) extract 11,<:+:>,segm0,<: relative :>,t(6) extract 12); end; end; if segmf and lastsegm>0 then begin comment search on segment; i:=connectcuri(sname); j:=1; if i<>0 then alarm(<:***connect segment :>, string sname(increase(j))); setposition(in,0,segm0); if test then write(out,"nl",1,"*",1,<:segment 0 :>,segm0); inrec(in,128); cursegm:=segm0+1; segm:=0; lastp:=in.segm(1) shift (-12); lastabs:=in.segm(1) extract 12; startext:=(if var then st(9) else t(9)) extract 12; if startext>500 then write(out,"nl",1,"*",2,<:procedure inconsistent:>) else begin if details then begin lines:=lines+2; write(out,<:<10>last point, last abs :>,lastp,lastabs); if startext=0 then write(out,"nl",1,<:no externals:>) else write(out,<:<10>start external :>,startext); end; noofext:=if startext=0 then 0 else in.segm(startext//2+1); if startext=500 and cursegm<lastsegm then begin inrec(in,128); startext:=in.segm(startext//2+2) extract 12; startext:=startext-2; cursegm:=cursegm+1; end; if startext>=500 then write(out,"nl",1,"*",2,<:procedure inconsistent:>) else begin exaux:=noofext shift (-12); noofext:=noofext extract 12; noinit:=in.segm(startext//2+2) extract 12; if noinit> 1 shift 12 -1 then begin end; if survey and startext>0 then begin lines:=lines+2; write(out,<:<10>no. of externals :>,noofext, <:<10>own bytes to initialize :>,noinit); end; if var and entrytype<12 then begin address:=t(6)+startext+4; i:=1; write(out,<: = :>); if t(6)>noinit then write(out,0) else case entrytype-7 of begin begin comment boolean; ival:=bval:=address; write(out,if in.bval then <:true:> else <:false:>); if -,in.bval and in.ival extract 12 >0 then write(out,<: add :>,in.ival extract 12); end; begin comment integer; ival:=address; write(out,in.ival); end; begin comment real; rval:=address; write(out,<< d.ddd ddd ddd>,in.rval); end; begin comment long; lval:=address; write(out,in.lval); end; end; end write out variable value; if abswords then begin lines:=lines+1; write(out,<:<10>abs words::>); for j:=2 step 1 until lastabs//2+1 do begin i:=in.segm(j) shift (-12); k:=in.segm(j) extract 12; lines:=lines+1; write(out,<:<10>:>); if i=0 then write(out,<: own byte :>,k) else if i>noofext and i<2048 then begin write(out,<: RS-entry:>,<< dd>,i-noofext); writeRS(i-noofext); end else if i<=noofext then write(out,<: ext segment :>,i,<: chain :>,k) else if i>=2048 then write(out,<: own segment :>,i extract 11); end; end; if points and lastabs<lastp then begin lines:=lines+1; write(out,<:<10>points::>); for i:=lastabs//2+2 step 1 until lastp//2+1 do begin j:=in.segm(i); if j<>0 and j<>1 shift 23 then begin lines:=lines+1; write(out,<:<10>:>,if j>0 then <:external no :> else <:rel segm :>, j shift (-12) extract 11); j:=j extract 12; if j>0 then write(out,<: relative :>,j); end; end; end; nf:=startext+noinit+4+exaux*2-12; type:=nf+12; exsegm:=segm0; for ext:=1 step 1 until noofext do begin nf:=nf+12; if nf>=512-10-12 then begin extc:=512-10-nf; address:=in.segm(256-4) extract 12;; exsegm:=exsegm+1; if extc>0 then lname(1):=in.nf(1); if extc>4 then lname(2):=in.nf(2); if extc>8 then k:=in.segm(256-5); if test then write(out,<:<10>next address:>,address, "nl",1,<:next segment external :>,exsegm); setposition(in,0,exsegm); inrec(in,128); nf:=address-extc; if extc>0 then in.nf(1):=lname(1); if extc>4 then in.nf(2):=lname(2); if extc>8 then in.segm(nf//2+5):=k; end; type:=nf+12; address:=firstaddr(in)+nf-2; i:=headandtail(address,ct); j:=1; version:=false; if (i<>0 or ct.ctype<>in.type) then begin lines:=lines+1; version:= in.nf(1)=real <:*vers:> add 105 and in.nf(2)=real <:on:>; if version then begin i:=1; write(out,"nl",1,string in.nf(increase(i)), in.type shift (-24) extract 24); end else write(out,<:<10>**external error :>, string in.nf(increase(j)),<: :>,<<b>,i,"sp",2,in.type); if i=0 and -,version then begin write(out,<: declared :>); if writetype(round(ct.ctype shift (-42)),in.nf) then writepar(ct.ctype); end; end; if externals and -,version then begin lines:=lines+1; char:=write(out,<:<10>external:>,<< dd>,ext,<: = :>); if writetype(round(in.type shift (-42)),in.nf) then writepar(in.type); end; end; comment time1:=startext+noinit+noofext*12+6+exaux*2; time1:=type+2; exsegm:=time1//512; if exsegm>0 then begin if test then write(out,"nl",1,"*",1,<:translated segment :>,exsegm); setposition(in,0,exsegm); inrec(in,128); time1:=time1 mod 512; end; time2:=time1+2; lines:=lines+1; write(out,<:<10>translated :>,<< dd dd dd>,in.time1,in.time2); if printsegm then begin nf:=512-8; segmkind:=in.segm(256) extract 2; i:=1; lines:=lines+1; if segmkind=1 and entrytype>=32 then segmkind:=4; if segmkind=0 then writename(<:alarm address:>,in.nf) else write(out,<:<10>:>,case segmkind of ( <:external algol coded procedure:>, <:main algol segment:>,<:running system segment:>, <:external FORTRAN SUBROUTNE or FUNCTION:>)); end; end; end; unstackcuri; end; end algol variable or procedure; writestdent:=lines; if test then write(out,<:<10>lines :>,lines); end; end; lookup stdlist if ok.yes mode list.yes writestd=set 20 global writestd writestd=algol connect.no writestd 1980-10-01 begin comment copyright Anders Lindgård, february 1977; integer i,j,k,l,m,pda,noofdesc; boolean f,iarea; integer array t(-6:10),tail(1:10); boolean array options(1:20); array inp,outp,name(1:3); cleararray(name); cleararray(options); f:=false; noofdesc:=1; initfp; connectlso; f:=readsfp(<:name:>,name,<::>)or readinfp(name,1); for i:=8 step 1 until 20 do options(i):=true; options(3):=false; iarea:=readsfp(<:input:>,inp,<::>); if iarea then begin i:=lookuptail(inp,tail); m:=1; if i<>0 then alarm(<:***input area :>,string inp(increase(m)),<: unknown:>); for i:=8 step 1 until 20 do options(i):=false; f:=true; noofdesc:=tail(10); end; if fpbooleans>0 then begin readbfp(<:details:>,options(1),-,iarea); readbfp(<:survey:>,options(2),-,iarea); readbfp(<:test:>,options(3),false); readbfp(<:externals:>,options(4),-,iarea); readbfp(<:abswords:>,options(6),-,iarea); readbfp(<:points:>,options(7),-,iarea); readbfp(<:segments:>,options(8),-,iarea); end; if -,f then reads(<:name:>,name); if -,iarea then begin repeat readinfp(name,noofdesc); i:=headandtail(name,t); j:=1; pda:=description(name); if pda>0 and i>0 then begin write(out,<:<10>:>,string name(increase(j)), <: ; process :>,pda); end; if i<>0 then write(out,"nl",1,<:***:>,string name(increase(j)), <: unknown:>,i) else writestdent(t,options); noofdesc:=noofdesc+1; until noofdesc>fpinareas; outendcur(10); if fpout then closeout; end else begin integer array field entry; zone get(128,1,stderror); entry:=0; m:=1; open(get,4,string inp(increase(m)),0); setposition(get,0,0); for i:=1 step 1 until noofdesc do begin inrec6(get,64); for i:=1 step 1 until 17 do t(i-7):=get.entry(i); write(out,<:<10>:>); writestdent(t,options); end; close(get,true); end; outendcur(10); end; if warning.yes (mode list.no end) mode list.no lookup stdtest if ok.no end mode list.yes writestd name.plotform writestd name.fp writestd name.out writestd name.underflows writestd name.outchar writestd name.e writestd name.o writestd name.lookup writestd name.tpf writestd name.p writestd name.printer writestd name.write survey.yes writestd name.plottext details.yes writestd name.writeplot details.yes writestd name.cleararea test.yes writestd name.tpt writestd name.aimag writestd name.sin test.yes writestd name.externaladp test.yes mode list.no ▶EOF◀