File r38/packages/alg/mkgroup.red artifact 4bdca8a4f8 part of check-in c70d02b470

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;