1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: genutils.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.2 2002/10/06 13:30: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 GNU General Public License.
16 ;;;; *************************************************************************
21 (declaim (optimize (speed 3) (safety 1)))
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)))
295 (defmacro string-append (outputstr &rest args)
296 `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
298 (defmacro string-field-append (outputstr &rest args)
299 `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
301 (defun list-to-string (lst)
302 "Converts a list to a string, doesn't include any delimiters between elements"
303 (format nil "~{~A~}" lst))
305 (defun count-string-words (str)
306 (declare (simple-string str)
307 (optimize (speed 3) (safety 0)))
310 (declare (fixnum n-words))
311 (dotimes (i (length str))
312 (let ((ch (char str i)))
313 (declare (character ch))
314 (if (alphanumericp ch)
318 (setq in-word nil))))
322 (defun delimited-string-to-list (string &optional (separator #\space))
323 (excl:delimited-string-to-list string separator))
326 (defun delimited-string-to-list (sequence &optional (separator #\space))
327 "Split a string by a delimitor"
330 for end = (position separator sequence :start start)
331 collect (subseq sequence start end)
334 (setf start (1+ end))))
337 (defun list-to-delimited-string (list &optional (separator #\space))
338 (excl:list-to-delimited-string list separator))
341 (defun list-to-delimited-string (list &optional (separator #\space))
342 (let ((output (when list (format nil "~A" (car list)))))
343 (dolist (obj (rest list))
344 (setq output (concatenate 'string output
345 (format nil "~A" separator)
346 (format nil "~A" obj))))
349 (defun string-invert (str)
350 "Invert case of a string"
351 (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
353 (let ((up nil) (down nil))
355 (loop for char of-type character across str do
356 (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
357 ((lower-case-p char) (if up (return-from skip str) (setf down t)))))
358 (if up (string-downcase str) (string-upcase str)))))
360 (defun add-sql-quotes (s)
361 (substitute-string-for-char s #\' "''"))
363 (defun escape-backslashes (s)
364 (substitute-string-for-char s #\\ "\\\\"))
366 (defun substitute-string-for-char (procstr match-char subst-str)
367 "Substitutes a string for a single matching character of a string"
368 (let ((pos (position match-char procstr)))
371 (subseq procstr 0 pos) subst-str
372 (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
375 (defun string-substitute (string substring replacement-string)
376 "String substitute by Larry Hunter. Obtained from Google"
377 (let ((substring-length (length substring))
381 (search substring string)
382 (search substring string :start2 last-end)))
384 (concatenate 'string new-string (subseq string last-end)))
388 (subseq string last-end next-start)
390 (setq last-end (+ next-start substring-length)))))
393 (defun string-trim-last-character (s)
394 "Return the string less the last character"
395 (subseq s 0 (1- (length s))))
397 (defun string-hash (str &optional (bitmask 65535))
399 (declare (fixnum hash)
401 (dotimes (i (length str))
403 (setq hash (+ hash (char-code (char str i)))))
404 (logand hash bitmask)))
406 (defun string-not-null? (str)
407 (and str (not (zerop (length str)))))
409 (defun whitespace? (c)
410 (declare (character c))
411 (declare (optimize (speed 3) (safety 0)))
412 (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
414 (defun not-whitespace? (c)
415 (not (whitespace? c)))
417 (defun string-ws? (str)
418 "Return t if string is all whitespace"
420 (null (find-if #'not-whitespace? str))))
425 (unless (boundp '+indent-vector+)
426 (defconstant +indent-vector+
427 (make-array 15 :fill-pointer nil :adjustable nil
445 (defmacro indent-spaces (n &optional stream)
446 "Indent n*2 spaces to output stream"
448 `(let ((,st ,stream))
450 (setq ,st *standard-output*))
453 (princ (aref +indent-vector+ ,n) ,st)
456 (format ,st " ")))))))
458 (defun print-list (l &optional (output *standard-output*))
459 "Print a list to a stream"
462 (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
466 (defun print-rows (rows &optional (ostrm *standard-output*))
467 "Print a list of list rows to a stream"
469 (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
475 (defmacro concat-symbol (&rest args)
476 `(intern (concatenate 'string ,@args)))
478 (defmacro concat-symbol-pkg (pkg &rest args)
479 `(intern (concatenate 'string ,@args) ,pkg))
486 vec (start -1) (used -1) (new -1) (end -1))
490 (mod n (length (buf-vec buf)))))
492 (defun (setf bref) (val buf n)
493 (setf (svref (buf-vec buf)
494 (mod n (length (buf-vec buf))))
498 (make-buf :vec (make-array len)))
500 (defun buf-insert (x b)
501 (setf (bref b (incf (buf-end b))) x))
505 (bref b (incf (buf-start b)))
506 (setf (buf-used b) (buf-start b)
507 (buf-new b) (buf-end b))))
510 (when (< (buf-used b) (buf-new b))
511 (bref b (incf (buf-used b)))))
514 (setf (buf-used b) (buf-start b)
515 (buf-new b) (buf-end b)))
518 (setf (buf-start b) -1 (buf-used b) -1
519 (buf-new b) -1 (buf-end b) -1))
521 (defun buf-flush (b str)
522 (do ((i (1+ (buf-used b)) (1+ i)))
524 (princ (bref b i) str)))
527 (defun file-subst (old new file1 file2)
528 (with-open-file (in file1 :direction :input)
529 (with-open-file (out file2 :direction :output
530 :if-exists :supersede)
531 (stream-subst old new in out))))
533 (defun stream-subst (old new in out)
534 (declare (string old new))
539 (declare (fixnum pos len))
540 (do ((c (read-char in nil :eof)
541 (or (setf from-buf (buf-next buf))
542 (read-char in nil :eof))))
544 (declare (character c))
545 (cond ((char= c (char old pos))
547 (cond ((= pos len) ; 3
552 (buf-insert c buf))))
561 (princ (buf-pop buf) out)
564 (buf-flush buf out)))
569 (defun remove-tree-if (pred tree)
570 "Strip from tree of atoms that satistify predicate"
572 (unless (funcall pred tree)
574 (let ((car-strip (remove-tree-if pred (car tree)))
575 (cdr-strip (remove-tree-if pred (cdr tree))))
577 ((and car-strip (atom (cadr tree)) (null cdr-strip))
579 ((and car-strip cdr-strip)
580 (cons car-strip cdr-strip))
586 (defun find-tree (sym tree)
587 "Finds an atom as a car in tree and returns cdr tree at that positions"
588 (if (or (null tree) (atom tree))
590 (if (eql sym (car tree))
592 (aif (find-tree sym (car tree))
594 (aif (find-tree sym (cdr tree))
600 (defun print-file-contents (file &optional (strm *standard-output*))
601 "Opens a reads a file. Returns the contents as a single string"
602 (when (probe-file file)
603 (with-open-file (in file :direction :input)
604 (do ((line (read-line in nil 'eof)
605 (read-line in nil 'eof)))
607 (format strm "~A~%" line)))))
609 (defun read-file-to-string (file)
610 "Opens a reads a file. Returns the contents as a single string"
611 (with-output-to-string (out)
612 (with-open-file (in file :direction :input)
613 (do ((line (read-line in nil 'eof)
614 (read-line in nil 'eof)))
616 (format out "~A~%" line)))))
618 (defun read-file-to-strings (file)
619 "Opens a reads a file. Returns the contents as a list of strings"
621 (with-open-file (in file :direction :input)
622 (do ((line (read-line in nil 'eof)
623 (read-line in nil 'eof)))
629 ;; Generalized equal system
631 (defun generalized-equal (obj1 obj2)
632 (if (not (equal (type-of obj1) (type-of obj2)))
640 (let ((diff (abs (/ (- obj1 obj2) obj1))))
641 (if (> diff (* 10 double-float-epsilon))
645 (and (generalized-equal (realpart obj1) (realpart obj2))
646 (generalized-equal (imagpart obj1) (imagpart obj2))))
648 (generalized-equal-fielded-object obj1 obj2))
650 (generalized-equal-fielded-object obj1 obj2))
652 (generalized-equal-hash-table obj1 obj2)
655 (generalized-equal-function obj1 obj2))
659 (generalized-equal-array obj1 obj2))
661 (equal obj1 obj2)))))
664 (defun generalized-equal-function (obj1 obj2)
665 (string= (function-to-string obj1) (function-to-string obj2)))
667 (defun generalized-equal-array (obj1 obj2)
669 (when (not (= (array-total-size obj1) (array-total-size obj2)))
670 (return-from test nil))
671 (dotimes (i (array-total-size obj1))
672 (unless (generalized-equal (aref obj1 i) (aref obj2 i))
673 (return-from test nil)))
674 (return-from test t)))
676 (defun generalized-equal-hash-table (obj1 obj2)
678 (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
679 (return-from test nil))
682 (multiple-value-bind (value found) (gethash k obj2)
683 (unless (and found (generalized-equal v value))
684 (return-from test nil))))
686 (return-from test t)))
688 (defun generalized-equal-fielded-object (obj1 obj2)
690 (when (not (equal (class-of obj1) (class-of obj2)))
691 (return-from test nil))
692 (dolist (field (class-slot-names (class-name (class-of obj1))))
693 (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
694 (return-from test nil)))
695 (return-from test t)))
697 #+(or allegro lispworks)
698 (defun class-slot-names (class-name)
699 "Given a CLASS-NAME, returns a list of the slots in the class."
700 (mapcar #'clos:slot-definition-name
701 (clos:class-slots (find-class class-name))))
703 #-(or allegro lispworks)
704 (defun class-slot-names (class-name)
705 (warn "class-slot-names not supported on this platform"))
708 (defun function-to-string (obj)
709 "Returns the lambda code for a function. Relies on
710 Allegro implementation-dependent features."
711 (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
712 (declare (ignore closurep))
714 (format nil "#'~s" lambda)
716 (format nil "#'~s" name)
722 ;;; Formatting functions
724 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
725 (multiple-value-bind (sec min hr dy mn yr wkday)
726 (decode-universal-time
727 (encode-universal-time s m hour day month year))
728 (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
729 "Friday" "Saturday" "Sunday")
731 (elt '("January" "February" "March" "April" "May" "June"
732 "July" "August" "September" "October" "November"
735 (format nil "~A" dy) (format nil "~A" yr)
736 (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
739 (defun date-string (ut)
740 (if (typep ut 'integer)
741 (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
742 (decode-universal-time ut)
743 (declare (ignore daylight-p zone))
744 (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~
745 ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~
746 ~2,'0d:~2,'0d:~2,'0d"