File r38/packages/rlisp88/inspect.red artifact 6e221d41ed part of check-in aacf49ddfa


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;


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]