reduce-historical/r38/packages/rlisp88/rvector.red

module rvector; % Definition of RLISP vectors and operations on them.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

fluid '(!*fastvector);

global '(cursym!*);

switch fastvector;

% Add to system table.

flag('(vec!*),'vecfn);

% Parsing interface.

symbolic procedure xreadvec;
   % Expects a list of expressions enclosed by [, ].
   begin scalar cursym,delim,lst;
	if scan() eq '!*rsqb!* then <<scan(); return list 'list>>;
    a:	lst := aconc(lst,xread1 'group);
        cursym := cursym!*;
        scan();
	if cursym eq '!*rsqb!*
          then return if delim eq '!*semicol!* then 'progn . lst
		       else list('vec!*,'list . lst)
         else if null delim then delim := cursym
         else if not(delim eq cursym)
	  then symerr("Syntax error: mixed , and ; in vector",nil);
        go to a
   end;

put('!*lsqb!*,'stat,'xreadvec);

newtok '((![) !*lsqb!*);

newtok '((!]) !*rsqb!*);

flag('(!*rsqb!*),'delim);

flag('(!*rsqb!*),'nodel);

symbolic procedure vec!* u;
   % Make a vector out of elements of u.
   begin scalar n,x;
      n := length u - 1;
      x := mkvect n;
      for i:= 0:n do <<putv(x,i,car u); u := cdr u>>;
      return x
   end;

% Evaluation interface.

% symbolic procedure setv(u,v);
%   <<set(u,v); put(u,'rtype,'vector); v>>;


% Length interface.


% Printing interface.


% Definitions of operations on vectors.

symbolic procedure getvect(u,vars,mode);
   expandgetv(symbid(car u,vars),formlis(evalvecarg cdr u,vars,mode));

symbolic procedure expandgetv(u,v);
   if null v then u
    else expandgetv(list(if !*fastvector then 'igetv else 'getv,
			 u,car v),
		    cdr v);

symbolic procedure putvect(u,vars,mode);
   expandputv(symbid(caar u,vars),formlis(evalvecarg cdar u,vars,mode),
	      form1(cadr u,vars,mode));

symbolic procedure expandputv(u,v,w);
   if null cdr v
     then list(if !*fastvector then 'iputv else 'putv,u,car v,w)
    else expandputv(list(if !*fastvector then 'igetv else 'getv,
			 u,car v),
		    cdr v,w);

symbolic procedure evalvecarg u;
%   if u and null cdr u and vectorp car u
%     then for i:=0:upbv car u collect getv(car u,i) else
   if u and null cdr u and eqcar(car u,'vec!*)
       and eqcar(cadar u,'list)
     then cdadar u
    else u;

% Support for arrays defined in terms of vectors.

symbolic procedure mkar1 u;
   begin scalar x;
      x := mkvect car u;
      if cdr u then for i:= 0:upbv x do putv(x,i,mkar1 cdr u);
      return x
   end;

symbolic macro procedure array u;
   % Create an array from the elements in u.
   list('vec!*,'list . cdr u);

endmodule;

end;