%record %format rf(%integer conad, filetype, datastart, dataend) %system %routine %spec connect(%string (31) file, %integer mode, hole, prot, %record (rf) %name r, %integer %name flag) %external %integer %function %spec exist(%string (31) file) %system %integer %function %spec currentll %system %long %integer %function %spec load ep(%string (31) entry, %integer %name type, flag, %integer loadlevel) %system %routine %spec unload2(%integer loadlevel, flag) %external %integer %function %spec uinfi(%integer ep) %external %routine %spec define(%string (255) s) %external %routine %spec clear(%string (255) s) %external %routine %spec closestream(%integer str) %system %routine %spec ssmessa(%integer fail, %string (63) fname) %system %routine %spec find entry(%string (31) entry, %integer type, dad, %string %name file, %integer %name dr0, dr1, flag) %system %routine %spec load(%string (31) entry, %integer type, %integer %name flag) %system %routine %spec setpar(%string (255) s) %system %string %function %spec spar(%integer i) %system %integer %function %spec parmap %system %string %function %spec confile(%integer adr) %system %integer %map %spec comreg(%integer i) %external %string %function %spec uinfs(%integer entry) %constant %byte %integer %array hex(0:15)= %c '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' %constant %integer %array accept digits(0:7)= %c X'FFFFFFFF', X'FFFF003F', X'FFFFFFFF'(6) %string (8) %function htos(%integer value, places) !* TURNS AN INTEGER INTO A HEXADECIMAL STRING OF GIVEN LENGTH !* USES MACHINE CODE %string (8) s %integer i i = 64 - 4 * places *LD_s; *LSS_places; *ST_(%dr ) *INCA_1; *STD_ %tos; *STD_ %tos *LSS_value; *LUH_0; *USH_i *MPSR_X'24'; ! SET CC=1 *SUPK_ %l =8 *LD_ %tos; *ANDS_ %l =8, 0, 15; ! THROW AWAY ZONE CODES *LSS_hex+4; *LUH_X'18000010' *LD_ %tos; *TTR_ %l =8 %result = s %end; !OF HTOS %routine phex(%integer i) printstring(htos(i, 8)) %end; !OF PHEX %routine getnum(%string (255) s, %integer %name i, flag) %integer j, k, l, sign ->err %if s = ""; !NO PARAM l = length(s) i = 0 j = charno(s, 1) %if j = 'X' %then %start %if l > 9 %then ->err %for k = 2, 1, l %cycle j = charno(s, k) - '0' %if j > 9 %then j = j + '0' - 'A' + 10 %unless 0 <= j <= 15 %then ->err i = (i << 4) ! j %repeat %finish %else %start %if j = '-' %then %start sign = 13 k = 2 %finish %else %start sign = 15 k = 1 %finish l = l - k + 1 %if l > 0 %then %start %if l > 10 %then ->err k = addr(s) + k *LDTB_X'18000000' *LDB_l *LDA_k *STD_ %tos *LSS_accept digits+4 *LUH_256 *TCH_ %l = %dr *JCC_7, *LD_ %tos *LB_sign *LSQ_ %b *PK_ %l = %dr *CBIN_0 *ST_ %tos *USH_32 *ISH_-32 *UCP_ %tos *JCC_7, *STUH_ %b *ST_(i) %finish %finish flag = 0 %return err: flag = 1 %end; ! GETNUM %routine define output(%string (255) s) %if s = "$CLEAR$" %start selectoutput(0) closestream(23) clear("23") %return %finish s = ".OUT" %if s = "" define("23,".s) selectoutput(23) %end %external %routine history(%string (255) file) %routine check for source(%string (255) files) %string (255) others, file, owner1, owner2 others = files others -> owner1.(".").files %while others # "" %cycle %unless others - > file.("+").others %start file = others others = "" %finish %if file - > owner2.(".").file %then %c file = owner2.".".file %else file = owner1.".".file length(file) = 31 %if length(file) > 31 %if exist(file) # 0 %then %c printstring("*** ".file." exists ") %else %c printstring(" ".file." does not exist ") newline %repeat %end; !of check for source %record (rf) rr %integer flag, lda, p %constant %integer ssobjfiletype=1 %string (255) source, source1, source2 %if file# "#DIRCODE" %start connect(file, 0, 0, 0, rr, flag) %if flag # 0 %start printstring(" History fails - ") ssmessa(flag, file) newline %return %finish %if rr_filetype # ssobjfiletype %start printstring(" History fails - ") ssmessa(267, file) newline %return %finish %finishelsestart printstring(" Director code file") %return %finish printstring(" Object File :".file) newline lda = rr_conad + integer(rr_conad + 24); !start of load data p = rr_conad + integer(lda + 48); !start of object data %while byteinteger(p) # 0 %cycle %if byteinteger(p) = 1 {source file type} %start source = string(p + 1) %if source - > source1.("+").source2 %start source = source1."+".source2 printstring(" (Source file(s):".source.")") newline %finish check for source(source) %finish p = p + byteinteger(p + 1) + 2; !point to next item %repeat newline %end %routine decodedr0(%integer dr0, dr1) %integer type, subtype, size, s, usc, bci, bound, newdr0, newdr1 %string (255) line *lss_(%lnb +5) *st_ %b *lss_ %b; *ush_-30; *st_type *lss_ %b; *ush_2; *ush_-26; *st_subtype *lss_ %b; *ush_2; *ush_-29; *st_size *lss_ %b; *ush_5; *ush_-31; *st_s *lss_ %b; *ush_6; *ush_-31; *st_usc *lss_ %b; *ush_7; *ush_-31; *st_bci *lss_ %b; *ush_8; *ush_-8; *st_bound printstring(" DR0= "); write(dr0, 1); printstring(" (=X'"); phex(dr0); printstring("')"); newline printstring(" Type "); write(type, 1) %if type = 3 %start printstring(" Subtype "); write(subtype, 1) %finish printstring(" Size "); write(size, 1); newline printstring(" S "); write(s, 1) printstring(" USC "); write(usc, 1) printstring(" BCI "); write(bci, 1) printstring(" Bound "); write(bound, 1); newline %constant %integer %array sizecode(0:7)= 1, 0, 0, 8, 16, 32, 64, 128 {BITS} { 0, 1, 2, 3, 4, 5, 6, 7 CODE} %constant %string (255) %array descname(0:3)= %c "Vector","String","Descriptor"," " %constant %string (255) %array subname(32:64)= %c "Bounded code","Unbounded code","INVALID","System call", "INVALID","Escape","INVALID"(2),"Bounded semaphore", "Unbounded semaphore","INVALID"(21),"Null","INVALID" line = " descriptor " line = descname(type).line subtype = 64 %unless 32 <= subtype <= 63 line = subname(subtype).line %if type = 3 %switch desctype(0:3) ->desctype(type) desctype(0): {vector} %if sizecode(size) = 8 %then %c line = "Byte ".line."to a string of length " %else %if %c bci = 0 %then line = line." - greatest modifer is 1+ " printstring(" ".line); write(bound, 1); newline %return desctype(1): {string} line = "Poorly formed ".line."(wrong size specified)" %if %c sizecode(size) # 8 line = line."to string of length" printstring(" ".line) write(bound, 1) newline %return desctype(2): {descriptor} %unless sizecode(size) = 64 %and s = 0 %then %c line = "Poorly formed ".line."(wrong size)" printstring(" ".line) newline %unless dr1 <= 0 %start printstring(" Descriptor is loaded in file ".confile(dr1)) newline *lda_dr1; *ldtb_dr0; *lsd_(%dr ); *stuh_newdr0; *st_newdr1 printstring("Accesing descriptor in file ".confile(newdr1)) newline printstring(" New DR0:"); write(newdr0, 1); printstring(" (=X'"); phex(newdr0); printstring("')") printstring(" New DR1:"); write(newdr1, 1) printstring(" (=X'"); phex(newdr1); printstring("')") newline dr0 = newdr0 dr1 = newdr1 decodedr0(dr0, dr1) %if confile(newdr1) # "" %start printstring("Attempt to find source(s) of object file") newline history(confile(newdr1)) %finish %finish %return desctype(3): {other} printstring(" ".line) newline %return %end %external %routine getdr0(%string (255) str) %integer dr0, dr1, flag1, flag2 %string (255) s1, s2 setpar(str) s1 = spar(1) s2 = spar(2) getnum(s1, dr0, flag1) getnum(s2, dr1, flag2) %if flag1 = 0 %then decode dr0(dr0, dr1) %else printstring("BAD PARAM") !temp %end %external %routine checkentry(%string (255) s) %constinteger true = 1, false = 0 %string (31) file %integer dr0, dr1, flag, savecom44, savemon, type, loadlevel, full %long %integer %name desc full = false file = "" dr0 = 0 dr1 = 0 flag = 100000 savecom44 = comreg(44) setpar(s) ->out %if parmap & 1 # 1 s = spar(1) full = true %if spar(2) = "*" length(s) = 31 %if length(s) > 31 %if uinfi(26) = 0 %start findentry(s, 0, 0, file, dr0, dr1, flag) %if flag # 0 %then %start load(s, 0, flag) %if flag # 0 %then %start printstring(" Checkentry fails - ") ->out %finish findentry(s, 0, 0, file, dr0, dr1, flag) %if flag # 0 %then %start printstring(" ERROR FAILED TO FIND ENTRY ".s. %c " AFTER CALLING LOADER") newline ->out %finish %finish %finish %else %start type = 2 loadlevel = currentll desc == longinteger(addr(dr0)) desc = loadep(s, type, flag, loadlevel) %if desc = 0 %then flag = 289 ->out %if flag # 0 %finish %if full=1 %start write(dr0, 10) write(dr1, 10) newline %finish file = confile(dr1) file = uinfs(1).".#DGLA" %if file = "" printstring(" ".s." successfully loaded in file ".file) newline %if full=true %start printstring(" DR0=") write(dr0, 10) printstring("(X'") phex(dr0) printstring("')") printstring(" DR1=") write(dr1, 10) printstring("(X'") phex(dr1) printstring("')") newline printstring("Analysis of Descriptor gives :") newline decode dr0(dr0, dr1) %finishelsestart %if dr1<(2<<18)%then file="#DIRCODE" %else file=confile(integer(dr1+4)) history(file) %finish out: %if flag # 0 %then %start ssmessa(flag, s) newline %finish %if uinfi(26) = 0 %start comreg(44) = savecom44 %finish %else %start loadlevel = currentll unload2(loadlevel, flag) %finish %end %external %routine source(%string (255) s) %integer dr0, dr1, full, command, flag %string (255) s1, s2, s3, s4 setpar(s) %if parmap & 1 # 1 %start printstring("invalid param"); !TEMP %return %finish s1 = spar(1) s2 = spar(2) s3 = spar(3) s4 = spar(4) getnum(s1, dr0, flag) %if flag # 0 %then command = 1 %else command = 0 %if command = 1 %start %if s2 # "" %then full = 1 %else full = 0 defineoutput(s3) checkentry(s1.",".s2); !change for full!!! defineoutput("$CLEAR$") %return %finish !dr1=getnum(s2) getnum(s2, dr1, flag) %if s3 # "" %then full = 1 %else full = 0 defineoutput(s4) dr1 = 0 %if dr1 < 0 decodedr0(dr0, dr1); !change for full defineoutput("$CLEAR$") %end %end %of %file