reduce-historical/r37/packages/rlisp/form.red

module form;  % Performs a mode analysis of parsed forms.

% Author: Anthony C. Hearn.

% Modifications by: Jed Marti, Arthur C. Norman.

% Copyright (c) 1993 RAND.  All rights reserved.

fluid '(!*!*a2sfn !*cref !*defn !*mode !*reduce4 !*rlisp88
	current!-modulus fname!* ftype!*);

global '(!*argnochk !*comp !*composites !*force !*micro!-version
	 !*vars!* cursym!*);

!*!*a2sfn := 'aeval;

flag('(algebraic symbolic),'modefn);

symbolic procedure formcond(u,vars,mode);
   'cond . formcond1(cdr u,vars,mode);

symbolic procedure formcond1(u,vars,mode);
   if null u then nil
    else list(formbool(caar u,vars,mode),formc(cadar u,vars,mode))
       % FORM1 here leaves out top level REVAL.
              . formcond1(cdr u,vars,mode);

put('cond,'formfn,'formcond);

symbolic procedure formlamb(u,vars,mode);
   list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode));

put('lambda,'formfn,'formlamb);

symbolic procedure formprogn(u,vars,mode);
   'progn . formclis(cdr u,vars,mode);

put('progn,'formfn,'formprogn);

symbolic procedure expdrmacro u;
   % Returns the macro form for U if expansion is permitted.
   begin scalar x;
      if null(x := getrmacro u) or flagp(u,'noexpand) then return nil
%      else if null(null !*cref and (null !*defn or car x eq 'smacro)
%         or flagp(u,'expand) or !*force)
       else if !*cref and null flagp(u,'expand) and null !*force
	then return nil
       else return x
   end;

symbolic procedure getrmacro u;
   %returns a Reduce macro definition for U, if one exists,
   %in GETD format;
   begin scalar x;
      return if not idp u then nil
       else if (x := getd u) and car x eq 'macro then x
       else if (x := get(u,'smacro)) then 'smacro . x
       else nil
   end;

symbolic procedure applmacro(u,v,w); apply1(u,w . v);

put('macro,'macrofn,'applmacro);

flag('(ed go quote),'noform);

symbolic procedure set!-global!-mode u;
   begin
      !*mode := u;
      return list('null,list('setq,'!*mode,mkquote u))
   end;

symbolic procedure form1(u,vars,mode);
   begin scalar x,y;
      if atom u
        then return if not idp u then u
                     else if u eq 'ed then list u
                     else if flagp(u,'modefn) then set!-global!-mode u
                     else if x:= get(mode,'idfn)
                      then apply2(x,u,vars)
                     else u
       else if not atom car u then return form2(u,vars,mode)
       else if not idp car u then typerr(car u,"operator")
       else if flagp(car u,'noform) then return u
       else if arrayp car u
%         and (mode eq 'symbolic or intexprlisp(cdr u,vars))
	  and mode eq 'symbolic
        then return list('getel,intargfn(u,vars,mode))
       else if cdr u and (get(car u,'rtype) eq 'vector
             or vectorp cadr u or flagpcar(cadr u,'vecfn))
        then return getvect(u,vars,mode)
       else if flagp(car u,'modefn)
        then return convertmode(cadr u,vars,mode,car u)
       else if (x := get(car u,'formfn))
	then return macrochk(apply3(x,u,vars,mode),mode)
       else if get(car u,'stat) eq 'rlis
        then return macrochk(formrlis(u,vars,mode),mode)
%      else if (x := getd car u) and eqcar(x, 'macro) and
%              not(mode eq 'algebraic) then
%            return <<x := apply3(cdr x,u,vars,mode);
%                     formc(x,vars,mode) >>
%      else if flagp(car u,'type) then blocktyperr car u
       else if car u eq '!*comma!*
        then if not atom cadr u and atom caddr u
                 and flagp(caadr u,'type)
%                and(get(caddr u,'stat) eq 'decstat)
               then blocktyperr caadr u
	      else rerror('rlisp,10,
			  list("Syntax error: , invalid after",cadr u));
      % Exclude algebraic operator with same name as symbolic function.
      if mode eq 'symbolic or flagp(car u,'opfn)
	then argnochk u;
      x := formlis(cdr u,vars,mode);
      y := if x=cdr u then u else car u . x;
      return if mode eq 'symbolic
              or get(car u,'stat)
              or cdr u and eqcar(cadr u,'quote)
                       and null(!*micro!-version and null !*defn)
              or intexprnp(y,vars) and null !*composites
		 and current!-modulus=1
               then macrochk(y,mode)
              else if not(mode eq 'algebraic)
               then convertmode(y,vars,mode,'algebraic)
              else ('list . algid(car u,vars) . x)
   end;

symbolic procedure form2(u,vars,mode);
   begin scalar x;
      if x := get(caar u,'form2fn) then return apply3(x,u,vars,mode)
	else typerr(car u,"operator")
   end;

put('lambda,'form2fn,'formlis);

symbolic procedure argnochk u;
   begin scalar x;
      if null !*argnochk then return u
       else if (x := argsofopr car u) and x neq length cdr u
	  %% and null get(car u,'simpfn)
	  and null (get(car u,'simpfn) or get(car u,'psopfn)) % FJW ?????
	then rerror('rlisp,11,list(car u,"called with",
				   length cdr u,
				   if length cdr u=1 then "argument"
				    else "arguments",
				   "instead of",x))
      else return u
   end;

symbolic procedure argsofopr u;
   % This function may be optimizable in various implementations.
   get(u,'number!-of!-args);

symbolic procedure intexprnp(u,vars);
   %determines if U is an integer expression;
    if atom u then if numberp u then fixp u
                   else if (u := atsoc(u,vars)) then cdr u eq 'integer
                   else nil
     else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars);

symbolic procedure intexprlisp(u,vars);
   null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars);

flag('(difference minus plus times),'intfn);
   % EXPT is not included in this list, because a negative exponent can
   % cause problems (i.e., result can be rational);

symbolic procedure formlis(u,vars,mode);
   begin scalar x;
   a: if null u then return reversip!* x;
      x := form1(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure formclis(u,vars,mode);
   begin scalar x;
   a: if null u then return reversip!* x;
      x := formc(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure form u;
   if null atom u and flagp(car u,'always_nform)
     then n_form u   % REDUCE 4.
    else if null !*rlisp88 then form1(u,!*vars!*,!*mode)
    else if null(!*mode eq 'symbolic)
	or flagp(u,'modefn) and null(u eq 'symbolic)
	or flagpcar(u,'modefn) and null(car u eq 'symbolic)
     then typerr("algebraic expression","Rlisp88 form")
    else form1(u,!*vars!*,!*mode);

symbolic procedure macrochk(u,mode);
   begin scalar y;
      % Expands U if CAR U is a macro and expansion allowed.
      % This model has the problem that nested macros are not expanded
      % at this point (but they will be in the compiler).
      if atom u then return u
       else if (y := expdrmacro car u)
        and (mode eq 'symbolic or idp car u and flagp(car u,'opfn))
	then return apply3(get(car y,'macrofn),cdr y,cdr u,car u)
       else return u
   end;

put('symbolic,'idfn,'symbid);

symbolic procedure symbid(u,vars);
   <<if fname!* and null(ftype!* memq '(macro smacro))
       and not(atsoc(u,vars) or fluidp u or globalp u
	or null u or u eq t or flagp(u,'share) or !*comp)
       then lprim list("nonlocal use of undeclared variable",u,
		       "in procedure",fname!*);
     u>>;

put('algebraic,'idfn,'algid);

symbolic procedure algid(u,vars);
   if atsoc(u,vars) or flagp(u,'share) then u else mkquote u;

put('integer,'idfn,'intid);

symbolic procedure intid(u,vars);
   begin scalar x,y;
      return if (x := atsoc(u,vars))
        then if cdr x eq 'integer then u
               else if y := get(cdr x,'integer)
                then apply2(y,u,vars)
               else if cdr x eq 'scalar then !*!*a2i(u,vars)
	       else rerror('rlisp,12,
			   list(cdr x,"not convertable to INTEGER"))
      else !*!*a2i(mkquote u,vars)
   end;

symbolic procedure convertmode(exprn,vars,target,source);
   convertmode1(form1(exprn,vars,source),vars,target,source);

symbolic procedure convertmode1(exprn,vars,target,source);
   begin scalar x;
      if source eq 'real then source := 'algebraic;
      if target eq 'real then target := 'algebraic;
      if target eq source then return exprn
       else if idp exprn and (x := atsoc(exprn,vars))
          and not(cdr x memq '(integer scalar real))
          and not(cdr x eq source)
        then return convertmode(exprn,vars,target,cdr x)
       else if not (x := get(source,target))
        then typerr(source,target)
       else return apply2(x,exprn,vars)
   end;

put('algebraic,'symbolic,'!*!*a2s);

put('symbolic,'algebraic,'!*!*s2a);

symbolic procedure !*!*a2s(u,vars);
   % It would be nice if we could include the ATSOC(U,VARS) line,
   % since in many cases that would save recomputation. However,
   % in any sequential process, assignments or substitution rules
   % can change the value of a variable, so we have to check its
   % value again.  More comprehensive analysis could certainly
   % optimize this.  We could also avoid wrapping an integer, thus
   % making a mode change only occur within an expression.
   if null u then rederr "tell Hearn!!"
%   else if constantp u and null fixp u
%     or intexprnp(u,vars) and null !*composites
%                and null current!-modulus
    else if flagpcar(u,'nochange) and not(car u eq 'getel)
     then u
    % Expressions involving "random" cannot be cached.
    else if smember('random,u) then
     list(list('lambda,'(!*uncached),list(!*!*a2sfn,u)),t)
    else list(!*!*a2sfn,u);

symbolic procedure !*!*s2a(u,vars); u;

symbolic procedure formc(u,vars,mode);
   %this needs to be generalized;
   if !*rlisp88 and flagpcar(u,'modefn) and null(car u eq 'symbolic)
     then typerr("algebraic expression","Rlisp88 form")
    else if mode eq 'algebraic and intexprnp(u,vars) then u
    else convertmode(u,vars,'symbolic,mode);

symbolic procedure intargfn(u,vars,mode);
   % transforms array element U into expression with integer arguments.
   % Array name is treated as an algebraic variable;
   begin scalar x,y;
      y := cdr u;
   a: if y then progn(x := convertmode(car y,vars,'integer,mode) . x,
		      y := cdr y,
		      go to a);
      return 'list . form1(car u,vars,'algebraic) . reversip!* x
   end;

put('algebraic,'integer,'!*!*a2i);

symbolic procedure !*!*a2i(u,vars);
   if intexprnp(u,vars) then u else list('ieval,u);

symbolic procedure ieval u; !*s2i reval u;

flag('(ieval),'opfn);   % To make it a symbolic operator.

flag('(ieval),'nochange);

put('symbolic,'integer,'!*!*s2i);

symbolic procedure !*!*s2i(u,vars);
   if fixp u then u else list('!*s2i,u);

symbolic procedure !*s2i u;
   if fixp u then u else typerr(u,"integer");

put('integer,'symbolic,'identity);

symbolic procedure identity(u,vars); u;

symbolic procedure formbool(u,vars,mode);
   if mode eq 'symbolic then formc(u,vars,mode)
    else if atom u then if u eq 't then u
           else if not idp u or atsoc(u,vars)
           then list('boolvalue!*,u)
          else list('boolvalue!*,formc!*(u,vars,mode))
    else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u
    else if idp car u and get(car u,'boolfn)
     then get(car u,'boolfn) . formclis(cdr u,vars,mode)
    else if idp car u and flagp(car u,'boolean)
	then car u . formboollis(cdr u,vars,mode,flagp(car u,'boolargs))
    else if car u eq 'boolvalue!* then rederr("Too many formbools")
    else if car u eq 'where
     then list('boolvalue!*,
	   formc!*(list('where,
		   mkquote list('bool!-eval,formbool(cadr u,vars,mode)),
		   caddr u),
		   vars,mode))
    else list('boolvalue!*,formc!*(u,vars,mode));

symbolic procedure formboollis(u,vars,mode,bool);
   begin scalar x;
   a: if null u then return reversip!* x
       else if bool then x := formbool(car u,vars,mode) . x
       else x := formc!*(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure bool!-eval u; lispeval u;

flag('(bool!-eval),'noform);

flag('(bool!-eval),'opfn);  % symbolic operator bool!-eval.

flag('(bool!-eval),'noval);

symbolic procedure boolvalue!* u; u and null(u = 0);

symbolic procedure formc!*(u,vars,mode);
   begin scalar !*!*a2sfn;
      !*!*a2sfn := 'revalx;
      return formc(u,vars,mode)
   end;

symbolic procedure revalx u;
   % Defined this way to handle standard form kernels in pattern
   % matching.
   reval if not atom u and not atom car u then prepf u else u;

% Functions with side effects must be handled carefully in this model,
% otherwise they are not always evaluated within blocks.

symbolic procedure formrerror(u,vars,mode);
   begin scalar x;
      argnochk u;
      if not fixp caddr u then typerr(caddr u,"RERROR argument");
      x := formc!*(cadddr u,vars,mode);
      if idp cadr u then return list('rerror,mkquote cadr u,caddr u,x)
       else if eqcar(cadr u,'quote) and idp cadadr u
	then return list('rerror,cadr u,caddr u,x)
       else typerr(cadr u,"RERROR argument")
   end;

deflist('((rerror formrerror)),'formfn);   % For bootstrapping.

symbolic procedure formrederr(u,vars,mode);
   list('rederr,formc!*(cadr u,vars,mode));

put('rederr,'formfn,'formrederr);

symbolic procedure formreturn(u,vars,mode);
%  begin scalar x;
%     x := form1(cadr u,vars,mode);  % FORMC here would add REVAL
%     if not(mode memq '(symbolic integer real))
%        and eqcar(x,'setq)             % Should this be more general?
%       then x := list(!*!*a2sfn,x);
%     return list('return,x)
%  end;
   list('return,formc(cadr u,vars,mode));

put('return,'formfn,'formreturn);

symbolic procedure rsverr x;
   rerror('rlisp,13,list (x,"is a reserved identifier"));

symbolic procedure mksetshare(u,v);
   mksetq(u,list('progn,'(setq alglist!* (cons nil nil)),v));

symbolic procedure formsetq(u,vars,mode);
   begin scalar x,y,z;
     if idp(z := car(u := cdr u)) then y := atsoc(z,vars);
     if eqcar(cadr u,'quote) then mode := 'symbolic;
      % Make target always SYMBOLIC so that algebraic expressions
      % are evaluated before being stored.
      x := convertmode(cadr u,vars,'symbolic,mode);
      return if not atom z
	then if not idp car z then typerr(z,"assignment")
	  else if null atom(z := macrochk(z,mode)) and arrayp car z
	   then list('setel,intargfn(z,vars,mode),x)
	  else if null atom z
	       and cdr z and (get(car z,'rtype) eq 'vector
			      or vectorp cadr z
			      or flagpcar(cadr z,'vecfn))
	   then putvect(u,vars,mode)
	  else if eqcar(z,'part)
	   then aconc('list .
		      mkquote 'setpart!* . formlis(cdr z,vars,mode),x)
	  else if null atom z and (y := get(car z,'setqfn))
	   then form1(applsmacro(y,append(cdr z,cdr u),nil),vars,mode)
	  else if mode eq 'symbolic
	     and (!*rlisp88 or eqcar(z,'structfetch))
	  % Allow for Rlisp '88 records in general Rlisp.
	   then list('rsetf,form1(z,vars,mode),x)
	  else list('setk,form1(z,vars,'algebraic),x)
	     % algebraic needed above, since SETK expects it.
    else if not idp z then typerr(z,"assignment")
    else if flagp(z,'reserved) and null atsoc(z,vars) then rsverr z
    else if flagp(z,'share) then mksetshare(symbid(z,vars),x)
    else if mode eq 'symbolic or y or eqcar(x,'quote)
     then mksetq(symbid(z,vars),x)
    else if vectorp cadr u or flagpcar(cadr u,'vecfn)
     then list('setv,mkquote z,cadr u)
    else list('setk,mkquote z,x)
   end;

put('setq,'formfn,'formsetq);

% Table of SETQFNs.

symbolic procedure setcar(a,b); progn(rplaca(a,b),b);

symbolic procedure setcdr(a,b); progn(rplacd(a,b),b);

put('car,'setqfn,'(lambda (u v) (setcar u v)));

put('cdr,'setqfn,'(lambda (u v) (setcdr u v)));

put('caar,'setqfn,'(lambda (u v) (setcar (car u) v)));

put('cadr,'setqfn,'(lambda (u v) (setcar (cdr u) v)));

put('cdar,'setqfn,'(lambda (u v) (setcdr (car u) v)));

put('cddr,'setqfn,'(lambda (u v) (setcdr (cdr u) v)));

put('caaar,'setqfn,'(lambda (u v) (setcar (caar u) v)));

put('caadr,'setqfn,'(lambda (u v) (setcar (cadr u) v)));

put('cadar,'setqfn,'(lambda (u v) (setcar (cdar u) v)));

put('caddr,'setqfn,'(lambda (u v) (setcar (cddr u) v)));

put('cdaar,'setqfn,'(lambda (u v) (setcdr (caar u) v)));

put('cdadr,'setqfn,'(lambda (u v) (setcdr (cadr u) v)));

put('cddar,'setqfn,'(lambda (u v) (setcdr (cdar u) v)));

put('cdddr,'setqfn,'(lambda (u v) (setcdr (cddr u) v)));

put('caaaar,'setqfn,'(lambda (u v) (setcar (caaar u) v)));

put('caaadr,'setqfn,'(lambda (u v) (setcar (caadr u) v)));

put('caadar,'setqfn,'(lambda (u v) (setcar (cadar u) v)));

put('caaddr,'setqfn,'(lambda (u v) (setcar (caddr u) v)));

put('cadaar,'setqfn,'(lambda (u v) (setcar (cdaar u) v)));

put('cadadr,'setqfn,'(lambda (u v) (setcar (cdadr u) v)));

put('caddar,'setqfn,'(lambda (u v) (setcar (cddar u) v)));

put('cadddr,'setqfn,'(lambda (u v) (setcar (cdddr u) v)));

put('cdaaar,'setqfn,'(lambda (u v) (setcdr (caaar u) v)));

put('cdaadr,'setqfn,'(lambda (u v) (setcdr (caadr u) v)));

put('cdadar,'setqfn,'(lambda (u v) (setcdr (cadar u) v)));

put('cdaddr,'setqfn,'(lambda (u v) (setcdr (caddr u) v)));

put('cddaar,'setqfn,'(lambda (u v) (setcdr (cdaar u) v)));

put('cddadr,'setqfn,'(lambda (u v) (setcdr (cdadr u) v)));

put('cdddar,'setqfn,'(lambda (u v) (setcdr (cddar u) v)));

put('cddddr,'setqfn,'(lambda (u v) (setcdr (cdddr u) v)));

put('nth,'setqfn,'(lambda (l i x) (setcar (pnth l i) x)));

put('getv,'setqfn,'(lambda (v i x) (putv v i x)));

put('igetv,'setqfn,'(lambda (v i x) (iputv v i x)));

symbolic procedure formfunc(u,vars,mode);
   if idp cadr u then if getrmacro cadr u
     then rerror('rlisp,14,list("Macro",cadr u,"Used as Function"))
        else list('function,cadr u)
    else list('function,form1(cadr u,vars,mode));

put('function,'formfn,'formfunc);

% RLIS is a parser function that reads a list of arguments and returns
% this list as one argument.  It needs to be defined in this module for
% bootstrapping purposes since this definition only works with its form
% function.

symbolic procedure rlis;
   begin scalar x;
        x := cursym!*;
	return if flagp(scan(),'delim) then list(x,nil)
		else if !*reduce4
		 then list(x,'list . remcomma xread1 'lambda)
                else x . remcomma xread1 'lambda
   end;

symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end;

symbolic procedure rlistat u;
   begin
    a:  if null u then return nil;
        put(car u,'stat,'rlis);
        u := cdr u;
        go to a
   end;

rlistat '(flagop);

symbolic procedure formrlis(u,vars,mode);
   if not flagp(car u,'flagop)
     then list(car u,'list .
		  if car u eq 'share
		    then (begin scalar x,y;
			     y := cdr u;
			  a: if null y then return reversip!* x;
			     x := mkquote car y . x;
			     y := cdr y;
			     go to a
			 end)
		   else formlis(cdr u,vars,'algebraic))
    else if not idlistp cdr u 
     then typerr('!*comma!* . cdr u,"identifier list")
    else list('flag,
	      'list . formlis(cdr u,vars,'algebraic),mkquote car u);

symbolic procedure mkarg(u,vars);
   % Returns the "unevaled" form of U.
   if null u or constantp u then u
    else if atom u then if atsoc(u,vars) then u else mkquote u
    else if car u memq '(quote !:dn!: !:int!:) then mkquote u
    else begin scalar x;
	 a: if null u then return 'list . reversip!* x;
	    x := mkarg(car u,vars) . x;
	    u := cdr u;
	    go to a
	 end;

% Form functions needed for number input.

put('!:dn!:,'formfn,'dnform);

% symbolic procedure dnform(u,vars,mode);
%    if mode eq 'symbolic
%      then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u)
%     else progn(if !*adjprec then precmsg length explode abs cadr u,
%                mkquote(quote !:rd!: . cdr u));

symbolic procedure dnform(u,vars,mode);
   if mode eq 'symbolic
     then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u)
    else progn(if !*adjprec then precmsg length explode abs cadr u,
	       mkquote if cddr u >= 0
			 then decimal2internal(cadr u,cddr u)
			else u);

put('!:int!:,'formfn,'intform);

symbolic procedure intform(u,vars,mode);
   if mode eq 'symbolic then mkquote cadr u
   else progn(precmsg length explode abs cadr u, mkquote cadr u);

endmodule;

end;