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.5 2002/10/12 06:10:17 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 bind-when ((bind-var boundForm) &body body)
24 `(let ((,bind-var ,boundForm))
25 (declare (ignore-if-unused ,bind-var))
29 (defmacro bind-if ((bind-var boundForm) yup &optional nope)
30 `(let ((,bind-var ,boundForm))
37 (defmacro aif (test then &optional else)
41 (defmacro awhen (test-form &body body)
45 (defmacro awhile (expr &body body)
46 `(do ((it ,expr ,expr))
50 (defmacro aand (&rest args)
52 ((null (cdr args)) (car args))
53 (t `(aif ,(car args) (aand ,@(cdr args))))))
55 (defmacro acond (&rest clauses)
58 (let ((cl1 (car clauses))
60 `(let ((,sym ,(car cl1)))
62 (let ((it ,sym)) ,@(cdr cl1))
63 (acond ,@(cdr clauses)))))))
65 (defmacro alambda (parms &body body)
66 `(labels ((self ,parms ,@body))
70 (defmacro aif2 (test &optional then else)
72 `(multiple-value-bind (it ,win) ,test
73 (if (or it ,win) ,then ,else))))
75 (defmacro awhen2 (test &body body)
79 (defmacro awhile2 (test &body body)
80 (let ((flag (gensym)))
87 (defmacro acond2 (&rest clauses)
90 (let ((cl1 (car clauses))
93 `(multiple-value-bind (,val ,win) ,(car cl1)
95 (let ((it ,val)) ,@(cdr cl1))
96 (acond2 ,@(cdr clauses)))))))
103 `(pprint (macroexpand-1 ',expr)))
105 (defmacro print-form-and-results (form)
106 `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
108 (defun show (&optional (what :variables) (package *package*))
110 (:variables (show-variables package))
111 (:functions (show-functions package))))
113 (defun show-variables (package)
114 (do-symbols (s package)
115 (multiple-value-bind (sym status)
116 (find-symbol (symbol-name s) package)
117 (when (and (or (eq status :external)
118 (eq status :internal))
120 (format t "~&Symbol ~S~T -> ~S~%"
122 (symbol-value sym))))))
124 (defun show-functions (package)
125 (do-symbols (s package)
126 (multiple-value-bind (sym status)
127 (find-symbol (symbol-name s) package)
128 (when (and (or (eq status :external)
129 (eq status :internal))
131 (format t "~&Function ~S~T -> ~S~%"
133 (symbol-function sym))))))
136 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
143 (defmacro ensure-integer (obj)
144 "Ensure object is an integer. If it is a string, then parse it"
152 "Make into list if atom"
153 (if (listp obj) obj (list obj)))
155 (defun filter (fn lst)
156 "Filter a list by function, eliminate elements where fn returns nil"
159 (let ((val (funcall fn x)))
160 (if val (push val acc))))
166 (defun memo-proc (fn)
167 "Memoize results of call to fn, returns a closure with hash-table"
168 (let ((cache (make-hash-table :test #'equal)))
169 #'(lambda (&rest args)
170 (multiple-value-bind (val foundp) (gethash args cache)
173 (setf (gethash args cache)
174 (apply fn args)))))))
176 (defun memoize (fn-name)
177 (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
179 (defmacro defun-memo (fn args &body body)
180 "Define a memoized function"
181 `(memoize (defun ,fn ,args . ,body)))
183 (defmacro _f (op place &rest args)
184 (multiple-value-bind (vars forms var set access)
185 (get-setf-expansion place)
186 `(let* (,@(mapcar #'list vars forms)
187 (,(car var) (,op ,access ,@args)))
190 (defun compose (&rest fns)
192 (let ((fn1 (car (last fns)))
194 #'(lambda (&rest args)
195 (reduce #'funcall fns
197 :initial-value (apply fn1 args))))
202 (defmacro until (test &body body)
207 (defmacro while (test &body body)
212 (defmacro for ((var start stop) &body body)
213 (let ((gstop (gensym)))
214 `(do ((,var ,start (1+ ,var))
220 ;;; Keyword functions
222 (defun remove-keyword (key arglist)
223 (loop for sublist = arglist then rest until (null sublist)
224 for (elt arg . rest) = sublist
225 unless (eq key elt) append (list elt arg)))
227 (defun remove-keywords (key-names args)
228 (loop for ( name val ) on args by #'cddr
229 unless (member (symbol-name name) key-names
230 :key #'symbol-name :test 'equal)
231 append (list name val)))
233 (defmacro in (obj &rest choices)
234 (let ((insym (gensym)))
235 `(let ((,insym ,obj))
236 (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
239 (defmacro mean (&rest args)
240 `(/ (+ ,@args) ,(length args)))
242 (defmacro with-gensyms (syms &body body)
243 `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
250 (defun mapappend (fn list)
251 (apply #'append (mapcar fn list)))
254 (defun mapcar-append-string-nontailrec (func v)
255 "Concatenate results of mapcar lambda calls"
257 (concatenate 'string (funcall func it)
258 (mapcar-append-string-nontailrec func (cdr v)))
262 (defun mapcar-append-string (func v &optional (accum ""))
263 "Concatenate results of mapcar lambda calls"
265 (mapcar-append-string
268 (concatenate 'string accum (funcall func it)))
272 (defun mapcar2-append-string-nontailrec (func la lb)
273 "Concatenate results of mapcar lambda call's over two lists"
277 (concatenate 'string (funcall func a b)
278 (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
281 (defun mapcar2-append-string (func la lb &optional (accum ""))
282 "Concatenate results of mapcar lambda call's over two lists"
286 (mapcar2-append-string
290 (concatenate 'string accum (funcall func a b)))
296 (defun indent-spaces (n &optional (stream *standard-output*))
297 "Indent n*2 spaces to output stream"
298 (let ((fmt (format nil "~~~DT" (+ n n))))
299 (format stream fmt)))
301 (defun print-list (l &optional (output *standard-output*))
302 "Print a list to a stream"
305 (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
309 (defun print-rows (rows &optional (ostrm *standard-output*))
310 "Print a list of list rows to a stream"
312 (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
318 (defmacro concat-symbol (&rest args)
319 `(intern (concatenate 'string ,@args)))
321 (defmacro concat-symbol-pkg (pkg &rest args)
322 `(intern (concatenate 'string ,@args) ,pkg))
329 vec (start -1) (used -1) (new -1) (end -1))
333 (mod n (length (buf-vec buf)))))
335 (defun (setf bref) (val buf n)
336 (setf (svref (buf-vec buf)
337 (mod n (length (buf-vec buf))))
341 (make-buf :vec (make-array len)))
343 (defun buf-insert (x b)
344 (setf (bref b (incf (buf-end b))) x))
348 (bref b (incf (buf-start b)))
349 (setf (buf-used b) (buf-start b)
350 (buf-new b) (buf-end b))))
353 (when (< (buf-used b) (buf-new b))
354 (bref b (incf (buf-used b)))))
357 (setf (buf-used b) (buf-start b)
358 (buf-new b) (buf-end b)))
361 (setf (buf-start b) -1 (buf-used b) -1
362 (buf-new b) -1 (buf-end b) -1))
364 (defun buf-flush (b str)
365 (do ((i (1+ (buf-used b)) (1+ i)))
367 (princ (bref b i) str)))
370 (defun file-subst (old new file1 file2)
371 (with-open-file (in file1 :direction :input)
372 (with-open-file (out file2 :direction :output
373 :if-exists :supersede)
374 (stream-subst old new in out))))
376 (defun stream-subst (old new in out)
377 (declare (string old new))
382 (declare (fixnum pos len))
383 (do ((c (read-char in nil :eof)
384 (or (setf from-buf (buf-next buf))
385 (read-char in nil :eof))))
387 (declare (character c))
388 (cond ((char= c (char old pos))
390 (cond ((= pos len) ; 3
395 (buf-insert c buf))))
404 (princ (buf-pop buf) out)
407 (buf-flush buf out)))
412 (defun remove-tree-if (pred tree)
413 "Strip from tree of atoms that satistify predicate"
415 (unless (funcall pred tree)
417 (let ((car-strip (remove-tree-if pred (car tree)))
418 (cdr-strip (remove-tree-if pred (cdr tree))))
420 ((and car-strip (atom (cadr tree)) (null cdr-strip))
422 ((and car-strip cdr-strip)
423 (cons car-strip cdr-strip))
429 (defun find-tree (sym tree)
430 "Finds an atom as a car in tree and returns cdr tree at that positions"
431 (if (or (null tree) (atom tree))
433 (if (eql sym (car tree))
435 (aif (find-tree sym (car tree))
437 (aif (find-tree sym (cdr tree))
443 (defun print-file-contents (file &optional (strm *standard-output*))
444 "Opens a reads a file. Returns the contents as a single string"
445 (when (probe-file file)
446 (with-open-file (in file :direction :input)
447 (do ((line (read-line in nil 'eof)
448 (read-line in nil 'eof)))
450 (format strm "~A~%" line)))))
452 (defun read-file-to-string (file)
453 "Opens a reads a file. Returns the contents as a single string"
454 (with-output-to-string (out)
455 (with-open-file (in file :direction :input)
456 (do ((line (read-line in nil 'eof)
457 (read-line in nil 'eof)))
459 (format out "~A~%" line)))))
461 (defun read-file-to-strings (file)
462 "Opens a reads a file. Returns the contents as a list of strings"
464 (with-open-file (in file :direction :input)
465 (do ((line (read-line in nil 'eof)
466 (read-line in nil 'eof)))
473 ;;; Formatting functions
475 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
476 (multiple-value-bind (sec min hr dy mn yr wkday)
477 (decode-universal-time
478 (encode-universal-time s m hour day month year))
479 (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
480 "Friday" "Saturday" "Sunday")
482 (elt '("January" "February" "March" "April" "May" "June"
483 "July" "August" "September" "October" "November"
486 (format nil "~A" dy) (format nil "~A" yr)
487 (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
490 (defun date-string (ut)
491 (if (typep ut 'integer)
492 (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
493 (decode-universal-time ut)
494 (declare (ignore daylight-p zone))
495 (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"