Artifact 6e221d41eda3dba2331217ae8acb118e05e6f9bd2b6ad170824445c2f3af372d:
- Executable file
r37/packages/rlisp88/inspect.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 17076) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/rlisp88/inspect.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 17076) [annotate] [blame] [check-ins using]
module inspect; % Rlisp88 Code inspector. % Author: Jed Marti. % Description: Formats and displays the active annotation associated % with various RLISP data structures. % Notes: Things left to work on: % DEFINE constants. % SWITCH % CLASS, instances, scripts, etc. % The line numbers are pretty much the input expression numbers % (where comments are counted). Fixing this would require a % modification to the RLISP lexical scanner. % Dependencies: % Revision History: (Created Fri Jan 3 08:40:29 1992) % Wed Feb 26 09:39:28 1992 Add file/line numbers to functions. % Upgrade comments. % Sun Mar 1 11:09:30 1992 Try GLOBAL and FLUID declarations. Also % clear COMMENT!* after each use. % Fri Mar 13 17:28:41 1992 Add the comment reformatting routine % fmtcmt. % Fri Oct 8 12:06:00 1993 Fix use if ifl!*, remove printf's. Make % work with old RLISP syntax first. No active comments in this % code. expr procedure describe x; % DESCRIBE(X) -- Inspect any data structure X. This main routine % farms out the work accordingly. if pairp x then << prin2t "A dotted-pair or list"; nil >> else if vectorp x then if i!&recordinstp x then i!&recordinst x else <<prin2 "A vector with "; prin1 add1 upbv x; prin2t " elements"; nil>> else if codep x then <<prin2t "A code-pointer"; nil>> else if numberp x then if fixp x then <<prin2t "A fixed number"; nil>> else if floatp x then <<prin2t "A floating-point number"; nil>> else <<prin2t "An unknown type of number"; nil>> else if stringp x then <<prin2t "A string"; nil>> else if idp x then if i!&recordp x then i!&record x else if i!&functionp x then i!&function x else if i!&constantp x then i!&constant x else if i!&modulep x then i!&module x else if get(x, 'newnam) then i!&idnewnam x else i!&id x else <<prin2t "Can't inspect data structures of this type";nil>>; expr procedure i!&idnewnam x; % I!&IDNEWNAM(X) - This is the result of a define. <<prin1 x; prin2 " is a constant defined as "; print get(x,'newnam); if x := get(x,'active!-annotation) then if pairp x then i!&dump car x else i!&dump x>>; expr procedure i!&recordp x; % I!&RECORDP(X) -- X is an id. Returns T if this looks like an RLISP % record. get(x,'formfn) eq 'form!_record!_constructor; expr procedure i!&record x; % I!&RECORD(X) -- X is an id and the name of a record constructor. Try % and display as much about the record as possible. Note that record % instances are handled by the vector case temporarily. << prin1 x; prin2t " is a record constructor with the following fields"; prin2t "** not implemented. **"; nil >>; expr procedure i!&recordinstp x; % I!&RECORDINSTP(X) -- Returns T if X (a vector) looks like a record % instance. begin scalar tmp; if not idp getv(x,0) then return nil; if not (tmp := getd getv(x,0)) then return nil; if not eqcar(getd getv(x,0),'macro) then return nil; if atom (tmp := errorset({getv(x,0)},nil,nil)) then return nil; if upbv x neq upbv car tmp then return nil; return t end; expr procedure i!&recordinst x; % x is identified as a record. << prin2 "A "; prin1 getv(x,0); prin2t " record with "; for i:=1:upbv x do << prin2 " "; prin1 i; prin2 ": "; print getv(x,i)>>; nil >>; expr procedure i!&functionp x; % I!&FUNCTIONP(X) -- X is an id. Returns T if it is also the name of a % function or SMACRO. get(x, 'smacro) or getd x; expr procedure i!&function x; % I!&FUNCTION(X) - X is a function or SMACRO name. Farm out the % description based on its type. if get(x, 'smacro) then i!&function!-smacro x else (if eqcar(w, 'macro) then i!&function!-macro(x, cdr w) else if eqcar(w, 'expr) then i!&function!-expr(x, cdr w) else if eqcar(w, 'fexpr) then i!&function!-fexpr(x, cdr w) else i!&function!-unknown(x, w)) where w := getd x; expr procedure i!&function!-smacro x; % I!&FUNCTION!-SMACRO(X) -- X is the name of an SMACRO. Display what we % know about it. begin scalar tmp, d; d := get(x, 'smacro); prin1 x; prin2 " is an SMACRO with "; if not (tmp := get(x, 'number!-of!-args)) then if eqcar(d, 'lambda) and cdr d then tmp := length cadr d else tmp := nil; if onep tmp then prin2t "one argument" else if not tmp then prin2t "an unknown number of arguments" else << prin1 tmp; prin2t " arguments" >>; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp>> end; expr procedure i!&function!-expr(x, d); % I!&FUNCTION!-EXPR(X, D) -- X is the name of an EXPR type function and % D is it's definition. Display what we know about it. begin scalar tmp; prin1 x; prin2 " is an EXPR with "; if not (tmp := get(x, 'number!-of!-args)) then if eqcar(d, 'lambda) and cdr d then tmp := length cadr d else tmp := nil; if onep tmp then prin2t "one argument" else if not tmp then prin2t "an unknown number of arguments" else << prin1 tmp; prin2t " arguments" >>; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&function!-fexpr(x, d); % I!&FUNCTION!-FEXPR(X, D) -- X is the name of an FEXPR type function % and D is its definition. Display what we know about it. begin scalar tmp; prin1 x; prin2t " is an FEXPR"; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&function!-macro(x, d); % I!&FUNCTION!-MACRO(X, D) -- X is the name of a MACRO type function and % D its definition. Display what we know. begin scalar tmp; prin1 x; prin2t " is a MACRO"; if tmp := get(x, 'active!-annotation) then << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >> end; expr procedure i!&whereis x; % I!&WHEREIS(X) -- We might have a (comment line-number file). If so, % display this information. if length x = 3 then << prin2 "Function ends on line "; prin1 cadr x; prin2 " in file "; prin2t caddr x >>; expr procedure i!&constantp x; % I!&CONSTANTP(X) - Returns T if X is a constant. constantp x; expr procedure i!&id x; % I!&ID(X) -- X is an id see if we can find out anything about it. if globalp x then i!&id1(x, 'global) else if fluidp x then i!&id1(x, 'fluid) else << prin2 "Don't know anything about "; print x; nil >>; expr procedure i!&id1(x, ty); % I!&ID1(X, TY) -- X is TY (global or fluid). Print out what we know % about this id. begin scalar a; prin2 "Identifier '"; prin1 x; prin2 "' is "; prin2 ty; if a := get(x, 'active!-annotation) then if length a = 3 then << prin2 " defined line "; prin1 cadr a; prin2 " in file "; prin2t caddr a; i!&dump car a >> else i!&dump a else terpri() end; expr procedure i!&constant x; % I!&CONSTANT(X) - X is some sort of constant. Not much we can say about % it. <<prin1 x; prin2t " is a constant">>; expr procedure i!&modulep x; % I!&MODULEP(X) - Returns T if x looks like a module. flagp(x, 'module); expr procedure i!&module x; % I!&MODULE(X) - Display the facts about a module. (if filep r88 then i!&module1(x, i!&moduleb x, r88) else if filep rd then i!&module1(x, i!&moduleb x, rd) else i!&module2 x) where r88 := string!-downcase compress nconc('!" . explode2 x, '(!. !r !8 !8 !")), rd := string!-downcase compress nconc('!" . explode2 x, '(!. !r !e !d !")); expr procedure i!&module1(mname, bfile, sfile); % I!&MODULE(MNAME, BFILE, SFILE) - Display data about module MNAME % with object file BFILE, source file SFILE. PSL/UNIX specific. begin scalar sfs, bfs; if sfile then sfs := filestatus sfile; if bfile then bfs := filestatus bfile; if sfile then if bfile then << prin2 "Module "; prin1 mname; prin2 " source file "; prin2 sfile; prin2 " fasl file "; prin2 bfile; prin2 " and is "; print i!&dcomp(sfs, bfs) >> else << prin2 "Module "; prin1 mname; prin2 " has source file "; prin2 sfile; prin2 " written "; prin2t i!&sdt sfs >> else if bfile then << prin2 "Module "; prin1 mname; prin2 " has fasl file "; prin2 bfile; prin2 " written "; prin2t i!&sdt bfs >> else << prin2 "Module "; prin1 mname; prin2t ", can't find any files." >>; if sfs := get(mname, 'active!-annotation) then if pairp sfs then i!&dump car sfs else i!&dump sfs; end; expr procedure i!&module2 mname; % I!&MODULE2(MNAME) - called when we don't know much about a module. << prin2 "Can't find source or fasl file for module "; print mname; if sfs then if pairp sfs then i!&dump car sfs else i!&dump sfs >> where sfs := get(mname, 'active!-annotation); expr procedure i!&dcomp(s1, s2); % I!&DCOMP(S1, S2) -- two PSL file statuses. Compare the WRITETIMES % and return " OUT OF DATE." or " UP TO DATE.". if i!&dt s1 > i!&dt s2 then " out of date." else " up to date."; expr procedure i!&dt x; (if w then cddr w else 0) where w := atsoc('writetime, x); expr procedure i!&sdt x; (if w then cadr w else "no date") where w := atsoc('writetime, x); expr procedure i!&moduleb x; % I!&MODULEB(X) - Find which directory LOADDIRECTORIES!* the .b file % is and return the file name. begin scalar fs, fn; fs := loaddirectories!* while pairp fs do << fn := string!-downcase nconc('!" . explode2 car fs, nconc(explode2 x, '(!. !b !"))); if filep fn then fs := fn else fs := cdr fs >>; return fs end; %----------------------------------------------------------------------- % Basic active comment formatting. Remove the leading blank from the % first line, all blanks at start of each subsequent line, but only % of the shortest line. expr procedure i!&dump x; % I!&DUMP(X) - X is a string or something. Display its characters but % dump blanks at the beginning of each line as appropriate. begin scalar lnes, minsp, v; lnes := reversip i!&makelines(explode2 x, {nil}); minsp := 5000; for each x in cdr lnes do if (v:= i!&spcount x) < minsp then minsp := v; i!&prn i!&delspace(5000, car lnes); for each l in cdr lnes do i!&prn i!&delspace(minsp, l) end; expr procedure i!&makelines(x, l); % I!&MAKELINES(X, L) -- Remove EOL's form x and convert to a list of % sentences. L is used to build this list, call this with L = NIL. if null x then reversip car l . cdr l else if eqcar(x, !$eol!$) then i!&makelines(cdr x, nil . (reversip car l . cdr l)) else << car l := car x . car l; i!&makelines(cdr x, l) >>; expr procedure i!&spcount l; % I!&SPCOUNT(l) -- Count spaces in front of line l and return. if null l then 0 else if eqcar(l, '! ) then add1 i!&spcount cdr l else 0; expr procedure i!&delspace(n, l); % I!&DELSPACE(N, L) -- Delete n spaces from the front of line L and % return a new list. Quit if the list is short or runs into some % non-blank character. if null l then nil else if zerop n then l else if eqcar(l, '! ) then i!&delspace(n - 1, cdr l) else l; expr procedure i!&prn x; % I!&PRN(x) -- Display the characters of list x and then terminate the % line. << for each c in x do prin2 c; terpri() >>; %----------------------------------------------------------------------- % Hacks to make active comments work. fluid '(!*saveactives); switch saveactives; expr procedure i!&makeComment; % I!&MAKECOMMENT() - returns (comment line file) for packing active % annotation data away. mkquote {cadr Comment!*, curline!*, if ifl!* then car ifl!* else "unknown"}; expr procedure nformproc(a, b, c); % NFORMPROC(A, B, C) -- Temporary wrapper for FORMPROC to save the % function active annotation if the SAVEACTIVES switch is on. Also % put the file name and current line out there. begin scalar v,w; v := if !*saveactives and comment!* then <<w := i!&makecomment(); put(cadr a,'active!-annotation,eval w); {'progn, {'cond,{'!*saveactives, {'put,mkquote cadr a,mkquote 'active!-annotation,w}}}, formproc(a, b, c)}>> else formproc(a, b, c); comment!* := nil; return v end; put('procedure,'formfn,'nformproc); expr procedure formmodule(u, vars, mode); % FORMMODULE(U,VARS,MODE) - Save any active annotation on the property % of the module. Clear comment after use. begin scalar x; x := if !*saveactives and Comment!* then {'progn, {'cond, {'!*saveactives, {'put, mkquote cadr u, mkquote 'active!-annotation, i!&makecomment()}}}, {'flag, mkquote {cadr u}, mkquote 'MODULE}, {'module, mkquote{cdr u}}} else {'module, mkquote cdr u}; Comment!* := nil; return x end; % put('module, 'formfn, 'formmodule); expr procedure formglobalfluid(u, vars, mode); % FORMGLOBALFLUID(U, VARS, MODE) -- Attach active annotation to the % variables declared. if !*saveactives and Comment!* then {{'lambda, {'!$v!$}, {'progn, {'cond, {'!*saveactives, {'mapcar, '!$v!$, {'function, {'lambda, {'!$u!$}, {'put, '!$u!$, mkquote 'active!-annotation, i!&makeComment()}}}}}}, {car u, '!$v!$}}}, formc(cadr u, vars, mode)} else {car u, formc(cadr u, vars, mode)}; % put('global, 'formfn, 'formglobalfluid); % put('fluid, 'formfn, 'formglobalfluid); expr procedure fmtcmt(ano, ind, rm); begin scalar la, ind3, tcs, c, coll, colle, curbl, cbl; la := explode2 ano; if (ind3 := ind + 3) > (rm - 10) then error(0, "margins too small"); tcs := rm - ind3; % Remove extra blanks from front. % la := deblank la; % STATE 1: Now scan the lines dumping tokens to the output. spaces ind; prin2 "/* "; loop: if null la then return prin2 " */"; if c := fmtfulllineof(car la, la) then << la := fmtremoveline la; for i:=1:tcs do prin2 c; terpri(); spaces ind3; go to loop >> else if fmtblankline la then << if posn() > ind3 then terpri(); terpri(); spaces ind3; la := fmtremoveline la; go to loop >> else if eqcar(la, !$eol!$) then << terpri(); spaces ind3;go to loop >> else if eqcar(la, '! ) then go to state4; % STATE 2: Collect characters to EOL, blank, or NIL. state2: coll := colle := {car la}; la := cdr la; state2a: if null la then << fmtdumptok(coll, ind3, rm); go to loop >> else if eqcar(la, !$eol!$) then << fmtdumptok(coll, ind3, rm); la := cdr la; go to loop >> else if eqcar(la, '! ) then << fmtdumptok(coll, ind3, rm); go to state3 >>; cdr colle := {car la}; colle := cdr colle; la := cdr la; go to state2a; % STATE 3: Skip blanks to NIL, EOL, or next token. state3: if null la then go to loop else if eqcar(la, !$eol!$) then << la := cdr la; go to loop >> else if eqcar(la, '! ) then << la := cdr la; go to state3 >> else go to state2; % STATE 4: We've got a line that starts with a blank. Dump it to the % output line. state4: curbl := 0; cbl := t; state4a: prin2 car la; if cbl and eqcar(la, '! ) then curbl := add1 curbl else cbl := nil; la := cdr la; if null la then go to loop; if eqcar(la, !$eol!$) then << terpri(); spaces ind3;la := cdr la; go to loop >>; if posn() >= rm then << terpri(); spaces(1 + ind3 + curbl) >>; go to state4a end; expr procedure fmtblankline l; % FMTBLANKLINE(L) -- returns T if the rest of the current line is % all blanks. if null l or eqcar(l, !$eol!$) then t else if eqcar(l, '! ) then fmtblankline cdr l; expr procedure fmtfulllineof(c, la); % FMTFULLLINEOF(C, LA) -- Returns C if LA up to the end or !$EOL!$ is % all one character. if null la then c else if eqcar(la, c) then fmtfulllineof(c, cdr la) else if eqcar(la, !$eol!$) then c else nil; expr procedure fmtremoveline la; % FMTREMOVELINE(LA) -- returns the remainder of LA up to the end or the % first !$EOL!$. if la and not eqcar(la, !$eol!$) then fmtremoveline cdr la else cdr la; expr procedure fmtdumptok(l, ind, rm); if (length l + posn()) > rm then << terpri(); spaces ind; for each x in l do prin2 x; prin2 " " >> else << for each x in l do prin2 x; if posn() <= rm then prin2 " " >>; endmodule; end;