File r38/packages/rlisp/rsupport.red from the latest check-in

module rsupport;   % Basic functions needed to support RLISP and REDUCE.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

fluid '(!*backtrace);

global '(!*comp);

symbolic procedure aconc(u,v);
   % Adds element v to the tail of u. u is destroyed in process.
   nconc(u,list v);

symbolic procedure arrayp u; get(u,'rtype) eq 'array;

symbolic procedure atsoc(u,v);
   % This definition allows for a search of a general list.
   if null v then nil
    else if eqcar(car v,u) then car v
    else atsoc(u,cdr v);

symbolic procedure copyd(new,old);
   % Copy the function definition from old id to new.
   begin scalar x;
      x := getd old;
      if null x
	then rerror('rlisp,1,list(old,"has no definition in copyd"));
      putd(new,car x,cdr x);
      return new
   end;

symbolic procedure eqcar(u,v); null atom u and car u eq v;

symbolic procedure errorset!*(u,v); errorset(u,v,!*backtrace);

symbolic procedure errorset2 u;
   begin scalar !*protfg;
      !*protfg := t;
      return errorset(u,nil,nil)
   end;

symbolic procedure flagpcar(u,v);
   null atom u and idp car u and flagp(car u,v);

symbolic procedure idlistp u;
   % True if u is a list of id's.
   null u or null atom u and idp car u and idlistp cdr u;

symbolic procedure listp u;
   % Returns T if U is a top level list.
   null u or null atom u and listp cdr u;

symbolic procedure mkprog(u,v); 'prog . (u . v);

symbolic procedure mkquote u; list('quote,u);

symbolic procedure mksetq(u,v);
   if atom u then list('setq,u,v)
    else begin scalar x;
       if (x := get(car u,'setfn)) then return apply2(x,u,v)
	else typerr(u,"assignment argument")
    end;

symbolic procedure pairvars(u,vars,mode);
   % Sets up pairings of parameters and modes.
   begin scalar x;
   a: if null u then return append(reversip!* x,vars)
       else if null idp car u or get(car u,'infix) or get(car u,'stat)
	     then symerr(list("Invalid parameter:",car u),nil);
      x := (car u . mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure prin2t u; progn(prin2 u, terpri(), u);

% The following is included for compatibility with some old code.
% Its use is discouraged.

symbolic procedure princ u; prin2 u;

symbolic procedure putc(name,type,body);
   % Defines a non-standard function, such as an smacro. Returns NAME.
   begin
      if !*comp and flagp(type,'compile) then compd(name,type,body)
       else put(name,type,body);
      return name
   end;

% flag('(putc),'eval);

symbolic procedure reversip u;
   begin scalar x,y;
    a:  if null u then return y;
        x := cdr u; y := rplacd(u,y); u := x;
        go to a
   end;

symbolic procedure smemq(u,v);
   % True if id U is a member of V at any level (excluding quoted
   % expressions).
   if atom v then u eq v
    else if car v eq 'quote then nil
    else smemq(u,car v) or smemq(u,cdr v);

symbolic procedure subsetp(u,v);
   % True if u is a subset of v.
   null u or car u member v and subsetp(cdr u,v);

symbolic procedure union(x,y);
   if null x then y
    else union(cdr x,if car x member y then y else car x . y);

symbolic procedure intersection(u,v);
   % This definition is consistent with PSL.
   if null u then nil
    else if car u member v
     then car u . intersection(cdr u,delete(car u,v))
    else intersection(cdr u,v);

symbolic procedure u>=v; null(u<v);

symbolic procedure u<=v; null(u>v);

symbolic procedure u neq v; null(u=v);

symbolic procedure setdiff(u,v);
   if null v then u
    else if null u then nil
    else setdiff(delete(car v,u),cdr v);

% symbolic smacro procedure u>=v; null(u<v);

% symbolic smacro procedure u<=v; null(u>v);

% symbolic smacro procedure u neq v; null(u=v);

% List changing alternates (may also be defined as copying functions).

symbolic procedure aconc!*(u,v); nconc(u,list v);  % append(u,list v);

symbolic procedure nconc!*(u,v); nconc(u,v);       % append(u,v);

symbolic procedure reversip!* u; reversip u;       % reverse u;

symbolic procedure rplaca!*(u,v); rplaca(u,v);     % v . cdr u;

symbolic procedure rplacd!*(u,v); rplacd(u,v);     % car u . v;

% The following functions should be provided in the compiler for
% efficient coding.

symbolic procedure lispapply(u,v);
   % I'd like to use idp in the following test, but the TPS package
   % stores code pointers on property lists which then get used here.
   if null atom u
     then rerror('rlisp,2,list("Apply called with non-id arg",u))
    else apply(u,v);

symbolic procedure lispeval u; eval u;

symbolic procedure apply1(u,v); apply(u,list v);

symbolic procedure apply2(u,v,w); apply(u,list(v,w));

symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x));

% The following function is needed by several modules. It is more
% REDUCE-specific than other functions in this module, but since it
% needs to be defined early on, it might as well go here.

symbolic procedure gettype u;
   % Returns a REDUCE-related type for the expression U.
   % It needs to be more table driven than the current definition.
   if numberp u then 'number
    else if null atom u or null u or null idp u then 'form
    else if get(u,'simpfn) then 'operator
    else if get(u,'avalue) then car get(u,'avalue) 
    else if getd u then 'procedure
    else if globalp u then 'global
    else if fluidp u then 'fluid
    else if flagp(u,'parm) then 'parameter
    else get(u,'rtype);

endmodule;

end;