
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

SYMBOLIC PROCEDURE MKGROUP;
   %Expects a list of statements terminated by a >>;
   BEGIN SCALAR LST,DELIM;
    A:      LST := ACONC(LST,XREAD 'GROUP);
        IF CURSYM!* EQ '!*RSQB!* THEN GO TO B
         ELSE IF NULL DELIM THEN DELIM := CURSYM!*
         ELSE IF NOT(DELIM EQ CURSYM!*)
          THEN SYMERR("Syntax error: mixed , and ; in group",NIL);
        GO TO A;
    B:  SCAN();
        RETURN IF DELIM EQ '!*SEMICOL!* THEN 'PROGN . LST
                ELSE 'VECT . LST
   END;

PUT('!*LSQB!*,'STAT,'MKGROUP);

NEWTOK '((![) !*LSQB!*);

NEWTOK '((!]) !*RSQB!*);

SYMBOLIC PROCEDURE FORMVECT(U,VARS,MODE);
   BEGIN INTEGER N; SCALAR V;
      U := FOR EACH X IN U COLLECT FORM1(X,VARS,MODE); % was FORMC
      V := MKVECT(LENGTH U-1);
      N := 0;
      FOR EACH X IN U DO <<PUTV(V,N,X); N := N+1>>;
      RETURN V
   END;

PUT('VECT,'FORMFN,'FORMVECT);

PUT('VECEXPRP,'EVFN,'EVVECTOR);

SYMBOLIC PROCEDURE !*!*A2S(U,VARS);
   IF U = '(QUOTE NIL) THEN NIL
%   else if eqcar(u,'for) and not(cadddr u eq 'do)
%    then list('foraeval,u)
    ELSE IF VECTORP U THEN LIST(!*!*A2SFN,U)
    ELSE IF NULL U OR CONSTANTP U AND NULL FIXP U
      OR INTEXPRNP(U,VARS) AND NULL !*COMPOSITES
      OR NOT ATOM U AND IDP CAR U
         AND FLAGP(CAR U,'NOCHANGE) AND NOT(CAR U EQ 'GETEL)
     THEN U
    ELSE LIST(!*!*A2SFN,U);

SYMBOLIC PROCEDURE VECEXPRP U;
   % Determines if U is a valid vector expression.
   IF VECTORP U THEN T
    ELSE IF ATOM U THEN NIL
    ELSE IF CAR U EQ 'PLUS THEN VECEXPRLISP CDR U
    ELSE IF CAR U EQ 'TIMES THEN ONEVECEXPRLISP CDR U
    ELSE IF CAR U EQ 'MINUS THEN VECEXPRP CADR U
    ELSE IF CAR U EQ 'QUOTIENT
     THEN VECEXPRP CADR U AND NOT VECEXPRP CADDR U
    ELSE NIL;

SYMBOLIC PROCEDURE VECEXPRLISP U;
   NULL U OR VECEXPRP CAR U AND VECEXPRLISP CDR U;

SYMBOLIC PROCEDURE ONEVECEXPRLISP U;
   IF NULL U THEN NIL
    ELSE IF VECEXPRP CAR U THEN NOTVECEXPRLISP CDR U
    ELSE ONEVECEXPRLISP CDR U;

SYMBOLIC PROCEDURE NOTVECEXPRLISP U;
   NULL U OR NOT VECEXPRP CAR U AND NOTVECEXPRLISP CDR U;

SYMBOLIC PROCEDURE EVVECTOR(u,v);
   % Simplification function for a vector expression.
   IF VECTORP U THEN EVVECT(U,NIL,NIL)
    ELSE NIL;

SYMBOLIC PROCEDURE EVVECT(U,OPR,ARG);
   BEGIN INTEGER N; SCALAR V;
      N := UPBV U;
      V := MKVECT N;
      FOR I := 0:N DO PUTV(V,I,
                           REVAL IF NULL OPR THEN GETV(U,I)
                                  ELSE LIST(OPR,GETV(U,I),ARG));
      RETURN V
   END;

END;
