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

module xread; % Routines for parsing RLISP input.

% Author: Anthony C. Hearn.

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

fluid '(!*blockp !*eoldelimp !*reduce4);   % !*ignoreeol

global '(cursym!* nxtsym!*);

% The conversion of an RLISP expression to LISP prefix form is carried
% out by the function XREAD.  This function initiates the scanning
% process, and then calls the auxiliary function XREAD1 to perform the
% actual parsing.  Both XREAD and XREAD1 are used by many functions
% whenever an expression must be read;

flag ('(end !*colon!* !*semicol!*),'delim);

symbolic procedure chknewnam u;
   % Check to see if U has a newnam, and return it else return U.
   begin scalar x;
      return if null(x := get(u,'newnam)) or x eq u then u
              else if idp x then chknewnam x
              else x
   end;

symbolic procedure mkvar(u,v); u;

symbolic procedure remcomma u;
   if eqcar(u,'!*comma!*) then cdr u else list u;

symbolic procedure eolcheck;
   if null !*eoldelimp then nil
    else begin
   a: if nxtsym!* eq !$eol!$
	then progn(nxtsym!* := (if cursym!* eq 'end then '!;
				 else token()),
		   go to a)
     end;

symbolic procedure xread1 u;
   begin scalar v,w,x,y,z,z1,z2;
	% This is the basic function for parsing RLISP input, once
	% tokens have been read by TOKEN and SCAN.  Its one argument
	% U can take a number of values:
	%   FOR:     Parsing of FOR statements
	%   GROUP:   Parsing of group statements after keyword <<
	%   LAMBDA:  Parsing of lambda expressions after keyword lambda
	%   NIL:     Parsing of expressions which can have a comma at
	%            the end for example.
	%   PROC:    Parsing of procedures after keyword PROCEDURE
	%   T:       Default case with standard parsing.
	% Also, if U is flagged STRUCT, it is assumed that the arguments
	% are lists of lists, and so commas are removed.  At present,
	% only MAT is tagged in this manner.
	% The local variables are used as follows:
        % v: expression being built
        % w: prefix operator stack
        % x: infix operator stack
        % y: infix value or stat property
        % z: current symbol
        % z1: next symbol
        % z2: temporary storage;
  a:    z := cursym!*;
  a1:   if null idp z then nil
         else if z eq '!*lpar!* then go to lparen
         else if z eq '!*rpar!* then go to rparen
         else if y := get(z,'infix) then go to infx
         % The next line now commented out was intended to allow a STAT
         % to be used as a label. However, it prevents the definition of
         % a diphthong whose first character is a colon.
%        else if nxtsym!* eq '!: then nil
         else if flagp(z,'delim) then go to delimit
         else if y := get(z,'stat) then go to stat
	 else if null !*reduce4 and flagp(z,'type)
	  then progn(w := lispapply('decstat,nil) . w, go to a);
  a2:   y := nil;
  a3:   w := z . w;
	% allow for implicit * after a number.
	if toknump z
           and null(z1 eq !$eol!$)
           and idp (z1 := chknewnam nxtsym!*)
           and null flagp(z1,'delim)
           and null(get(z1,'switch!*) and null(z1 eq '!())
           and null get(z1,'infix)
           and null (!*eoldelimp and z1 eq !$eol!$)
	  then progn(cursym!* := 'times, go to a)
	 else if u eq 'proc and length w > 2
	  then symerr("Syntax error in procedure header",nil);
  next: z := scan();
        go to a1;
  lparen:
        eolcheck();
        y := nil;
        if scan() eq '!*rpar!* then go to lp1    % no args
         else if flagpcar(w,'struct) then z := xread1 car w
         else z := xread1 'paren;
        if flagp(u,'struct) then progn(z := remcomma z, go to a3)
         else if null eqcar(z,'!*comma!*) then go to a3
         else if null w         % then go to a3
           then (if u eq 'lambda then go to a3
                 else symerr("Improper delimiter",nil))
         else w := (car w . cdr z) . cdr w;
        go to next;
  lp1:  if w then w := list car w . cdr w;  % Function of no args.
        go to next;
  rparen:
	if null u or u eq 'group
	   or u eq 'proc % and null !*reduce4
          then symerr("Too many right parentheses",nil)
         else go to end1;
  infx: eolcheck();
        if z eq '!*comma!* or null atom (z1 := scan())
		or toknump z1 then go to in1
         else if z1 eq '!*rpar!* % Infix operator used as variable.
                or z1 eq '!*comma!*
                or flagp(z1,'delim)
          then go to in2
         else if z1 eq '!*lpar!* % Infix operator in prefix position.
                    and null eolcheck()     % Side effect important
                    and null atom(z1 := xread 'paren)
                    and car z1 eq '!*comma!*
                    and (z := z . cdr z1)
          then go to a1;
  in1:  if w then go to unwind
         else if null(z := get(z,'unary))
          then symerr("Redundant operator",nil);
        v := '!*!*un!*!* . v;
        go to pr1;
% in2:  if y then if !*ignoreeol then y := nil
%                  else symerr("Redundant operator",nil);
  in2:  if y then y := nil;
        w := z . w;
  in3:  z := z1;
        go to a1;
  unwind:
	% Null w implies a delimiter was found, say, after a comma.
        if null w then symerr("Improper delimiter",nil);
        z2 := mkvar(car w,z);
  un1:  w:= cdr w;
        if null w then go to un2
        % Next line used to be toknump car w, but this test catches more
%        else if null idp car w and null eqcar(car w,'lambda)
	 else if atom car w and null idp car w
%           and null eqcar(car w,'lambda)
	  then symerr("Missing operator",nil);
        z2 := list(car w,z2);
        go to un1;
  un2:  v:= z2 . v;
  preced:
        if null x then if y=0 then go to end2 else nil
%        else if z eq 'setq then nil
	% Makes parsing a + b := c more natural.
         else if y<caar x
           or (y=caar x
               and ((z eq cdar x and null flagp(z,'nary)
                                 and null flagp(z,'right))
                             or get(cdar x,'alt)))
          then go to pr2;
  pr1:  x:= (y . z) . x;
        if null(z eq '!*comma!*) then go to in3
         else if cdr x or null u or u memq '(lambda paren)
            or flagp(u,'struct)
          then go to next
         else go to end2;
  pr2:  %if cdar x eq 'setq then go to assign else;
	% Check for NOT used as infix operator.
	if eqcar(cadr v,'not) and caar x >= get('member,'infix)
	  then typerr("NOT","infix operator");
        if cadr v eq '!*!*un!*!*
          then (if car v eq '!*!*un!*!* then go to pr1
                else z2 := list(cdar x,car v))
         else z2 := cdar x .
                     if eqcar(car v,cdar x) and flagp(cdar x,'nary)
                       then (cadr v . cdar v)
                      else list(cadr v,car v);
        x:= cdr x;
        v := z2 . cddr v;
        go to preced;
  stat: if null(y eq 'endstat) then eolcheck();
        if null(flagp(z,'go)
%          or (flagp(y,'endstatfn)
           or null(u eq 'proc) and (flagp(y,'endstatfn)
                or (null delcp nxtsym!* and null (nxtsym!* eq '!,))))
          then go to a2;
	if z eq 'procedure and !*reduce4
	  then if w then if cdr w or !*reduce4
			   then symerr("proc form",nil)
			  else w := list procstat1 car w
		else w := list procstat1 nil
	 else w := lispapply(y,nil) . w;
        y := nil;
        go to a;
  delimit:
        if null(cursym!* eq '!*semicol!*) then eolcheck();
        if z eq '!*colon!* and null(u eq 'for)
              and (null !*blockp or null w or null atom car w or cdr w)
           or flagp(z,'nodel)
              and (null u 
		      or u eq 'group
			and null(z memq
				   '(!*rsqbkt!* !*rcbkt!* !*rsqb!*)))
          then symerr("Improper delimiter",nil)
         else if idp u and (u eq 'paren or flagp(u,'struct))
          then symerr("Too few right parentheses",nil);
  end1:
	if y then symerr("Improper delimiter",nil) % Probably ,).
         else if null v and null w and null x then return nil;
        y := 0;
        go to unwind;
  end2: if null cdr v then return car v
	 else print "Please send hearn@rand.org your program!!";
	symerr("Improper delimiter",nil)
   end;

%symbolic procedure getels u;
%   getel(car u . !*evlis cdr u);

%symbolic procedure !*evlis u;
%   mapcar(u,function lispeval);

flag ('(endstat retstat),'endstatfn);

flag ('(else then until),'nodel);

flag ('(begin),'go);

symbolic procedure xread u;
   begin
   a: scan();
      if !*eoldelimp and cursym!* eq '!*semicol!* then go to a;
      return xread1 u
   end;

symbolic procedure expread;  xread t;

flag('(expread xread),'opfn);   % To make them operators.

endmodule;

end;