| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273 |
- module smacro; % Support for SMACRO expansion.
- % Author: Anthony C. Hearn.
- % Copyright (c) 1987 The RAND Corporation. All rights reserved.
- symbolic procedure applsmacro(u,vals,name);
- % U is smacro body of form (lambda <varlist> <body>), VALS is
- % argument list, NAME is name of smacro.
- begin scalar body,remvars,varlist,w;
- varlist := cadr u;
- body := caddr u;
- if length varlist neq length vals
- then rerror(rlisp,15,list("Argument mismatch for SMACRO",name));
- if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body)
- then return subla!-q(pair(varlist,vals),body)
- else if length varlist>1
- then <<w := for each x in varlist collect (x . gensym());
- body := subla!-q(w,body);
- varlist := for each x in w collect cdr x>>;
- for each x in vals do
- <<if no!-side!-effectp x or one!-entryp(car varlist,body)
- then body := subla!-q(list(car varlist . x),body)
- else remvars := aconc(remvars,car varlist . x);
- varlist := cdr varlist>>;
- if null remvars then return body
- else <<w := list('lambda,
- for each x in remvars collect car x,
- body) .
- for each x in remvars collect cdr x;
- % if not eqcar(cadr w,'setq)
- % then <<prin2 "*** smacro: "; print cdr w>>;
- return w>>
- end;
- symbolic procedure no!-side!-effectp u;
- if atom u then numberp u or idp u and not(fluidp u or globalp u)
- else if car u eq 'quote then t
- else if flagp(car u,'nosideeffects)
- then no!-side!-effect!-listp cdr u
- else nil;
- symbolic procedure no!-side!-effect!-listp u;
- null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u;
- flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
- cddar cdddr cons),'nosideeffects);
- symbolic procedure one!-entryp(u,v);
- % determines if id U occurs less than twice in V.
- if atom v then t
- else if smemq(u,car v)
- then if smemq(u,cdr v) then nil else one!-entryp(u,car v)
- else one!-entryp(u,cdr v);
- symbolic procedure one!-entry!-listp(u,v);
- null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v);
- symbolic procedure subla!-q(u,v);
- begin scalar x;
- if null u or null v then return v
- else if atom v
- then return if x:= atsoc(v,u) then cdr x else v
- else if car v eq 'quote then return v
- else return(subla!-q(u,car v) . subla!-q(u,cdr v))
- end;
- put('smacro,'macrofn,'applsmacro);
- endmodule;
- end;
|
