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