; (LOOP [(INTIAL v1 e1 v2 e2...)]
;       [(WHILE ew)]
;       [(DO ed...)]
;       [(UNTIL eu)]
;       [(RESULT er)]
; )
;	==>
;
; (PROG (v1 v2...)
;         (SETQ v1 e1)
;         (SETQ v2 e2)
;         ...
;    LOOP
;         (COND ((NOT ew) (GO EXIT)))
;         ed...
;         (COND ((eu) (GO EXIT)))
;         (GO LOOP)
;    EXIT (RETURN er)
; )
 
; WHILE, DO and UNTIL clauses can be put anywhere, they are taken as they come;
; the expressions they translate to are spliced in between the INITIAL and the
; RESULT expressions.
 
(DM LOOP (L)
,  (APPEND
,  ,  (LIST 'PROG (VAR-LIST (LOOP-CLAUSE 'INITIAL L)))
,  ,  (INITIAL-STEPS (LOOP-CLAUSE 'INITIAL L))
,  ,  '(LOOP)
,  ,  (APPLY 'APPEND (MAPCAR (CDR L) 'DO-CLAUSE))
,  ,  (LIST
,  ,  ,  '(GO LOOP)
,  ,  ,  'EXIT
,  ,  ,  (CONS 'RETURN (LOOP-CLAUSE 'RESULT L))
,  ,  ,,,)
,  ,,,)
,,,)
 
; LOOP-CLAUSE gets LOOP keyword clauses
; -- NOTE: This definition depends on CDR NIL = NIL
 
(DE LOOP-CLAUSE (KEY L)
,  (CDR (ASSOC KEY L))
,,,)
 
; DO-CLAUSE translates a keyword clause into the appropriate code
; INITIAL and RESULT are taken care of seperately
 
(DE DO-CLAUSE (CLAUSE)
,  (COND
,  ,  ((MEMQ (CAR CLAUSE) '(INITIAL RESULT))
,  ,  ,  NIL
,  ,  ,,,)
,  ,  ((EQ (CAR CLAUSE) 'WHILE)
,  ,  ,  (LIST (LIST 'COND (LIST (LIST 'NOT (CADR CLAUSE)) '(GO EXIT))))
,  ,  ,,,)
,  ,  ((EQ (CAR CLAUSE) 'DO)
,  ,  ,  (CDR CLAUSE)
,  ,  ,,,)
,  ,  ((EQ (CAR CLAUSE) 'UNTIL)
,  ,  ,  (LIST (LIST 'COND (LIST (CADR CLAUSE) '(GO EXIT))))
,  ,  ,,,)
,  ,  ( T
,  ,  ,  (MSG T "Unknown keyword " CLAUSE)
,  ,  ,  NIL
,  ,  ,,,)
,  ,,,)
,,,)
 
; VAR-LIST: (v1 e1 v2 e2 ...) => (v1 v2 ...)
 
(DE VAR-LIST (L)
,  (AND
,  ,  L
,  ,  (CONS
,  ,  ,  (CAR L)
,  ,  ,  (VAR-LIST (CDDR L))
,  ,  ,,,)
,  ,,,)
,,,)
 
; INITIAL-STEPS: (v1 e1 v2 e2 ...) => ((SETQ v1 e1) (SETQ v2 e2) ...)
 
(DE INITIAL-STEPS (L)
,  (COND
,  ,  ((NULL L) NIL)
,  ,  ((NULL (CADR L))
,  ,  ,  (INITIAL-STEPS (CDDR L))
,  ,  ,,,)
,  ,  ( T
,  ,  ,  (CONS
,  ,  ,  ,  (LIST 'SETQ (CAR L) (CADR L))
,  ,  ,  ,  (INITIAL-STEPS (CDDR L))
,  ,  ,  ,,,)
,  ,  ,,,)
,  ,,,)
,,,)