1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: gentils.lisp
6 ;;;; Purpose: Main general utility functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: genutils.lisp,v 1.14 2003/01/13 21:40:20 kevin Exp $
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
23 (defmacro let-when ((var test-form) &body body)
24 `(let ((,var ,test-form))
27 (defmacro let-if ((var test-form) if-true &optional if-false)
28 `(let ((,var ,test-form))
29 (if ,var ,if-true ,if-false)))
33 (defmacro aif (test then &optional else)
37 (defmacro awhen (test-form &body body)
41 (defmacro awhile (expr &body body)
42 `(do ((it ,expr ,expr))
46 (defmacro aand (&rest args)
48 ((null (cdr args)) (car args))
49 (t `(aif ,(car args) (aand ,@(cdr args))))))
51 (defmacro acond (&rest clauses)
54 (let ((cl1 (car clauses))
56 `(let ((,sym ,(car cl1)))
58 (let ((it ,sym)) ,@(cdr cl1))
59 (acond ,@(cdr clauses)))))))
61 (defmacro alambda (parms &body body)
62 `(labels ((self ,parms ,@body))
66 (defmacro aif2 (test &optional then else)
68 `(multiple-value-bind (it ,win) ,test
69 (if (or it ,win) ,then ,else))))
71 (defmacro awhen2 (test &body body)
75 (defmacro awhile2 (test &body body)
76 (let ((flag (gensym)))
83 (defmacro acond2 (&rest clauses)
86 (let ((cl1 (car clauses))
89 `(multiple-value-bind (,val ,win) ,(car cl1)
91 (let ((it ,val)) ,@(cdr cl1))
92 (acond2 ,@(cdr clauses)))))))
99 `(pprint (macroexpand-1 ',expr)))
101 (defmacro print-form-and-results (form)
102 `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
104 (defun show (&optional (what :variables) (package *package*))
106 (:variables (show-variables package))
107 (:functions (show-functions package))))
109 (defun show-variables (package)
110 (do-symbols (s package)
111 (multiple-value-bind (sym status)
112 (find-symbol (symbol-name s) package)
113 (when (and (or (eq status :external)
114 (eq status :internal))
116 (format t "~&Symbol ~S~T -> ~S~%"
118 (symbol-value sym))))))
120 (defun show-functions (package)
121 (do-symbols (s package)
122 (multiple-value-bind (sym status)
123 (find-symbol (symbol-name s) package)
124 (when (and (or (eq status :external)
125 (eq status :internal))
127 (format t "~&Function ~S~T -> ~S~%"
129 (symbol-function sym))))))
132 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
139 (defmacro ensure-integer (obj)
140 "Ensure object is an integer. If it is a string, then parse it"
148 "Make into list if atom"
149 (if (listp obj) obj (list obj)))
151 (defun filter (fn lst)
152 "Filter a list by function, eliminate elements where fn returns nil"
155 (let ((val (funcall fn x)))
156 (if val (push val acc))))
159 (defun appendnew (l1 l2)
160 "Append two lists, filtering out elem from second list that are already in first list"
162 (unless (find elem l1)
163 (setq l1 (append l1 (list elem)))))
168 (defun memo-proc (fn)
169 "Memoize results of call to fn, returns a closure with hash-table"
170 (let ((cache (make-hash-table :test #'equal)))
171 #'(lambda (&rest args)
172 (multiple-value-bind (val foundp) (gethash args cache)
175 (setf (gethash args cache)
176 (apply fn args)))))))
178 (defun memoize (fn-name)
179 (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
181 (defmacro defun-memo (fn args &body body)
182 "Define a memoized function"
183 `(memoize (defun ,fn ,args . ,body)))
185 (defmacro _f (op place &rest args)
186 (multiple-value-bind (vars forms var set access)
187 (get-setf-expansion place)
188 `(let* (,@(mapcar #'list vars forms)
189 (,(car var) (,op ,access ,@args)))
192 (defun compose (&rest fns)
194 (let ((fn1 (car (last fns)))
196 #'(lambda (&rest args)
197 (reduce #'funcall fns
199 :initial-value (apply fn1 args))))
204 (defmacro until (test &body body)
209 (defmacro while (test &body body)
214 (defmacro for ((var start stop) &body body)
215 (let ((gstop (gensym)))
216 `(do ((,var ,start (1+ ,var))
221 (defmacro with-each-stream-line ((var stream) &body body)
225 `(let ((,strm ,stream)
227 (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
231 (defmacro with-each-file-line ((var file) &body body)
232 (let ((stream (gensym)))
233 `(with-open-file (,stream ,file :direction :input)
234 (with-each-stream-line (,var ,stream)
238 ;;; Keyword functions
240 (defun remove-keyword (key arglist)
241 (loop for sublist = arglist then rest until (null sublist)
242 for (elt arg . rest) = sublist
243 unless (eq key elt) append (list elt arg)))
245 (defun remove-keywords (key-names args)
246 (loop for ( name val ) on args by #'cddr
247 unless (member (symbol-name name) key-names
248 :key #'symbol-name :test 'equal)
249 append (list name val)))
251 (defmacro in (obj &rest choices)
252 (let ((insym (gensym)))
253 `(let ((,insym ,obj))
254 (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
257 (defmacro mean (&rest args)
258 `(/ (+ ,@args) ,(length args)))
260 (defmacro with-gensyms (syms &body body)
261 `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
268 (defun mapappend (fn list)
269 (apply #'append (mapcar fn list)))
272 (defun mapcar-append-string-nontailrec (func v)
273 "Concatenate results of mapcar lambda calls"
275 (concatenate 'string (funcall func it)
276 (mapcar-append-string-nontailrec func (cdr v)))
280 (defun mapcar-append-string (func v &optional (accum ""))
281 "Concatenate results of mapcar lambda calls"
283 (mapcar-append-string
286 (concatenate 'string accum (funcall func it)))
289 (defun mapcar2-append-string-nontailrec (func la lb)
290 "Concatenate results of mapcar lambda call's over two lists"
294 (concatenate 'string (funcall func a b)
295 (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
298 (defun mapcar2-append-string (func la lb &optional (accum ""))
299 "Concatenate results of mapcar lambda call's over two lists"
303 (mapcar2-append-string
307 (concatenate 'string accum (funcall func a b)))
313 (defun indent-spaces (n &optional (stream *standard-output*))
314 "Indent n*2 spaces to output stream"
316 (let ((fmt (format nil "~~~DT" (+ n n))))
317 (format stream fmt))))
319 (defun print-list (l &optional (output *standard-output*))
320 "Print a list to a stream"
323 (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
327 (defun print-rows (rows &optional (ostrm *standard-output*))
328 "Print a list of list rows to a stream"
330 (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
338 vec (start -1) (used -1) (new -1) (end -1))
342 (mod n (length (buf-vec buf)))))
344 (defun (setf bref) (val buf n)
345 (setf (svref (buf-vec buf)
346 (mod n (length (buf-vec buf))))
350 (make-buf :vec (make-array len)))
352 (defun buf-insert (x b)
353 (setf (bref b (incf (buf-end b))) x))
357 (bref b (incf (buf-start b)))
358 (setf (buf-used b) (buf-start b)
359 (buf-new b) (buf-end b))))
362 (when (< (buf-used b) (buf-new b))
363 (bref b (incf (buf-used b)))))
366 (setf (buf-used b) (buf-start b)
367 (buf-new b) (buf-end b)))
370 (setf (buf-start b) -1 (buf-used b) -1
371 (buf-new b) -1 (buf-end b) -1))
373 (defun buf-flush (b str)
374 (do ((i (1+ (buf-used b)) (1+ i)))
376 (princ (bref b i) str)))
379 (defun file-subst (old new file1 file2)
380 (with-open-file (in file1 :direction :input)
381 (with-open-file (out file2 :direction :output
382 :if-exists :supersede)
383 (stream-subst old new in out))))
385 (defun stream-subst (old new in out)
386 (declare (string old new))
391 (declare (fixnum pos len))
392 (do ((c (read-char in nil :eof)
393 (or (setf from-buf (buf-next buf))
394 (read-char in nil :eof))))
396 (declare (character c))
397 (cond ((char= c (char old pos))
399 (cond ((= pos len) ; 3
404 (buf-insert c buf))))
413 (princ (buf-pop buf) out)
416 (buf-flush buf out)))
421 (defun remove-tree-if (pred tree)
422 "Strip from tree of atoms that satistify predicate"
424 (unless (funcall pred tree)
426 (let ((car-strip (remove-tree-if pred (car tree)))
427 (cdr-strip (remove-tree-if pred (cdr tree))))
429 ((and car-strip (atom (cadr tree)) (null cdr-strip))
431 ((and car-strip cdr-strip)
432 (cons car-strip cdr-strip))
438 (defun find-tree (sym tree)
439 "Finds an atom as a car in tree and returns cdr tree at that positions"
440 (if (or (null tree) (atom tree))
442 (if (eql sym (car tree))
444 (aif (find-tree sym (car tree))
446 (aif (find-tree sym (cdr tree))
452 (defun print-file-contents (file &optional (strm *standard-output*))
453 "Opens a reads a file. Returns the contents as a single string"
454 (when (probe-file file)
455 (with-open-file (in file :direction :input)
456 (let ((eof (gensym)))
457 (do ((line (read-line in nil eof)
458 (read-line in nil eof)))
460 (format strm "~A~%" line))))))
462 (defun read-file-to-string (file)
463 "Opens a reads a file. Returns the contents as a single string"
464 (with-output-to-string (out)
465 (with-open-file (in file :direction :input)
466 (let ((eof (gensym)))
467 (do ((line (read-line in nil eof)
468 (read-line in nil eof)))
470 (format out "~A~%" line))))))
472 (defun read-file-to-strings (file)
473 "Opens a reads a file. Returns the contents as a list of strings"
475 (with-open-file (in file :direction :input)
476 (let ((eof (gensym)))
477 (do ((line (read-line in nil eof)
478 (read-line in nil eof)))
484 ;;; Formatting functions
486 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
487 (multiple-value-bind (sec min hr dy mn yr wkday)
488 (decode-universal-time
489 (encode-universal-time s m hour day month year))
490 (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
491 "Friday" "Saturday" "Sunday")
493 (elt '("January" "February" "March" "April" "May" "June"
494 "July" "August" "September" "October" "November"
497 (format nil "~A" dy) (format nil "~A" yr)
498 (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
501 (defun date-string (ut)
502 (if (typep ut 'integer)
503 (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
504 (decode-universal-time ut)
505 (declare (ignore daylight-p zone))
506 (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
516 (defun print-float-units (val unit)
519 (format t "~,2,9F nano~A" val unit))
521 (format t "~,2,6F micro~A" val unit))
523 (format t "~,2,3F milli~A" val unit))
525 (format t "~,2,-9F giga~A" val unit))
527 (format t "~,2,-6F mega~A" val unit))
529 (format t "~,2,-3F kilo~A" val unit))
531 (format t "~,2F ~A" val unit))))
533 (defun print-seconds (secs)
534 (print-float-units secs "sec"))
536 (defmacro time-iterations (n &body body)
541 (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
542 (let ((t1 (get-internal-real-time)))
545 (let* ((t2 (get-internal-real-time))
546 (secs (coerce (/ (- t2 t1)
547 internal-time-units-per-second)
549 (format t "~&Total time: ")
551 (format t ", time per iteration: ")
552 (print-seconds (coerce (/ secs ,n) 'double-float))))))))