/[clazy]/clazy/library.lisp
ViewVC logotype

Contents of /clazy/library.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Fri Dec 17 13:12:20 2010 UTC (3 years, 3 months ago) by mantoniotti
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +4 -4 lines
Fixed problem with interaction of CALL and the lazy defnition of CONS.
The INTEGERS stream is not moved outside this file.
(In general, CONS cannot be "execute" lazily in this file lest I introduced several EVAL-WHEN etc etc.
1 ;;;; -*- Mode: Lisp -*-
2
3 ;;;; library.lisp --
4 ;;;; Some library functions useful with CLAZY.
5 ;;;; See COPYING file for copyright and licensing information.
6
7
8 (in-package "CLAZY")
9
10 ;;;;===========================================================================
11 ;;;; Usual stream things.
12
13 ;;; lazy-stream, lazy-cons --
14 ;;; Definitions and manipultion functions.
15
16 (defstruct (lazy-stream
17 (:constructor %cons-lazy-stream (head &optional
18 (tail (make-thunk nil)))))
19 "The Lazy Stream Structure.
20
21 The traditional implementation of SICP-like streams. The LAZY-STREAM
22 structure has a strict head and a lazy tail."
23 (head () :read-only t) ; Maybe I'll revert to mutable later on. MA 20090219.
24 (tail () :read-only t)
25 )
26
27
28 (defstruct (lazy-cons
29 (:include lazy-stream)
30 (:constructor %cons-lazy-cons (head &optional
31 (tail (make-thunk nil)))))
32 "The Lazy Cons Structure.
33
34 The LAZY-CONS structure has both head and tail lazy. It includes LAZY-STREAM.")
35
36
37 (defmacro cons-stream (head tail)
38 "Constructs a LAZY-STREAM, DELAYing the TAIL argument."
39 `(%cons-lazy-stream ,head (delay ,tail)))
40
41
42 ;;; head, tail -- They operate on lists as well.
43
44 (defun head (s)
45 "Returns the first element of a SEQUENCE or a LAZY-STREAM."
46 (declare (type (or sequence lazy-stream) s))
47 (etypecase s
48 (list (first s))
49 (vector (aref s 0))
50 (lazy-cons (force (lazy-cons-head s)))
51 (lazy-stream (lazy-stream-head s))))
52
53
54 (defun tail (s)
55 "Retirns the rest of a LIST or LAZY-STREAM."
56 (declare (type (or list lazy-stream) s))
57 (etypecase s
58 (list (rest s))
59 (lazy-stream (force (lazy-stream-tail s)))))
60
61
62 (defmethod print-object ((ls lazy-stream) (s stream))
63 (print-unreadable-object (ls s :type t :identity t)
64 (format s "[~S ...]" (head ls))))
65
66
67 (defmethod print-object ((ls lazy-cons) (s stream))
68 (print-unreadable-object (ls s :type t :identity t)
69 (if (thunk-p (lazy-cons-head ls))
70 (write-string "[(LAMBDA () ...)" s)
71 (format s "[~S" (head ls)))
72 (if (lazy-cons-tail ls)
73 (write-string " ...]" s)
74 (write-string "]" s))))
75
76
77
78 ;;;---------------------------------------------------------------------------
79 ;;; Lazy versions of major functions.
80 ;;;
81 ;;; These are useful mostly within "slacking" blocks.
82 ;;; The list is incomplete. New ones can be added later.
83
84 ;;; Note:
85 ;;; We cannot define the lazy version of CONS and CONS-STREAM in the
86 ;;; way I'd hoped, because of the way the thunking machinery works.
87
88 ;;; cons-stream --
89 ;;; Lazy version of the macro; which we don't actually define because
90 ;;; it'd interfere with LAZILY.
91
92 #|
93 ;;; Wrong version
94 (def-lazy-function cons-stream (head tail)
95 (%cons-lazy-cons head (delay tail)))
96
97 ;;; Working version
98 (def-lazy-function cons-stream (&rest head-tail)
99 ;; (assert (= (list-length head-tail) 2))
100 (%cons-lazy-cons (force (first head-tail)) (second head-tail)))
101 |#
102
103
104 ;;; SBCL and CLISP fascist package locks are the reason for the
105 ;;; hairiness following.
106
107 #+sbcl #| has-fascist-package-locks |#
108 (eval-when (:compile-toplevel :load-toplevel :execute)
109 (sb-ext:unlock-package "CL"))
110
111 #+clisp #| has-fascist-package-locks |#
112 (eval-when (:compile-toplevel :load-toplevel :execute)
113 (setf (ext:package-lock "CL") nil))
114
115
116
117 ;;; lazy cons -- Let's (almost) put our money where our mouth is.
118
119 #| Nice version but...
120 (def-lazy-function cons (car cdr)
121 ;; (assert (= (list-length car-cdr) 2))
122 (%cons-lazy-cons (delay car) (delay cdr)))
123 |#
124
125 (def-lazy-function cons (&rest car-cdr)
126 ;; (assert (= (list-length car-cdr) 2))
127 (%cons-lazy-cons (first car-cdr) (second car-cdr)))
128
129
130 ;;; lazy car, cdr --
131
132 (def-lazy-function car (cons)
133 (head cons))
134
135
136 (def-lazy-function cdr (cons)
137 (tail cons))
138
139
140 ;;; list -- Same as for CONS
141 ;;; This will become useful later as well.
142
143 (def-lazy-function list (&rest args)
144 ;; ARGS is actually a list of THUNKS. Since that's the case, I can
145 ;; just fill up a nice set of lazy-cons'es.
146
147 (labels ((lazy-cons (thunks)
148 (if (null thunks)
149 () ; Rather arbitrary, but consistent with CL.
150 (%cons-lazy-cons (first thunks)
151 (lazy-cons (rest thunks)))))
152 )
153 (lazy-cons args)))
154
155
156 ;;; repeatedly --
157 ;;; it is just a simple function.
158
159 (defun repeatedly (fn &rest args)
160 "Returns a lazy list containing repeated applications of FN to ARGS."
161 (lazy:call 'cons
162 (apply fn args)
163 (apply 'repeatedly fn args)))
164
165
166
167 ;;;; szergling (Yong) ideas
168
169 ;;; slacking, lazily --
170 ;;; These macro are very useful, yet obviously not right. Think of
171 ;;; (let ((cons 1 2)) ...)
172 ;;;
173 ;;; The reason is that there is *NO* decent code walker out there and
174 ;;; that it is impossible to implement one as the CLtL2 environment
175 ;;; functions are not supported by all implementations (besides, it
176 ;;; may be that these facilities are insufficient themselves.)
177
178 (defmacro slacking (&body body) ; with-laziness
179 (labels ((transform (form)
180 (if (atom form)
181 form
182 (destructuring-bind (name . args)
183 form
184 (if (lazy-function-name-p name)
185 `(call ',name ,@(mapcar #'transform args))
186 form)))))
187 `(block slacking
188 ,.(mapcar #'transform body))))
189
190
191 (defmacro lazily (&body body) ; with-laziness
192 "Ensures that lazy functions are called lazily with LAZY:CALL.
193
194 The macro code-walks BODY and whenever it finds an application that
195 has a lazily defined operator, then it rewrites such application with
196 LAZY:CALL."
197 (labels ((transform (form)
198 (if (atom form)
199 form
200 (destructuring-bind (name . args)
201 form
202 (if (lazy-function-name-p name)
203 `(call ',name ,@(mapcar #'transform args))
204 form)))))
205 `(block slacking
206 ,.(mapcar #'transform body))))
207
208
209 #| This is quite incorrect. Need help to fix it.
210 (def-lazy-function map (result-type function &rest seqs)
211 (ecase result-type
212 (lazy-stream
213 (lazily
214 (cons (apply function (mapcar #'head seqs))
215 (apply (lazy map)
216 result-type
217 function
218 (mapcar #'tail seqs)))))
219 (lazy-stream
220 (cons-stream (apply function (mapcar #'head seqs))
221 (apply (lazy map)
222 result-type
223 function
224 (mapcar #'rest seqs))))))
225 |#
226
227
228 #| More szergling ideas. LETREC/LAZY is actually just LET/LAZY.
229
230 (defmacro letrec/lazy (bindings &body body)
231 (let* ((bindings
232 (mapcar (lambda (x)
233 (if (and (list x)
234 (= 2 (length x)))
235 x
236 (list x nil)))
237 bindings))
238 (vars (mapcar #'car bindings))
239 (val-forms (mapcar #'cadr bindings))
240 (gvars (mapcar (lambda (x)
241 (gensym (symbol-name x)))
242 vars))
243 (fun-names (mapcar (lambda (x)
244 (gensym (format nil "GET-~a" x)))
245 vars))
246 (value (gensym "VALUE-"))
247 )
248
249 (flet ((make-getter (var fun-name)
250 `(,fun-name () ,var))
251 (make-setter (var fun-name)
252 `((setf ,fun-name) (,value)
253 (setf ,var ,value)))
254 (make-symbol-macro (var fun-name)
255 `(,var (,fun-name)))
256 (make-initialiser (var val-form)
257 `(setf ,var ,val-form)))
258 `(let ,vars
259 (flet (,@(mapcar #'make-getter vars fun-names)
260 ,@(mapcar #'make-setter vars fun-names))
261 (symbol-macrolet ,(mapcar #'make-symbol-macro
262 vars fun-names)
263 ,@(mapcar #'make-initialiser vars val-forms)
264 ,@body))))))
265 |#
266
267 #|
268 (letrec/lazy ((x (call 'lcons 1 x)))
269 (list-force 10 x))
270
271 (let/lazy ((x (call 'lcons 1 x)))
272 (list-force 10 x))
273 |#
274
275
276 (defun diverge ()
277 "A function that never returns.
278
279 It is equivalent to (LOOP). It should not be called striclty: called
280 striclty: it will never terminate."
281 (loop))
282
283 #+sbcl #| has-fascist-package-locks |#
284 (eval-when (:compile-toplevel :load-toplevel :execute)
285 (sb-ext:lock-package "CL"))
286
287 #+clisp #| has-fascist-package-locks |#
288 (eval-when (:compile-toplevel :load-toplevel :execute)
289 (setf (ext:package-lock "CL") t))
290
291
292
293 ;;;;===========================================================================
294 ;;;; Tests also counting as a library.
295 #|
296 (defun integers-starting-from (n)
297 (lazy:call 'cons n (integers-starting-from (1+ n))))
298
299 (defparameter naturals (integers-starting-from 0))
300 |#
301 ;;;; end of file -- library.lisp --

  ViewVC Help
Powered by ViewVC 1.1.5