Artifact 1906d5b717d08b2cdd592d4a1f692a55af302935f5a44bb1bac8c8610289975e:

• File psl-1983/3-1/glisp/glcase.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 1648) [annotate] [blame] [check-ins using] [more...]

% 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)))