File psl-1983/3-1/glisp/glcase.sl artifact 1906d5b717 part of check-in 46c747b52c

% GSN 10-FEB-83 12:56 
% Compile code for Case statement. 
(DE GLDOCASE (EXPR)
(PROG
  (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB)
  (SETQ TYPEOK T)
  (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR))
			NIL CONTEXT T))
  (SETQ SELECTOR (CAR TMP))
  (SETQ SELECTORTYPE (CADR TMP))
  (SETQ EXPR (CDDR EXPR))
  
% Get rid of of if present 

  (COND ((MEMQ (CAR EXPR)
	       '(OF Of of))
	 (SETQ EXPR (CDR EXPR))))
  A
  (COND
    ((NULL EXPR)
     (RETURN (LIST (GLGENCODE (CONS 'SELECTQ
				    (CONS SELECTOR (ACONC RESULT ELSECLAUSE))))
		   RESULTTYPE)))
    ((MEMQ (CAR EXPR)
	   '(ELSE Else
	      else))
     (SETQ TMP (GLPROGN (CDR EXPR)
			CONTEXT))
     (SETQ ELSECLAUSE (COND ((CDAR TMP)
			     (CONS 'PROGN
				   (CAR TMP)))
			    (T (CAAR TMP))))
     (SETQ EXPR NIL))
    (T
      (SETQ TMP (GLPROGN (CDAR EXPR)
			 CONTEXT))
      (SETQ
	RESULT
	(ACONC RESULT
	       (CONS (COND
		       ((ATOM (CAAR EXPR))
			(OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE
						       'VALUES
						       (CAAR EXPR)
						       NIL))
				 (CADR TMPB))
			    (CAAR EXPR)))
		       (T (MAPCAR (CAAR EXPR)
				  (FUNCTION
				    (LAMBDA (X)
				      (OR (AND (SETQ TMPB (GLSTRPROP
						   SELECTORTYPE
						   'VALUES
						   X NIL))
					       (CADR TMPB))
					  X))))))
		     (CAR TMP))))))
  
% If all the result types are the same, then we know the result of the 
%   Case statement. 

  (COND (TYPEOK (COND ((NULL RESULTTYPE)
		       (SETQ RESULTTYPE (CADR TMP)))
		      ((EQUAL RESULTTYPE (CADR TMP)))
		      (T (SETQ TYPEOK NIL)
			 (SETQ RESULTTYPE NIL)))))
  (cond (expr (SETQ EXPR (CDR EXPR)) ))
  (GO A)))