reduce-historical/r38/packages/rlisp88/mstruct.red

module mstruct;  % A tiny structure package for Standard Lisp.

% Author: Bruce A. Florman.

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

comment

 DESCRIPTION

  (defstruct <structspec> [ <slotspec>... ] )

   The <structspec> may be either the name of the structure, or a list
  containing the name followed by zero or more options.  Each <slotspec>
  may be either a list containing the slot name and its default value,
  or simply the slot name, in which case the default value is NIL.

   Each option in the <structspec> may be either an option name, or a
  list containing the option name and a specified value.  If only the
  option name is given, then the default value for the given option is
  used.  If NIL is the specified value in an option, then the option is
  not used at all (in general a NIL value is the same as not having that
  option in the list at all).  If the same option appears more than once
  with different values, the last one in the <structspec> takes
  precedence.

 These are the valid options:

  PREDICATE
    Makes the zeroth element of the structure contain the structure name
    and creates a predicate macro to test if a given item is an instance
    of this structure.  The specified value is the name of the predicate
    macro.  The default value is the structure name followed by a `P'.

  CONSTRUCTOR
    By default the name of the constructor macro is `MAKE-' followed by
    the structure name.  You may provide a different constructor name
    with this option.  If there is no constructor option in the
    <structspec> the default constructor will still be generated.  The
    only way to completely suppress the generation of a constructor
    macro is to have a (CONSTRUCTOR NIL) option.

  The flag !*FASTSTRUCTS controls how the accessor macros expand.
  If it is NIL, they expand as GETVs, otherwise they expand as 
  IGETVs.

 NOTE: see records.tst for a level 0 test file.

 REVISION HISTORY
  07/19/85 BAF -- File created.
  01/26/89 BAF -- Added predicate and constructor macros so that 
      this code can replace the RLISP record code. 
      Changed  GetR to StructFetch, and !*FAST-RECORDS 
      to !*FASTSTRUCTS.  Added code to check the
      validity of the options.  Also added this file 
      header.
  01/30/89 BAF -- Added CONC-NAME as a synonym for SLOT-PREFIX and 
      the ExplodeId function for compatability with 
      existing programs (eg. ernie).
  Wed Apr 21 14:22:18 1993 - JBM Convert to RLISP '88, remove prefix
      stuff.
  Tue May 11 09:03:20 1993 - JBM Remove tconc and fix evaluator bug.
  Mon May 17 15:36:54 1993 - JBM Add RSETF function.
  Tue May 18 11:09:07 1993 - JBM add qputv for CSL to RSETF;

flag('(defstruct), 'eval);

fluid '(!*faststructs);

switch FASTSTRUCTS;

