-
Notifications
You must be signed in to change notification settings - Fork 2
/
iterate.lisp
202 lines (182 loc) · 7.71 KB
/
iterate.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - iterate.lisp
;; Description - Applicative iteration
;; Author - Tim Bradshaw (tfb at lostwithiel)
;; Created On - Sat Oct 7 00:23:24 2000
;; Last Modified On - Wed Mar 20 08:41:14 2024
;; Last Modified By - Tim Bradshaw (tfb at pendeen.fritz.box)
;; Update Count - 19
;; Status - Unknown
;;
;; $Id$
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; * Applicative iteration (don't need this in CMUCL)
;;;
;;; iterate.lisp is copyright 1997-2000, 2021, 2023, 2024 by me, Tim
;;; Bradshaw, and may be used for any purpose whatsoever by anyone. It
;;; has no warranty whatsoever. I would appreciate acknowledgement if
;;; you use it in anger, and I would also very much appreciate any
;;; feedback or bug fixes.
;;;
;;; The improvements to all this code in 2023 & 2024, as well as the
;;; new ITERATE*, ITERATING & ITERATING* are due to Zyni: thank you.
;;;
(defpackage :org.tfeb.hax.iterate
(:use :cl)
(:export #:iterate #:iterate* #:iterating #:iterating*))
(in-package :org.tfeb.hax.iterate)
(provide :org.tfeb.hax.iterate)
(defun extract-ignore/other-decls (decls/forms)
;; See utilities. But this is not the same: it returns all ignores
;; and others as two values What's returned is the bodies of two
;; DECLARE forms.
(let ((ignores '())
(others '()))
(dolist (d/f decls/forms)
(unless (and (consp d/f)
(eql (car d/f) 'declare))
(return))
(dolist (d (rest d/f))
(if (and (consp d) (eql (car d) 'ignore))
(push d ignores)
(push d others))))
(values (nreverse ignores)
(nreverse others))))
(defun expand-iterate (name bindings body starred)
(unless (every (lambda (binding)
(typecase binding
(symbol t)
(list
(if (<= 1 (length binding) 2)
t
(progn
(warn "bad binding ~S" binding))))
(t
(warn "hopeless binding ~S" binding))))
bindings)
(error "bad bindings"))
(let ((argnames
(mapcar (lambda (binding)
(typecase binding
(symbol
binding)
(list
(first binding))))
bindings)))
(multiple-value-bind (ignores others) (extract-ignore/other-decls body)
(declare (ignore ignores))
`(,(if starred 'let* 'let) ,bindings
(declare ,@others)
(labels ((,name ,argnames
,@body))
(,name ,@argnames))))))
(defmacro iterate (name bindings &body body)
"Scheme-style named-LET: parallel binding
This compiles into LABELS and recursive calls, which is fully general.
If you are using an implementation which can't optimise tail calls,
start using one which can.
This is like LET, not LET*: initial values can't see preceeding
variables."
(expand-iterate name bindings body nil))
(defmacro iterate* (name bindings &body body)
"Variant Scheme-style named-LET: sequential binding
This compiles into LABELS and recursive calls, which is fully general.
If you are using an implementation which can't optimise tail calls,
start using one which can.
This is like LET*: initial values can depend on preceeding variables."
(expand-iterate name bindings body t))
(defun expand-iterating (name bindings body starred)
(unless (every (lambda (binding)
(typecase binding
(symbol t)
(list
(if (<= 1 (length binding) 3)
t
(progn
(warn "bad binding ~S" binding))))
(t
(warn "hopeless binding ~S" binding))))
bindings)
(error "bad bindings"))
(let ((argnames
(mapcar (lambda (binding)
(typecase binding
(symbol
binding)
(list
(first binding))))
bindings))
(argvals
(mapcar (lambda (binding)
(typecase binding
(symbol
nil)
(list
(case (length binding)
((1)
nil)
((2 3)
(second binding))))))
bindings))
(argsteps
(mapcar (lambda (binding)
(typecase binding
(symbol
nil)
(list
(case (length binding)
((1)
nil)
((2)
(second binding))
((3)
(third binding))))))
bindings)))
(if (not starred)
(let ((secret-name (make-symbol (symbol-name name)))
(interim-argnames (mapcar (lambda (v)
(make-symbol (symbol-name v)))
argnames))
(keyword-names (mapcar (lambda (v)
(intern (symbol-name v)
(load-time-value (find-package "KEYWORD"))))
argnames)))
`(labels ((,secret-name ,argnames
(flet ((,name (&key ,@(mapcar (lambda (k v i)
`((,k ,v) ,i))
keyword-names
interim-argnames argsteps))
(,secret-name ,@interim-argnames)))
(declare (inline ,name))
,@body)))
(,secret-name ,@argvals)))
(let ((secret-name (make-symbol (symbol-name name))))
(multiple-value-bind (ignores others) (extract-ignore/other-decls body)
`(labels ((,secret-name ,argnames
(declare ,@ignores ,@others)
(flet ((,name (&key ,@(mapcar #'list argnames argsteps))
(,secret-name ,@argnames)))
(declare (inline ,name))
,@body)))
(let* ,(mapcar #'list argnames argvals)
(declare ,@others)
(,secret-name ,@argnames))))))))
(defmacro iterating (name bindings &body body)
"Applicative iteration macro with optional step forms: parallel binding
This is like ITERATE but each binding can be (var init/step) or (var
init step). The local function has keyword arguments which default to
init/step or step respectively, so you can provide only some, or
simply use this as a looping construct.
This is like LET or DO, not LET* or DO*: initial values can't see
preceeding variables and step forms see the old values of variables."
(expand-iterating name bindings body nil))
(defmacro iterating* (name bindings &body body)
"Applicative iteration macro with optional step forms: sequential binding
This is like ITERATE but each binding can be (var init/step) or (var
init step). The local function has approproate keyword arguments
which default to init/step or step respectively, so you can provide
only some, or simply use this as a looping construct.
This is like LET* or DO*, not LET or DO: initial values can see
preceeding variables and step forms can see preceeding updated
variables."
(expand-iterating name bindings body t))