/[mcclim]/mcclim/utils.lisp
ViewVC logotype

Contents of /mcclim/utils.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (show annotations)
Sun Mar 4 22:37:36 2007 UTC (7 years, 1 month ago) by ahefner
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-6, HEAD
Changes since 1.46: +1 -1 lines
Fix parse-space, the unit name is :inches, not :inch (that's what all the
backends use, anyway).
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet@emi.u-bordeaux.fr)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :clim-internals)
21
22 (defun get-environment-variable (string)
23 #+excl (sys:getenv string)
24 #+(or cmu scl) (cdr (assoc string ext:*environment-list* :test #'string=))
25 #+clisp (ext:getenv (string string))
26 #+sbcl (sb-ext::posix-getenv string)
27 #+openmcl (ccl::getenv string)
28 #+lispworks (lw:environment-variable string)
29 #-(or excl cmu scl clisp sbcl openmcl lispworks)
30 (error "GET-ENVIRONMENT-VARIABLE not implemented"))
31
32 ;;; It would be nice to define this macro in terms of letf, but that
33 ;;; would change the top-levelness of the enclosed forms.
34
35 #+excl
36 (defmacro with-system-redefinition-allowed (&body body)
37 `(progn
38 (eval-when (:compile-toplevel :load-toplevel :execute)
39 (setf (excl:package-definition-lock (find-package :common-lisp)) nil))
40 ,@body
41 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (setf (excl:package-definition-lock (find-package :common-lisp)) t))))
43
44 #+clisp
45 (defmacro with-system-redefinition-allowed (&body body)
46 `(ext:without-package-lock ("COMMON-LISP")
47 ,@body))
48
49 #+openmcl
50 (defmacro with-system-redefinition-allowed (&body body)
51 `(progn
52 (eval-when (:compile-toplevel :load-toplevel :execute)
53 (setq ccl::*warn-if-redefine-kernel* nil))
54 ,@body
55 (eval-when (:compile-toplevel :load-toplevel :execute)
56 (setq ccl::*warn-if-redefine-kernel* t))))
57
58 #+cmu
59 (eval-when (:compile-toplevel :execute)
60 (when (find-symbol "PACKAGE-LOCK" :ext)
61 (pushnew 'clim-internals::package-locks *features*)))
62
63 #+(and cmu clim-internals::package-locks)
64 (eval-when (:load-toplevel)
65 (unless (find-symbol "PACKAGE-LOCK" :ext)
66 (error "Binary incompatibility: your CMUCL does not have package locks")))
67
68 #+cmu
69 (defmacro with-system-redefinition-allowed (&body body)
70 #+clim-internals::package-locks
71 `(progn
72 (eval-when (:compile-toplevel :load-toplevel :execute)
73 (setf (ext:package-definition-lock (find-package :common-lisp)) nil))
74 ,@body
75 (eval-when (:compile-toplevel :load-toplevel :execute)
76 (setf (ext:package-definition-lock (find-package :common-lisp)) t)))
77 #-clim-internals::package-locks
78 `(progn ,@body))
79
80 #+sbcl
81 (eval-when (:compile-toplevel :execute)
82 (when (find-symbol "UNLOCK-PACKAGE" :sb-ext)
83 (pushnew 'clim-internals::package-locks *features*)))
84
85 #+sbcl
86 (defmacro with-system-redefinition-allowed (&body body)
87 #+clim-internals::package-locks
88 `(progn
89 (eval-when (:compile-toplevel :load-toplevel :execute)
90 (sb-ext:unlock-package :common-lisp))
91 ,@body
92 (eval-when (:compile-toplevel :load-toplevel :execute)
93 (sb-ext:lock-package :common-lisp)))
94 #-clim-internals::package-locks
95 `(progn
96 ,@body))
97
98 #-(or excl openmcl cmu sbcl clisp)
99 (defmacro with-system-redefinition-allowed (&body body)
100 `(progn
101 ,@body))
102
103 (defun last1 (list)
104 "Last element of LIST."
105 (first (last list)))
106
107 (defun 2+ (x)
108 (+ x 2))
109
110 (defun 2- (x)
111 (- x 2))
112
113
114 (defun check-letf-form (form)
115 (assert (and (listp form)
116 (= 2 (length form)))))
117
118 (defun valueify (list)
119 (if (and (consp list)
120 (endp (rest list)))
121 (first list)
122 `(values ,@list)))
123
124 (defmacro letf ((&rest forms) &body body &environment env)
125 "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the
126 Forms, SETF the Places to the result of evaluating the Value forms.
127 The places are SETF-ed in parallel after all of the Values are
128 evaluated."
129 (mapc #'check-letf-form forms)
130 (let* (init-let-form save-old-values-setf-form
131 new-values-set-form old-values-set-form
132 update-form)
133 (loop for (place new-value) in forms
134 for (vars vals store-vars writer-form reader-form)
135 = (multiple-value-list (get-setf-expansion place env))
136 for old-value-names = (mapcar (lambda (var)
137 (declare (ignore var))
138 (gensym))
139 store-vars)
140 nconc (mapcar #'list vars vals) into temp-init-let-form
141 nconc (copy-list store-vars) into temp-init-let-form
142 nconc (copy-list old-value-names) into temp-init-let-form
143 nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form
144 nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form
145 nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form
146 collect writer-form into temp-update-form
147 finally (setq init-let-form temp-init-let-form
148 save-old-values-setf-form temp-save-old-values-setf-form
149 new-values-set-form temp-new-values-set-form
150 old-values-set-form temp-old-values-set-form
151 update-form (cons 'progn temp-update-form)))
152 `(let* ,init-let-form
153 (setf ,@save-old-values-setf-form)
154 (unwind-protect
155 (progn (setf ,@new-values-set-form)
156 ,update-form
157 (progn ,@body))
158 (setf ,@old-values-set-form)
159 ,update-form))))
160
161 ;;; XXX This is currently broken with respect to declarations
162
163 (defmacro letf* ((&rest forms) &body body)
164 (if (null forms)
165 `(locally
166 ,@body)
167 `(letf (,(car forms))
168 (letf* (,(cdr forms))
169 ,@body))))
170
171 (defun map-repeated-sequence (result-type n function sequence)
172 "Like CL:MAP, but applies \\arg{function} to \\arg{n} consecutive
173 elements of \\arg{sequence}. All the function's return values will be
174 gathered into the output sequence. \\arg{result-type} can also be NIL,
175 in which case the function is only applied for effect.
176
177 Examples:
178
179 (map-repeated-sequence 'list 2 #'list '(1 2 3 4 5 6)) => ((1 2) (3 4) (5 6))
180 (map-repeated-sequence 'list 2 #'+ '(1 2 3 4 5 6)) => (3 7 11)
181 (map-repeated-sequence 'vector 3 #'+ '(1 2 3 4 5 6)) => #(6 15)
182
183 (map-repeated-sequence 'list 2 #'floor '(2 1 4 3 6 5))
184 => (2 0 1 1 1 1)
185
186 (map-repeated-sequence 'list 2 #'cons '(color red weight 17 name fred))
187 => ((COLOR . RED) (WEIGHT . 17) (NAME . FRED))
188
189 (map-repeated-sequence 'list 1 #'(lambda (p) (values (car p) (cdr p)))
190 '((color . red) (weight . 17) (name . fred)))
191 => (COLOR RED WEIGHT 17 NAME FRED)
192
193 Note:
194 Be careful, since this function is quite sensible to the number of values
195 returned by \\arg{function}.
196 "
197 (assert (>= n 1))
198 (cond ((eq result-type 'nil)
199 ;; just map for effect
200 (cond ((vectorp sequence)
201 (loop for i from 0 below (length sequence) by n do
202 (apply function (loop for j from 0 below n collect (aref sequence (+ i j))))))
203 ((listp sequence)
204 (let ((q sequence))
205 (loop until (null q) do
206 (apply function (loop for j from 0 below n collect (pop q))))))))
207 (t
208 ;; otherwise, we (for now) take the easy route of calling COERCE
209 (coerce
210 (cond ((vectorp sequence)
211 (loop for i from 0 below (length sequence) by n
212 nconc (multiple-value-list
213 (apply function (loop for j from 0 below n collect (aref sequence (+ i j)))))))
214 ((listp sequence)
215 (let ((q sequence))
216 (loop until (null q) nconc
217 (multiple-value-list
218 (apply function (loop for j from 0 below n collect (pop q))))))))
219 result-type))))
220
221 ;;; A different way of attacking iteration of sequences
222 (defmacro do-sequence ((vars sequence &optional result-form) &body body)
223 "Iterate over SEQUENCE. VARS is a list of symbols (or a single
224 symbol). At each iteration the variables in VARS are bound to the
225 initial elements of the sequence. The iteration is then \"stepped\"
226 by the number of variables in VARS."
227 (flet ((list-accessor (n)
228 (case n
229 (0 'car)
230 (1 'cadr)
231 (2 'caddr)
232 (3 'cadddr)
233 (t `(lambda (list) (nth ,n list)))))
234 (list-stepper (n)
235 (case n
236 (1 'cdr)
237 (2 'cddr)
238 (3 'cdddr)
239 (4 'cddddr)
240 (t `(lambda (list) (nthcdr ,n list))))))
241 (when (not (listp vars))
242 (setq vars (list vars)))
243 (let* ((body-fun (gensym "BODY-FUN"))
244 (var-length (length vars))
245 (seq-var (gensym "SEQ-VAR"))
246 (tail-var (gensym "TAIL-VAR"))
247 (i (gensym "I"))
248 (list-args (loop for j from 0 below var-length
249 collect `(,(list-accessor j) ,tail-var)))
250 (vector-args (loop for j from 0 below var-length
251 collect `(aref ,seq-var (+ ,i ,j)))))
252 `(block nil
253 (flet ((,body-fun ,vars
254 (tagbody
255 ,@body)))
256 (let ((,seq-var ,sequence))
257 (etypecase ,seq-var
258 (list
259 (loop for ,tail-var on ,seq-var by #',(list-stepper var-length)
260 do (,body-fun ,@list-args)))
261 (vector
262 (loop for ,i of-type fixnum from 0 below (length ,seq-var) by ,var-length
263 do (,body-fun ,@vector-args))))))
264 ,@(when result-form
265 `((let ,vars ;Bind variables to nil
266 (declare (ignorable ,vars))
267 ,result-form)))))))
268
269 (defun clamp (value min max)
270 "Clamps the value 'value' into the range [min,max]."
271 (max min (min max value)))
272
273 ;;;;
274 ;;;; meta functions
275 ;;;;
276
277 ;; these are as in Dylan
278
279 (defun curry (fun &rest args)
280 #'(lambda (&rest more)
281 (apply fun (append args more))))
282
283 (define-compiler-macro curry (fun &rest args)
284 `(lambda (&rest more)
285 (apply ,fun ,@args more)))
286
287 (defun always (x)
288 #'(lambda (&rest more)
289 (declare (ignore more))
290 x))
291
292 (define-compiler-macro always (x)
293 (let ((g (gensym)))
294 `(let ((,g ,x))
295 (lambda (&rest more)
296 (declare (ignore more))
297 ,g))))
298
299 ;;; Convenience macros
300
301 (define-modify-macro maxf (&rest args) max)
302 (define-modify-macro minf (&rest args) min)
303 (define-modify-macro nconcf (&rest args) nconc)
304 (define-modify-macro orf (&rest args) or)
305
306
307 ;;; Move this early so it can be used in presentations.lisp, which
308 ;;; comes before commands.lisp.
309
310 (defmacro do-command-table-inheritance ((command-table-var command-table)
311 &body body)
312 `(apply-with-command-table-inheritance
313 #'(lambda (,command-table-var)
314 ,@body)
315 (find-command-table ,command-table)))
316
317 ;;;
318
319 (defmacro with-gensyms (syms &body body)
320 "Binds each symbol in the list `syms' to a gensym which uses the
321 name of the symbol."
322 `(let ,(mapcar (lambda (symbol) `(,symbol (gensym ,(symbol-name symbol))))
323 syms)
324 ,@ body))
325
326 (defun parse-method (description)
327 (loop
328 for (qualifier-or-ll . body) on description
329 until (listp qualifier-or-ll)
330 collect qualifier-or-ll into qualifiers
331 finally (return
332 (values qualifiers
333 (clim-mop:extract-specializer-names qualifier-or-ll)
334 (clim-mop:extract-lambda-list qualifier-or-ll)
335 body))))
336
337 (defun get-body-declarations (body)
338 "Collect all declaration forms from a body of forms that may have
339 declarations at its top. Returns as values a list of the declarations and the
340 rest of the body."
341 (loop for bod on body
342 for (form) = bod
343 if (and (consp form) (eq (car form) 'declare))
344 collect form into decls
345 else
346 return (values decls bod)
347 finally (return (values decls nil)))) ;It's all (declare ...)
348
349 (defun decode-specializer (specializer-name)
350 (if (atom specializer-name)
351 (find-class specializer-name)
352 (clim-mop:intern-eql-specializer (second specializer-name))))
353
354 (defmacro with-method ((name &rest description) &body body)
355 "Executes BODY installing the specified method on the generic
356 function named NAME."
357 (multiple-value-bind (qualifiers specializers)
358 (parse-method description)
359 (with-gensyms (old-method decoded-specializers new-method)
360 `(let* ((,decoded-specializers
361 (mapcar #'decode-specializer ',specializers))
362 (,old-method (find-method #',name
363 ',qualifiers
364 ,decoded-specializers
365 nil))
366 (,new-method
367 (defmethod ,name ,@description)))
368 (unwind-protect
369 (locally ,@body)
370 (remove-method #',name ,new-method)
371 (when ,old-method (add-method #',name ,old-method)))))))
372
373 ;;; Anaphoric
374
375 (defmacro aif (test-form then-form &optional else-form)
376 `(let ((it ,test-form))
377 (if it ,then-form ,else-form)))
378
379 (defmacro awhen (test-form &body body)
380 `(aif ,test-form
381 (progn ,@body)))
382
383 (defmacro aand (&rest args)
384 (cond ((endp args) t)
385 ((endp (rest args)) (first args))
386 (t `(aif ,(first args) (aand ,@(rest args))))))
387
388 ;;;
389 (declaim (inline maybe-funcall maybe-apply))
390
391 (defun maybe-funcall (function &rest args)
392 "If FUNCTION is not NIL, funcall it."
393 (when function (apply function args)))
394
395 (defun maybe-apply (function &rest args)
396 "If FUNCTION is not NIL, apply it."
397 (when function (apply #'apply function args)))
398
399 ;;; Remove keyword pairs from an argument list, consing as little as possible
400
401 (defun remove-keywords (arg-list keywords)
402 (let ((clean-tail arg-list))
403 ;; First, determine a tail in which there are no keywords to be removed.
404 (loop for arg-tail on arg-list by #'cddr
405 for (key) = arg-tail
406 do (when (member key keywords :test #'eq)
407 (setq clean-tail (cddr arg-tail))))
408 ;; Cons up the new arg list until we hit the clean-tail, then nconc that on
409 ;; the end.
410 (loop for arg-tail on arg-list by #'cddr
411 for (key value) = arg-tail
412 if (eq arg-tail clean-tail)
413 nconc clean-tail
414 and do (loop-finish)
415 else if (not (member key keywords :test #'eq))
416 nconc (list key value)
417 end)))
418
419 (defmacro with-keywords-removed ((var keywords &optional (new-var var))
420 &body body)
421 "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified
422 in KEYWORDS removed."
423 `(let ((,new-var (remove-keywords ,var ',keywords)))
424 ,@body))
425
426 (defun symbol-concat (&rest symbols)
427 "Actually this function raises the next question: what is *PACKAGE* supposed to be?
428 The correct answer: listen to the elders and don't use this function or any variant
429 of it -- Don't construct symbols, instead let the user specify them."
430 (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
431
432 (defun stream-designator-symbol (symbol default)
433 "Maps T to DEFAULT, barfs if argument does not look good.
434 To be used in the various WITH-... macros."
435 (cond ((eq symbol 't)
436 default)
437 ((symbolp symbol)
438 symbol)
439 (t
440 (error "~S Can not be a stream designator for ~S" symbol default))))
441
442 (defun declare-ignorable-form (variables)
443 #+CMU
444 ;; CMUCL barfs if you declare a special variable ignorable, work
445 ;; around that.
446 `(declare (ignorable
447 ,@(remove-if (lambda (symbol)
448 (eq :special (lisp::info lisp::variable lisp::kind symbol)))
449 variables)))
450 #-CMU
451 `(declare (ignorable ,@variables)))
452
453 ;; spread version:
454
455 (defun declare-ignorable-form* (&rest variables)
456 (declare-ignorable-form variables))
457
458 (defun gen-invoke-trampoline (fun to-bind to-pass body)
459 "Macro helper function, generates the LABELS / INVOKE-WITH-... ideom."
460 (let ((cont (gensym ".CONT.")))
461 `(labels ((,cont (,@to-bind)
462 ,(declare-ignorable-form to-bind)
463 ,@body))
464 (declare (dynamic-extent #',cont))
465 (,fun ,@to-bind #',cont ,@to-pass))))
466
467 ;;;; ----------------------------------------------------------------------
468
469 (defun parse-space (stream specification direction)
470 "Returns the amount of space given by SPECIFICATION relating to the
471 STREAM in the direction DIRECTION."
472 ;; This implementation lives unter the assumption that an
473 ;; extended-output stream is also a sheet and has a graft.
474 ;; --GB 2002-08-14
475 (etypecase specification
476 (integer specification)
477 ((or string character) (multiple-value-bind (width height)
478 (text-size stream specification)
479 (ecase direction
480 (:horizontal width)
481 (:vertical height))))
482 #+nil ; WITH-OUTPUT-TO-OUTPUT-RECORD not yet defined as a macro
483 (function (let ((record (with-output-to-output-record (stream)
484 (funcall specification))))
485 (ecase direction
486 (:horizontal (bounding-rectangle-width record))
487 (:vertical (bounding-rectangle-height record)))))
488 (cons
489 (destructuring-bind (value unit)
490 specification
491 (ecase unit
492 (:character
493 (* value (stream-character-width stream #\M)))
494 (:line
495 (* value (stream-line-height stream)))
496 ((:point :pixel :mm)
497 (let* ((graft (graft stream))
498 (gunit (graft-units graft)))
499 ;; mungle specification into what grafts talk about
500 (case unit
501 ((:point) (setf value (/ value 72) unit :inches))
502 ((:pixel) (setf unit :device))
503 ((:mm) (setf unit :millimeters)))
504 ;;
505 (multiple-value-bind (dx dy)
506 (multiple-value-call
507 #'transform-distance
508 (compose-transformation-with-scaling
509 (sheet-delta-transformation stream graft)
510 (/ (graft-width graft :units unit)
511 (graft-width graft :units gunit))
512 (/ (graft-height graft :units unit)
513 (graft-height graft :units gunit)))
514 (ecase direction
515 (:horizontal (values 1 0))
516 (:vertical (values 0 1))))
517 (/ value (sqrt (+ (* dx dx) (* dy dy))))))))))))
518
519 (defun delete-1 (item list &key (test #'eql) (key #'identity))
520 "Delete 1 ITEM from LIST. Second value is T if item was deleted."
521 (loop
522 for tail on list
523 and tail-prev = nil then tail
524 for (list-item) = tail
525 if (funcall test item (funcall key list-item))
526 do (return-from delete-1
527 (if tail-prev
528 (progn
529 (setf (cdr tail-prev) (cdr tail))
530 (values list t))
531 (values (cdr tail) t)))
532 finally (return (values list nil))))
533
534 ;;; Why do I feel like I've written this function 8 million times
535 ;;; already?
536
537 (defun parse-lambda-list (ll)
538 "Extract the parts of a function or method lambda list.
539
540 Returns values of required, &optional, &rest and &key
541 parameters. 5th value indicates that &key was seen"
542 (loop
543 with state = 'required
544 for var in ll
545 if (member var '(&optional &rest &key))
546 do (setq state var)
547 else if (eq state 'required)
548 collect var into required
549 else if (eq state '&optional)
550 collect var into optional
551 else if (eq state '&rest)
552 collect var into rest
553 else if (eq state '&key)
554 collect var into key
555 end
556 finally (return (values required optional rest key (eq state '&key)))))
557
558 (defun rebind-arguments (arg-list)
559 "Create temporary variables for non keywords in a list of
560 arguments. Returns two values: a binding list for let, and a new
561 argument list with the temporaries substituted in."
562 (loop
563 for arg in arg-list
564 for var = (gensym)
565 if (keywordp arg)
566 collect arg into new-arg-list
567 else
568 collect `(,var ,arg) into bindings
569 and collect var into new-arg-list
570 end
571 finally (return (values bindings new-arg-list))))
572
573 (defun make-keyword (obj)
574 "Turn OBJ into a keyword"
575 (etypecase obj
576 (keyword
577 obj)
578 (symbol
579 (intern (symbol-name obj) :keyword))
580 (string
581 (intern (string-upcase obj) :keyword))))
582
583 ;;; Command name utilities that are useful elsewhere.
584
585 (defun command-name-from-symbol (symbol)
586 (let ((name (symbol-name symbol)))
587 (string-capitalize
588 (substitute
589 #\Space #\-
590 (subseq name (if (string= '#:com- name :end2 (min (length name) 4))
591 4
592 0))))))
593
594 (defun keyword-arg-name-from-symbol (symbol)
595 (let ((name (symbol-name symbol)))
596 (string-capitalize (substitute #\Space #\- name))))

  ViewVC Help
Powered by ViewVC 1.1.5