From: Darrel VanBuer
Subject: A CL iteration macro, FOR
Date:
Message-ID: <5056@sdcrdcf.UUCP>
Here is limited documentation on, and code for a commonlisp iteration macro
which we developed for compatibility with an Interlisp code port.
Darrel J. Van Buer, PhD; unisys; 2400 Colorado Ave; Santa Monica, CA 90406
(213)829-7511 x5449 KI6VY ······@CAM.UNISYS.COM or
...{allegra,burdvax,cbosgd,hplabs,ihnp4}!sdcrdcf!darrelj
Extracted from:
A Common Lisp Translation Scheme for the Core of the Flexible Deductive Engine
by Richard Fritzson, Donald P. McKay and Darrel J. Van Buer
Technical Memo Number 44'
Logic-Based Systems
Paoli Research Center and West Coast Research Center
Unisys Corporation
December, 1986
Revised March, 1987
Unisys - Paoli Research Center
P.O. Box 517
Paoli, PA 19301
3. The Support Functions
A few Interlisp functions were not translated, but were instead defined in
the Common Lisp environment so that they could be ported with little or no
change. The primary reason for doing this was that there were no comparable
functions in Common Lisp, and the translations were difficult to read.
The most important example of these is the Interlisp iteration constructs.
hese allow the Interlisp programmer to specify both simple and complex
iterative statements in a perspicuous manner. If these were translated into
Common Lisp, they would result in a divergent collection of MAP functions,
DO forms, PROG forms and GOTO expressions, nearly all of which are far more
difficult to read than the original expressions.
A second reason for redefining these expressions is that this allows their
continued use in Common Lisp programming. The Interlisp iterative statements
have proven themselves to be invaluable in LISP programming; it would be a
shame to give them up now in a move forward to Common Lisp.
3.1 The Unisys Common Lisp FOR Macro
The Unisys Common Lisp FOR macro is modeled after the Interlisp iterative
statement and a significant subset of the Interlisp version's functionality
with only a small amount of incompatability. For this reason, it is not
described in detail here. The reader is referred to Section 9.8 of the
Interlisp Reference Manual[1] for a detailed description of its use and
capabilities. This section describes the differences between the Unisys
Common Lisp version and the XEROX Interlisp version.
The internal documentation of the FOR macro is in the file that contains the
code. Since it may still undergo further change, that is the best place to
look for up to date information about how to extend or modify it.
3.1.1 Differences between the Interlisp and Unisys iteration operators
In the Unisys FOR macro,
1) The car of the form must be FOR. The other operators work inside the form,
but FOR is the Common Lisp macro that triggers the translation. It is
perfectly acceptable to write e.g.
(FOR WHILE (< I 0) ...
2) DO not use FROM without TO. The appropriate defaults will not be provided.
FROM and TO function as a unit and must be provided together.
3) WHEN and UNLESS completely skip the the rest of the iteration including
the other generators that follow. In Interlisp, all of the generators
are evaluated, even when WHEN (and UNLESS) fail (or succeed).
4) BIND uses a PROG syntax instead of the Interlisp assignment syntax. That
is, you write
(FOR ... BIND (A B (C 0) D) ...
instead of
(FOR ... BIND A B (C _ 0) D ...
5) None of the OLD froms (FOR OLD, IN OLD , ON OLD) are supported.
6) INSIDE and OUTOF are not supported.
7) DECLARE, DECLARE: and ORIGINAL are also not supported.
8) The Unisys iteration package also supports MAX, MIN, and UNION operators.
3.1.2 List of operators that are supported in the Unisys FOR macro
DO FOR WHEN
COLLECT FOR var UNLESS
JOIN FOR (varlist) WHILE
SUM BIND (varlist) UNTIL
COUNT IN REPEATWHILE
ALWAYS ON REPEATUNTIL
NEVER FROM FIRST
THEREIS TO FINALLY
LARGEST BY EACHTIME
SMALLEST AS
MAX INSIDE
MIN
UNION
------------------------------------------------------------------------
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;;; File converted 7-Jan-88 14:14:25 from source FORMACRO
;;; Original source {DSK}<XAVIER>FORMACRO.;10 created 22-Sep-87 13:17:50
(EXPORT 'FOR)
(DEFUN EVLIST (L) (NREVERSE (MAPCAR #'EVAL L)))
(DEFMACRO FOR (&BODY X) (SDC-FOR X))
(DEFUN FROMTOTEST (IV FROM TO BY BYVAR TOVAR)
(LET ((BYVAL (SYMBOL-VALUE BY)))
(IF (CONSTANTP BYVAL)
(IF (AND (NUMBERP FROM)
(NUMBERP TO)
(< TO FROM)
(= BYVAL 1))
(PROGN ; BY was probably a default +1 so
; silently force to -1 before the
; incrementer gets expanded
(SET BY -1)
`(IF (< ,IV ,TO)
(GO $$OUT)))
`(IF (,(IF (MINUSP BYVAL)
'<
'>) ,IV ,(IF (CONSTANTP TO)
TO TOVAR))
(GO $$OUT)))
`(IF (AND ,BYVAR (OR (= 0 ,BYVAR)
(IF (MINUSP ,BYVAR)
(< ,IV ,(IF (CONSTANTP TO)
TO TOVAR))
(> ,IV ,(IF (CONSTANTP TO)
TO TOVAR)))))
(GO $$OUT)))))
(DEFUN ISOPRP (X) (IF (SYMBOLP X)
(GET (INTERN (STRING-UPCASE X)
"USER")
'FORWORD)))
(DEFUN SDC-FOR (X) (DECLARE (SPECIAL X))
(PROG (VARLIST IV IV1 IOV INITS EACHS PRETESTS BODYS POSTTESTS UPDATES FINALS OP
(INCCNT 0)
$$INC0 $$INC1 $$INC2 $$INC3 $$INC4 $$INC5 $$INC6 $$INCVAR0 $$INCVAR1
$$INCVAR2 $$INCVAR3 $$INCVAR4 $$INCVAR5 $$INCVAR6 $$INIT0 $$INIT1
$$INIT2 $$INIT3 $$INIT4 $$INIT5 $$INIT6 $$END0 $$END1 $$END2 $$END3
$$END4 $$END5 $$END6)
(DECLARE (SPECIAL VARLIST IV IV1 IOV INITS EACHS PRETESTS BODYS POSTTESTS
UPDATES FINALS INCCNT $$INC0 $$INC1 $$INC2 $$INC3 $$INC4
$$INC5 $$INC6 $$INCVAR0 $$INCVAR1 $$INCVAR2 $$INCVAR3
$$INCVAR4 $$INCVAR5 $$INCVAR6 $$INIT0 $$INIT1 $$INIT2
$$INIT3 $$INIT4 $$INIT5 $$INIT6 $$END0 $$END1 $$END2 $$END3
$$END4 $$END5 $$END6))
(PUSH '$$VAL VARLIST)
(COND
((CONSP (CAR X))
(COND
((CONSP (CAAR X)) ; (FOR ((VAR "...") "...") "...")
(SETQ IOV (SETQ IV1 (SETQ IV (CAAAR X)))))
(T ; (FOR (VAR "...") "...")
(SETQ IV1 (SETQ IV (CAAR X)))))
(SETQ VARLIST (NCONC (REVERSE (CAR X))
VARLIST))
(SETQ X (CDR X)))
((AND (SYMBOLP (CAR X))
(NOT (ISOPRP (CAR X)))) ; (FOR VAR "...")
(SETQ IOV (SETQ IV1 (SETQ IV (CAR X))))
(PUSH (LIST (CAR X)
1)
VARLIST)
(SETQ X (CDR X)))
(T ; E.G. (FOR DO "...")
(SETQ IOV (SETQ IV1 (SETQ IV '$$ITER)))
(PUSH '($$ITER 1) VARLIST)))
TOP (IF (NULL X)
(RETURN `(PROG ,(NREVERSE VARLIST)
,@(EVLIST INITS)
$$LP
,@(EVLIST EACHS)
,@(EVLIST PRETESTS)
,@(EVLIST BODYS)
$$ITERATE
,@(EVLIST POSTTESTS)
,@(EVLIST UPDATES)
(GO $$LP)
$$OUT
,@(EVLIST FINALS)
(RETURN $$VAL))))
(COND
((SETQ OP (ISOPRP (CAR X)))
(EVAL OP)
(COND
((AND (CDDR X)
(NOT (ISOPRP (CADDR X)))
(NOT (EQL 'DO (INTERN (STRING-UPCASE (CAR X))
"USER"))))
(PRINT (LIST "Warning, no implicit PROGN in Unisys FOR macro:" X)
T)))
(SETQ X (CDDR X)))
(T (PUSH (LIST 'QUOTE (CAR X))
BODYS)
(SETQ X (CDR X))))
(GO TOP)))
(DEFMACRO XCL-USER::SELECTC (XCL-USER::SELECTOR &REST XCL-USER::CASES)
`(CASE ,XCL-USER::SELECTOR ,@(FOR CASE XCL-USER::ON XCL-USER::CASES XCL-USER::WHILE (CDR CASE)
XCL-USER::COLLECT
(CONS (EVAL (CAAR CASE))
(CDAR CASE))) (OTHERWISE ,(CAR (LAST XCL-USER::CASES)))))
(DEFMACRO TESTFOR (L . BODY) (PROG (X)
(SETQ X (SDC-FOR (CONS L BODY)))
(TERPRI)
(WRITE X :PRETTY T)
(TERPRI)
(RETURN X)))
(SETF (GET 'ALWAYS 'FORWORD)
'(PROGN (PUSH ''(SETQ $$VAL T) INITS)
(PUSH (LIST 'QUOTE `(COND ((NULL ,(CADR X))
(SETQ $$VAL NIL)
(GO $$OUT))))
BODYS)))
(SETF (GET 'AS 'FORWORD)
'(PROGN (INCF INCCNT)
(SETQ IOV (SETQ IV (CADR X)))
(OR IV1 (SETQ IV1 IV))
(PUSH (LIST IV 1)
VARLIST)))
(SETF (GET 'BIND 'FORWORD)
'(IF (CONSP (CADR X))
(SETQ VARLIST (APPEND (REVERSE (CADR X))
VARLIST))
(PUSH (CADR X)
VARLIST)))
(SETF (GET 'BY 'FORWORD)
'(LET ((INCAMT (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT))
"USER")))
(COND ((NUMBERP (CADR X))
(SET INCAMT (CADR X)))
(T (SET INCAMT (SUBST IOV IV (CADR X)))
(LET ((BYVAR (GENSYM)))
(PUSH BYVAR VARLIST)
(SET (INTERN (CONCATENATE 'STRING "$$INCVAR" (PRINC-TO-STRING INCCNT))
"USER")
BYVAR))))))
(SETF (GET 'COLLECT 'FORWORD)
'(PROGN (PUSH (LIST 'QUOTE `(SETQ $$VAL (CONS ,(CADR X) $$VAL)))
BODYS)
(PUSH ''(SETQ $$VAL (NREVERSE $$VAL)) FINALS)))
(SETF (GET 'COUNT 'FORWORD)
'(PROGN (PUSH ''(SETQ $$VAL 0) INITS)
(PUSH (LIST 'QUOTE `(IF ,(CADR X) (SETQ $$VAL (1+ $$VAL))))
BODYS)))
(SETF (GET 'DO 'FORWORD)
'(IF (NULL (ISOPRP (CADR X)))
(PUSH (LIST 'QUOTE (CADR X))
BODYS)
(SETQ X (CONS 'X X))))
(SETF (GET 'EACHTIME 'FORWORD)
'(PUSH (LIST 'QUOTE (CADR X))
EACHS))
(SETF (GET 'FINALLY 'FORWORD)
'(PUSH (LIST 'QUOTE (CADR X))
FINALS))
(SETF (GET 'FIRST 'FORWORD)
'(PUSH (LIST 'QUOTE (CADR X))
INITS))
(SETF (GET 'FROM 'FORWORD)
'(LET ((INCREM (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT))
"USER")))
(IF (EQL IV (CADR (CADAR INITS)))
(RPLACA (CDDR (CADAR INITS))
(CADR X))
(PUSH `'(SETQ ,IV ,(CADR X)) INITS))
(SET (INTERN (CONCATENATE 'STRING "$$INIT" (PRINC-TO-STRING INCCNT))
"USER")
(CADR X))
(OR (SYMBOL-VALUE INCREM)
(SET INCREM 1))
(OR (EQL IV (CADR (CADDAR UPDATES)))
(PUSH `(LIST 'INCF ',IV (IF (CONSTANTP ,INCREM)
,INCREM
(LIST 'SETQ ,(INTERN (CONCATENATE 'STRING "$$INCVAR"
(PRINC-TO-STRING INCCNT))
"USER") ,INCREM))) UPDATES))))
(SETF (GET 'IN 'FORWORD)
'(PROG (INCEXPR)
(SETQ IOV (GENSYM))
(SETQ INCEXPR (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT))
"USER"))
(SET INCEXPR (LIST 'CDR IOV))
(PUSH (LIST IOV (CADR X))
VARLIST)
(PUSH (LIST 'QUOTE `(IF (NOT ,IOV)
(GO $$OUT)
(SETQ ,IV (CAR ,IOV))))
EACHS)
(PUSH `(LIST 'SETQ ,(LIST 'QUOTE IOV) ,INCEXPR) UPDATES)))
(SETF (GET 'INSIDE 'FORWORD)
'(PROGN (SETQ IOV (GENSYM))
(PUSH (LIST IOV (CADR X))
VARLIST)
(PUSH (LIST 'QUOTE `(COND ((NULL ,IOV)
(GO $$OUT))
((NOT (CONSP ,IOV))
(SETQ ,IV ,IOV)
(SETQ ,IOV NIL))
(T (SETQ ,IV (CAR ,IOV))
(SETQ ,IOV (CDR ,IOV)))))
EACHS)))
(SETF (GET 'JOIN 'FORWORD)
'(PROGN (PUSH (LIST 'QUOTE `(SETQ $$VAL (NCONC (NREVERSE ,(CADR X))
$$VAL)))
BODYS)
(PUSH ''(SETQ $$VAL (NREVERSE $$VAL)) FINALS)))
(SETF (GET 'LARGEST 'FORWORD)
'(PROGN (PUSH '$$EXTREME VARLIST)
(PUSH (LIST 'QUOTE `(COND ((OR (NULL $$EXTREME)
(> ,(CADR X) $$EXTREME))
(SETQ $$EXTREME ,(CADR X))
(SETQ $$VAL ,IV))))
BODYS)))
(SETF (GET 'MAX 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF (NULL $$VAL)
(SETQ $$VAL ,(CADR X))
(SETQ $$VAL (MAX $$VAL ,(CADR X)))))
BODYS))
(SETF (GET 'MIN 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF (NULL $$VAL)
(SETQ $$VAL ,(CADR X))
(SETQ $$VAL (MIN $$VAL ,(CADR X)))))
BODYS))
(SETF (GET 'NEVER 'FORWORD)
'(PROGN (PUSH ''(SETQ $$VAL T) INITS)
(PUSH (LIST 'QUOTE `(COND (,(CADR X) (SETQ $$VAL NIL)
(GO $$OUT))))
BODYS)))
(SETF (GET 'ON 'FORWORD)
'(PROG (INCEXPR)
(SETQ INCEXPR (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING (INCF INCCNT)))
"USER"))
(SET INCEXPR (LIST 'CDR IOV))
(COND ((EQL IV (CAAR VARLIST))
(RPLACA (CDAR VARLIST)
(CADR X)))
(T (PUSH (LIST 'QUOTE `(SETQ ,IV ,(CADR X)))
INITS)))
(PUSH `(LIST 'SETQ ,(LIST 'QUOTE IV) ,INCEXPR) UPDATES)
(PUSH (LIST 'QUOTE `(IF (NOT ,IV)
(GO $$OUT)))
PRETESTS)))
(SETF (GET 'REPEATWHILE 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X))
(GO $$OUT)))
POSTTESTS))
(SETF (GET 'REPEATUNTIL 'FORWORD)
'(IF (NUMBERP (CADR X))
(PUSH (LIST 'QUOTE `(IF (> ,IV ,(CADR X))
(GO $$OUT)))
POSTTESTS)
(PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$OUT)))
POSTTESTS)))
(SETF (GET 'SMALLEST 'FORWORD)
'(PROGN (PUSH '$$EXTREME VARLIST)
(PUSH (LIST 'QUOTE `(COND ((OR (NULL $$EXTREME)
(< ,(CADR X) $$EXTREME))
(SETQ $$EXTREME ,(CADR X))
(SETQ $$VAL ,IV))))
BODYS)))
(SETF (GET 'SUM 'FORWORD)
'(PROGN (PUSH ''(SETQ $$VAL 0) INITS)
(PUSH (LIST 'QUOTE `(SETQ $$VAL (+ ,(CADR X) $$VAL)))
BODYS)))
(SETF (GET 'TO 'FORWORD)
'(LET (LIMIT (INITAMT (INTERN (CONCATENATE 'STRING "$$INIT" (PRINC-TO-STRING INCCNT))
"USER"))
(INCREM (INTERN (CONCATENATE 'STRING "$$INC" (PRINC-TO-STRING INCCNT))
"USER"))
(BYVAR (INTERN (CONCATENATE 'STRING "$$INCVAR" (PRINC-TO-STRING INCCNT))
"USER"))
(END (INTERN (CONCATENATE 'STRING "$$END" (PRINC-TO-STRING INCCNT))
"USER")))
(OR (EQL IV (CADR (CADAR INITS)))
(PUSH `'(SETQ ,IV 1) INITS))
(OR (SYMBOL-VALUE INCREM)
(SET INCREM 1))
(OR (CONSTANTP (CADR X))
(PUSH (LIST (SETQ LIMIT (GENSYM))
(CADR X))
VARLIST))
(OR (SYMBOL-VALUE INITAMT)
(SET INITAMT 1))
(OR (EQL IV (CADR (CADDAR UPDATES)))
(PUSH `(LIST 'INCF ',IV (IF (CONSTANTP ,INCREM)
,INCREM
(LIST 'SETQ ,BYVAR ,INCREM))) UPDATES))
(SET END (CADR X))
(PUSH (LIST 'FROMTOTEST `',IV INITAMT END `',INCREM BYVAR `',LIMIT)
PRETESTS)))
(SETF (GET 'THEREIS 'FORWORD)
'(PROGN (PUSH (LIST 'QUOTE `(COND (,(CADR X) (SETQ $$VAL (OR ,IV1 T))
(GO $$OUT))))
BODYS)))
(SETF (GET 'UNION 'FORWORD)
'(PUSH (LIST 'QUOTE `(SETQ $$VAL (UNION ,(CADR X) $$VAL)))
BODYS))
(SETF (GET 'UNLESS 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$ITERATE)))
PRETESTS))
(SETF (GET 'UNTIL 'FORWORD)
'(IF (NUMBERP (CADR X))
(PUSH (LIST 'QUOTE `(IF (> ,IV ,(CADR X))
(GO $$OUT)))
PRETESTS)
(PUSH (LIST 'QUOTE `(IF ,(CADR X) (GO $$OUT)))
PRETESTS)))
(SETF (GET 'WHEN 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X))
(GO $$ITERATE)))
PRETESTS))
(SETF (GET 'WHILE 'FORWORD)
'(PUSH (LIST 'QUOTE `(IF (NOT ,(CADR X))
(GO $$OUT)))
PRETESTS))
(SETF (GET 'IL:FORMACRO 'IL:MAKEFILE-ENVIRONMENT)
'(:PACKAGE "USER" :READTABLE "XCL"))
--
Darrel J. Van Buer, PhD; unisys; 2400 Colorado Ave; Santa Monica, CA 90406
(213)829-7511 x5449 KI6VY ······@CAM.UNISYS.COM or
...{allegra,burdvax,cbosgd,hplabs,ihnp4}!sdcrdcf!darrelj