genutils.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          gentils.lisp
   6 ;;;; Purpose:       Main general utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: genutils.lisp,v 1.5 2002/10/12 06:10:17 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19
  20 (in-package :kmrcl)
  21 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  22
  23 (defmacro bind-when ((bind-var boundForm) &body body)
  24   `(let ((,bind-var ,boundForm))
  25       (declare (ignore-if-unused ,bind-var))
  26       (when ,bind-var
  27         ,@body)))
  28
  29 (defmacro bind-if ((bind-var boundForm) yup &optional nope)
  30   `(let ((,bind-var ,boundForm))
  31       (if ,bind-var
  32          ,yup
  33          ,nope)))
  34
  35 ;; Anaphoric macros
  36
  37 (defmacro aif (test then &optional else)
  38   `(let ((it ,test))
  39      (if it ,then ,else)))
  40
  41 (defmacro awhen (test-form &body body)
  42   `(aif ,test-form
  43         (progn ,@body)))
  44
  45 (defmacro awhile (expr &body body)
  46   `(do ((it ,expr ,expr))
  47        ((not it))
  48      ,@body))
  49
  50 (defmacro aand (&rest args)
  51   (cond ((null args) t)
  52         ((null (cdr args)) (car args))
  53         (t `(aif ,(car args) (aand ,@(cdr args))))))
  54
  55 (defmacro acond (&rest clauses)
  56   (if (null clauses)
  57       nil
  58       (let ((cl1 (car clauses))
  59             (sym (gensym)))
  60         `(let ((,sym ,(car cl1)))
  61            (if ,sym
  62                (let ((it ,sym)) ,@(cdr cl1))
  63                (acond ,@(cdr clauses)))))))
  64
  65 (defmacro alambda (parms &body body)
  66   `(labels ((self ,parms ,@body))
  67      #'self))
  68
  69
  70 (defmacro aif2 (test &optional then else)
  71   (let ((win (gensym)))
  72     `(multiple-value-bind (it ,win) ,test
  73        (if (or it ,win) ,then ,else))))
  74
  75 (defmacro awhen2 (test &body body)
  76   `(aif2 ,test
  77          (progn ,@body)))
  78
  79 (defmacro awhile2 (test &body body)
  80   (let ((flag (gensym)))
  81     `(let ((,flag t))
  82        (while ,flag
  83          (aif2 ,test
  84                (progn ,@body)
  85                (setq ,flag nil))))))
  86
  87 (defmacro acond2 (&rest clauses)
  88   (if (null clauses)
  89       nil
  90       (let ((cl1 (car clauses))
  91             (val (gensym))
  92             (win (gensym)))
  93         `(multiple-value-bind (,val ,win) ,(car cl1)
  94            (if (or ,val ,win)
  95                (let ((it ,val)) ,@(cdr cl1))
  96                (acond2 ,@(cdr clauses)))))))
  97
  98
  99 ;; Debugging
 100
 101 (defmacro mac (expr)
 102 "Expand a macro"
 103   `(pprint (macroexpand-1 ',expr)))
 104
 105 (defmacro print-form-and-results (form)
 106   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
 107
 108 (defun show (&optional (what :variables) (package *package*))
 109   (ecase what
 110     (:variables (show-variables package))
 111     (:functions (show-functions package))))
 112
 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))
 119                  (boundp sym))
 120         (format t "~&Symbol ~S~T -> ~S~%"
 121                 sym
 122                 (symbol-value sym))))))
 123
 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))
 130                  (fboundp sym))
 131         (format t "~&Function ~S~T -> ~S~%"
 132                 sym
 133                 (symbol-function sym))))))
 134
 135 #+allegro
 136 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
 137     ()
 138   :strings-convert t)
 139
 140
 141 ;; Ensure functions
 142
 143 (defmacro ensure-integer (obj)
 144   "Ensure object is an integer. If it is a string, then parse it"
 145   `(if (stringp ,obj)
 146       (parse-integer ,obj)
 147     ,obj))
 148
 149 ;; Lists
 150
 151 (defun mklist (obj)
 152   "Make into list if atom"
 153   (if (listp obj) obj (list obj)))
 154
 155 (defun filter (fn lst)
 156   "Filter a list by function, eliminate elements where fn returns nil"
 157   (let ((acc nil))
 158     (dolist (x lst)
 159       (let ((val (funcall fn x)))
 160         (if val (push val acc))))
 161     (nreverse acc)))
 162
 163
 164 ;; Functions
 165
 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)
 171           (if foundp
 172               val
 173               (setf (gethash args cache)
 174                     (apply fn args)))))))
 175
 176 (defun memoize (fn-name)
 177   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
 178
 179 (defmacro defun-memo (fn args &body body)
 180   "Define a memoized function"
 181   `(memoize (defun ,fn ,args . ,body)))
 182
 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)))
 188        ,set)))
 189
 190 (defun compose (&rest fns)
 191   (if fns
 192       (let ((fn1 (car (last fns)))
 193             (fns (butlast fns)))
 194         #'(lambda (&rest args)
 195             (reduce #'funcall fns
 196                     :from-end t
 197                     :initial-value (apply fn1 args))))
 198       #'identity))
 199
 200 ;;; Loop macros
 201
 202 (defmacro until (test &body body)
 203   `(do ()
 204        (,test)
 205      ,@body))
 206
 207 (defmacro while (test &body body)
 208   `(do ()
 209        ((not ,test))
 210      ,@body))
 211
 212 (defmacro for ((var start stop) &body body)
 213   (let ((gstop (gensym)))
 214     `(do ((,var ,start (1+ ,var))
 215           (,gstop ,stop))
 216          ((> ,var ,gstop))
 217        ,@body)))
 218
 219
 220 ;;; Keyword functions
 221
 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)))
 226
 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)))
 232
 233 (defmacro in (obj &rest choices)
 234   (let ((insym (gensym)))
 235     `(let ((,insym ,obj))
 236        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 237                      choices)))))
 238
 239 (defmacro mean (&rest args)
 240   `(/ (+ ,@args) ,(length args)))
 241
 242 (defmacro with-gensyms (syms &body body)
 243   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 244           syms)
 245      ,@body))
 246
 247
 248 ;;; Mapping
 249
 250 (defun mapappend (fn list)
 251   (apply #'append (mapcar fn list)))
 252
 253
 254 (defun mapcar-append-string-nontailrec (func v)
 255 "Concatenate results of mapcar lambda calls"
 256   (aif (car v)
 257        (concatenate 'string (funcall func it)
 258                     (mapcar-append-string-nontailrec func (cdr v)))
 259        ""))
 260
 261
 262 (defun mapcar-append-string (func v &optional (accum ""))
 263 "Concatenate results of mapcar lambda calls"
 264   (aif (car v)
 265        (mapcar-append-string
 266         func
 267         (cdr v)
 268         (concatenate 'string accum (funcall func it)))
 269        accum))
 270
 271
 272 (defun mapcar2-append-string-nontailrec (func la lb)
 273 "Concatenate results of mapcar lambda call's over two lists"
 274   (let ((a (car la))
 275         (b (car lb)))
 276     (if (and a b)
 277       (concatenate 'string (funcall func a b)
 278                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 279       "")))
 280
 281 (defun mapcar2-append-string (func la lb &optional (accum ""))
 282 "Concatenate results of mapcar lambda call's over two lists"
 283   (let ((a (car la))
 284         (b (car lb)))
 285     (if (and a b)
 286         (mapcar2-append-string
 287          func
 288          (cdr la)
 289          (cdr lb)
 290          (concatenate 'string accum (funcall func a b)))
 291       accum)))
 292
 293
 294 ;;; Output
 295
 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)))
 300
 301 (defun print-list (l &optional (output *standard-output*))
 302 "Print a list to a stream"
 303   (if (consp l)
 304     (progn
 305       (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
 306       t)
 307     nil))
 308
 309 (defun print-rows (rows &optional (ostrm *standard-output*))
 310 "Print a list of list rows to a stream"
 311   (dolist (r rows)
 312     (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
 313     (terpri ostrm)))
 314
 315
 316 ;;; Symbol functions
 317
 318 (defmacro concat-symbol (&rest args)
 319   `(intern (concatenate 'string ,@args)))
 320
 321 (defmacro concat-symbol-pkg (pkg &rest args)
 322   `(intern (concatenate 'string ,@args) ,pkg))
 323
 324
 325 ;;; IO
 326
 327
 328 (defstruct buf
 329   vec (start -1) (used -1) (new -1) (end -1))
 330
 331 (defun bref (buf n)
 332   (svref (buf-vec buf)
 333          (mod n (length (buf-vec buf)))))
 334
 335 (defun (setf bref) (val buf n)
 336   (setf (svref (buf-vec buf)
 337                (mod n (length (buf-vec buf))))
 338         val))
 339
 340 (defun new-buf (len)
 341   (make-buf :vec (make-array len)))
 342
 343 (defun buf-insert (x b)
 344   (setf (bref b (incf (buf-end b))) x))
 345
 346 (defun buf-pop (b)
 347   (prog1
 348     (bref b (incf (buf-start b)))
 349     (setf (buf-used b) (buf-start b)
 350           (buf-new  b) (buf-end   b))))
 351
 352 (defun buf-next (b)
 353   (when (< (buf-used b) (buf-new b))
 354     (bref b (incf (buf-used b)))))
 355
 356 (defun buf-reset (b)
 357   (setf (buf-used b) (buf-start b)
 358         (buf-new  b) (buf-end   b)))
 359
 360 (defun buf-clear (b)
 361   (setf (buf-start b) -1 (buf-used  b) -1
 362         (buf-new   b) -1 (buf-end   b) -1))
 363
 364 (defun buf-flush (b str)
 365   (do ((i (1+ (buf-used b)) (1+ i)))
 366       ((> i (buf-end b)))
 367     (princ (bref b i) str)))
 368
 369
 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))))
 375
 376 (defun stream-subst (old new in out)
 377   (declare (string old new))
 378   (let* ((pos 0)
 379          (len (length old))
 380          (buf (new-buf len))
 381          (from-buf nil))
 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))))
 386         ((eql c :eof))
 387       (declare (character c))
 388       (cond ((char= c (char old pos))
 389              (incf pos)
 390              (cond ((= pos len)            ; 3
 391                     (princ new out)
 392                     (setf pos 0)
 393                     (buf-clear buf))
 394                    ((not from-buf)         ; 2
 395                     (buf-insert c buf))))
 396             ((zerop pos)                   ; 1
 397              (princ c out)
 398              (when from-buf
 399                (buf-pop buf)
 400                (buf-reset buf)))
 401             (t                             ; 4
 402              (unless from-buf
 403                (buf-insert c buf))
 404              (princ (buf-pop buf) out)
 405              (buf-reset buf)
 406              (setf pos 0))))
 407     (buf-flush buf out)))
 408
 409
 410 ;;; Tree Functions
 411
 412 (defun remove-tree-if (pred tree)
 413   "Strip from tree of atoms that satistify predicate"
 414   (if (atom tree)
 415       (unless (funcall pred tree)
 416         tree)
 417     (let ((car-strip (remove-tree-if pred (car tree)))
 418           (cdr-strip (remove-tree-if pred (cdr tree))))
 419       (cond
 420        ((and car-strip (atom (cadr tree)) (null cdr-strip))
 421         (list car-strip))
 422        ((and car-strip cdr-strip)
 423         (cons car-strip cdr-strip))
 424        (car-strip
 425         car-strip)
 426        (cdr-strip
 427         cdr-strip)))))
 428
 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))
 432       nil
 433     (if (eql sym (car tree))
 434         (cdr tree)
 435       (aif (find-tree sym (car tree))
 436           it
 437         (aif (find-tree sym (cdr tree))
 438             it
 439           nil)))))
 440
 441 ;;; Files
 442
 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)))
 449                         ((eql line 'eof))
 450                       (format strm "~A~%" line)))))
 451
 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)))
 458           ((eql line 'eof))
 459         (format out "~A~%" line)))))
 460
 461 (defun read-file-to-strings (file)
 462   "Opens a reads a file. Returns the contents as a list of strings"
 463   (let ((lines '()))
 464     (with-open-file (in file :direction :input)
 465       (do ((line (read-line in nil 'eof)
 466                  (read-line in nil 'eof)))
 467           ((eql line 'eof))
 468         (push line lines)))
 469     (nreverse lines)))
 470
 471
 472
 473 ;;; Formatting functions
 474
 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")
 481                  wkday)
 482             (elt '("January" "February" "March" "April" "May" "June"
 483                    "July" "August" "September" "October" "November"
 484                    "December")
 485                  (1- mn))
 486             (format nil "~A" dy) (format nil "~A" yr)
 487             (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
 488
 489
 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"
 496                 dow
 497                 day
 498                 (1- mon)
 499                 year
 500                 hr min sec))))
 501