Artifact 1f8195fb2c8e91e60421d2b71d98bdc9cbbc6b15c156f4ec0cc50a74c11bae02:
- Executable file
r37/packages/rlisp88/mstruct.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: 8130) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/rlisp88/mstruct.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: 8130) [annotate] [blame] [check-ins using]
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;