macro procedure defstruct u;
begin integer indx;
      scalar options,slot_forms,name,predicate,constructor,functions;
  options := get_defstruct_options cadr u;
  if cdr u
    then slot_forms := for each slot in cddr u
			  collect if idp slot then {slot,nil} else slot;
  name := car options;
  predicate := atsoc('predicate,cdr options);
  if predicate then predicate := cdr predicate;
  constructor := atsoc('constructor,cdr options);
  if constructor then constructor := cdr constructor;
  functions := NIL;
  if constructor then
   functions := build_defstruct_constructor_macro(name,
						  constructor,
						  slot_forms,
						  predicate)
		   . functions;
  if predicate then
     functions :=
       build_defstruct_predicate_function(name, predicate) . functions;
  indx := if predicate then 1 else 0;
  for each slot in slot_forms do
     <<functions :=
	    build_defstruct_accessor_macro(car slot, indx) . functions;
       indx := indx + 1>>;
  functions :=  mkquote name . functions;
  return 'progn  . reverse functions
end;

expr procedure get_defstruct_options u;
begin scalar name, options, predicate, constructor;
  if pairp u then << name := car u; options := cdr u >>
     else << name := u; options := nil >>;
  if  not idp name then error(0, {"bad defstruct name:", name});
  for each entry in options
      do if  entry eq 'predicate then
            predicate := intern compress append(explode name, '(p))
         else if eqcar(entry, 'predicate) then predicate := cadr entry
         else if entry eq 'constructor then
               constructor := intern compress append('(m a k e !! !-),
                                                    explode name)
	 else if eqcar(entry,'constructor)
	  then constructor := cadr entry
         else error(0, {"bad defstruct option:", entry});
  if null constructor then
    constructor := intern compress append('(m a k e !! !-),
					  explode name);
  return {name, 'predicate . predicate, 'constructor . constructor}
end;

expr procedure explodeid x;
% EXPLODEID(X) - Explode whatever x is and make sure the result can
% be compressed back into an id no matter what it is.
if idp x then explode x
  else for each elt in explode2 x join {'!!, elt};

expr procedure build_defstruct_constructor_macro
   (name,macro_name,slot_forms,has_predicate);
begin scalar dflts;
  dflts := for each x in slot_forms collect
     {'cons, mkquote car x, cadr x};
   % I deal with the name field by inserting it as an extra slot, with
   % slot-name made by a gensym so that the user will not get to
   % override the default value ever.  As coded here if the default
   % value of a slot depends on a variable called !$!$!$ then scope
   % issues will lead to silly results being generated.
  if has_predicate
    then dflts := {'cons, '(gensym), mkquote name} . dflts;
  return {'putd,
           mkquote macro_name,
           ''macro,
           mkquote {'lambda, '(!$!$!$),
                      {'list, ''defstructvector, 
                         {'mklist, {'defstruct_constructor,
                            '(cdr !$!$!$),
                            'list . dflts}}}}}
   end;

symbolic procedure mklist x; 'list . x;

expr procedure defstruct_constructor(u, dflts);
  for each d in dflts collect find_struct_key(car d, u, cdr d);

expr procedure find_struct_key(key, u, dflt);
  if null u then mkquote dflt
  else if car u eq key then
    if null cdr u then nil else cadr u
  else find_struct_key(key, cddr u, dflt);

expr procedure defstructvector l;
% DEFSTRUCTVECTOR(L) - Create a vector and store the list L into it.
% This is a portable substitute for PSL's list2vector.
begin integer i; scalar v;
  v := mkvect sub1 length l;
  i := 0;
  for each vl in l do <<putv(v,i,vl); i := i+1>>;
  return v
end;

expr procedure build_defstruct_predicate_function(name, fnname);
% BUILD_DEFSTRUCT_PREDICATE_FUNCTION(NAME, FNNAME) - Builds a defstruct
% predicate to return as a function.
{'de, fnname, '(x), 
  {'and, '(vectorp x), {'eq, mkquote name, '(igetv x 0)}}};

expr procedure build_defstruct_accessor_macro(slot_name,indx);
{'dm, slot_name, '(u), {'list, '(quote structfetch), '(cadr u), indx}};

macro procedure structfetch u;
  if !*faststructs  then 'igetv . cdr u else 'getv . cdr u;


%-----------------------------------------------------------------------
%                         SETF for RLISP88
%-----------------------------------------------------------------------

macro procedure rsetf u; expandrsetf(cadr u, caddr u);

expr procedure expandrsetf(lhs, rhs);
 if atom lhs then {'setq, lhs, rhs}
    else if eqcar(lhs, '!&VARIABLE_FETCH) then
        '!&VARIABLE_STORE . append(cdr lhs, {rhs})
    else if get(car lhs, 'ASSIGN_OP) then
         get(car lhs, 'ASSIGN_OP) . append(cdr lhs, {rhs})
    else if getd car lhs and eqcar(getd car lhs, 'macro) then
        expandrsetf(apply(cdr getd car lhs, {lhs}), rhs)
    else error(0, {lhs, "bad RSETF form"});

deflist('((getv putv) (igetv putv) (car rplaca) (cdr rplacd)),
	'ASSIGN_OP);

% This is CSL specific but shouldn't hurt anybody.
put('qgetv, 'ASSIGN_OP, 'qputv);

endmodule;

end;