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.10 2002/11/08 06:43:34 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 (defmacro with-each-stream-line ((var stream) &body body)
 220   (let ((eof (gensym))
 221         (eof-value (gensym))
 222         (strm (gensym)))
 223     `(let ((,strm ,stream)
 224            (,eof ',eof-value))
 225       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 226           ((eql ,var ,eof))
 227         ,@body))))
 228
 229 (defmacro with-each-file-line ((var file) &body body)
 230   (let ((stream (gensym)))
 231     `(with-open-file (,stream ,file :direction :input)
 232       (with-each-stream-line (,var ,stream)
 233         ,@body))))
 234
 235
 236 ;;; Keyword functions
 237
 238 (defun remove-keyword (key arglist)
 239   (loop for sublist = arglist then rest until (null sublist)
 240         for (elt arg . rest) = sublist
 241         unless (eq key elt) append (list elt arg)))
 242
 243 (defun remove-keywords (key-names args)
 244   (loop for ( name val ) on args by #'cddr
 245         unless (member (symbol-name name) key-names
 246                        :key #'symbol-name :test 'equal)
 247         append (list name val)))
 248
 249 (defmacro in (obj &rest choices)
 250   (let ((insym (gensym)))
 251     `(let ((,insym ,obj))
 252        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 253                      choices)))))
 254
 255 (defmacro mean (&rest args)
 256   `(/ (+ ,@args) ,(length args)))
 257
 258 (defmacro with-gensyms (syms &body body)
 259   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 260           syms)
 261      ,@body))
 262
 263
 264 ;;; Mapping
 265
 266 (defun mapappend (fn list)
 267   (apply #'append (mapcar fn list)))
 268
 269
 270 (defun mapcar-append-string-nontailrec (func v)
 271   "Concatenate results of mapcar lambda calls"
 272   (aif (car v)
 273        (concatenate 'string (funcall func it)
 274                     (mapcar-append-string-nontailrec func (cdr v)))
 275        ""))
 276
 277
 278 (defun mapcar-append-string (func v &optional (accum ""))
 279   "Concatenate results of mapcar lambda calls"
 280   (aif (car v)
 281        (mapcar-append-string
 282         func
 283         (cdr v)
 284         (concatenate 'string accum (funcall func it)))
 285        accum))
 286
 287 (defun mapcar2-append-string-nontailrec (func la lb)
 288   "Concatenate results of mapcar lambda call's over two lists"
 289   (let ((a (car la))
 290         (b (car lb)))
 291     (if (and a b)
 292       (concatenate 'string (funcall func a b)
 293                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 294       "")))
 295
 296 (defun mapcar2-append-string (func la lb &optional (accum ""))
 297   "Concatenate results of mapcar lambda call's over two lists"
 298   (let ((a (car la))
 299         (b (car lb)))
 300     (if (and a b)
 301         (mapcar2-append-string
 302          func
 303          (cdr la)
 304          (cdr lb)
 305          (concatenate 'string accum (funcall func a b)))
 306       accum)))
 307
 308
 309 ;;; Output
 310
 311 (defun indent-spaces (n &optional (stream *standard-output*))
 312   "Indent n*2 spaces to output stream"
 313   (when (numberp n)
 314     (let ((fmt (format nil "~~~DT" (+ n n))))
 315       (format stream fmt))))
 316
 317 (defun print-list (l &optional (output *standard-output*))
 318   "Print a list to a stream"
 319   (if (consp l)
 320     (progn
 321       (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
 322       t)
 323     nil))
 324
 325 (defun print-rows (rows &optional (ostrm *standard-output*))
 326   "Print a list of list rows to a stream"
 327   (dolist (r rows)
 328     (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
 329     (terpri ostrm)))
 330
 331
 332 ;;; Symbol functions
 333
 334 (defmacro concat-symbol (&rest args)
 335   `(intern (concatenate 'string ,@args)))
 336
 337 (defmacro concat-symbol-pkg (pkg &rest args)
 338   `(intern (concatenate 'string ,@args) ,pkg))
 339
 340
 341 ;;; IO
 342
 343
 344 (defstruct buf
 345   vec (start -1) (used -1) (new -1) (end -1))
 346
 347 (defun bref (buf n)
 348   (svref (buf-vec buf)
 349          (mod n (length (buf-vec buf)))))
 350
 351 (defun (setf bref) (val buf n)
 352   (setf (svref (buf-vec buf)
 353                (mod n (length (buf-vec buf))))
 354         val))
 355
 356 (defun new-buf (len)
 357   (make-buf :vec (make-array len)))
 358
 359 (defun buf-insert (x b)
 360   (setf (bref b (incf (buf-end b))) x))
 361
 362 (defun buf-pop (b)
 363   (prog1
 364     (bref b (incf (buf-start b)))
 365     (setf (buf-used b) (buf-start b)
 366           (buf-new  b) (buf-end   b))))
 367
 368 (defun buf-next (b)
 369   (when (< (buf-used b) (buf-new b))
 370     (bref b (incf (buf-used b)))))
 371
 372 (defun buf-reset (b)
 373   (setf (buf-used b) (buf-start b)
 374         (buf-new  b) (buf-end   b)))
 375
 376 (defun buf-clear (b)
 377   (setf (buf-start b) -1 (buf-used  b) -1
 378         (buf-new   b) -1 (buf-end   b) -1))
 379
 380 (defun buf-flush (b str)
 381   (do ((i (1+ (buf-used b)) (1+ i)))
 382       ((> i (buf-end b)))
 383     (princ (bref b i) str)))
 384
 385
 386 (defun file-subst (old new file1 file2)
 387   (with-open-file (in file1 :direction :input)
 388     (with-open-file (out file2 :direction :output
 389                          :if-exists :supersede)
 390       (stream-subst old new in out))))
 391
 392 (defun stream-subst (old new in out)
 393   (declare (string old new))
 394   (let* ((pos 0)
 395          (len (length old))
 396          (buf (new-buf len))
 397          (from-buf nil))
 398     (declare (fixnum pos len))
 399     (do ((c (read-char in nil :eof)
 400             (or (setf from-buf (buf-next buf))
 401                 (read-char in nil :eof))))
 402         ((eql c :eof))
 403       (declare (character c))
 404       (cond ((char= c (char old pos))
 405              (incf pos)
 406              (cond ((= pos len)            ; 3
 407                     (princ new out)
 408                     (setf pos 0)
 409                     (buf-clear buf))
 410                    ((not from-buf)         ; 2
 411                     (buf-insert c buf))))
 412             ((zerop pos)                   ; 1
 413              (princ c out)
 414              (when from-buf
 415                (buf-pop buf)
 416                (buf-reset buf)))
 417             (t                             ; 4
 418              (unless from-buf
 419                (buf-insert c buf))
 420              (princ (buf-pop buf) out)
 421              (buf-reset buf)
 422              (setf pos 0))))
 423     (buf-flush buf out)))
 424
 425
 426 ;;; Tree Functions
 427
 428 (defun remove-tree-if (pred tree)
 429   "Strip from tree of atoms that satistify predicate"
 430   (if (atom tree)
 431       (unless (funcall pred tree)
 432         tree)
 433     (let ((car-strip (remove-tree-if pred (car tree)))
 434           (cdr-strip (remove-tree-if pred (cdr tree))))
 435       (cond
 436        ((and car-strip (atom (cadr tree)) (null cdr-strip))
 437         (list car-strip))
 438        ((and car-strip cdr-strip)
 439         (cons car-strip cdr-strip))
 440        (car-strip
 441         car-strip)
 442        (cdr-strip
 443         cdr-strip)))))
 444
 445 (defun find-tree (sym tree)
 446   "Finds an atom as a car in tree and returns cdr tree at that positions"
 447   (if (or (null tree) (atom tree))
 448       nil
 449     (if (eql sym (car tree))
 450         (cdr tree)
 451       (aif (find-tree sym (car tree))
 452           it
 453         (aif (find-tree sym (cdr tree))
 454             it
 455           nil)))))
 456
 457 ;;; Files
 458
 459 (defun print-file-contents (file &optional (strm *standard-output*))
 460   "Opens a reads a file. Returns the contents as a single string"
 461   (when (probe-file file)
 462     (with-open-file (in file :direction :input)
 463       (let ((eof (gensym)))
 464         (do ((line (read-line in nil eof)
 465                    (read-line in nil eof)))
 466             ((eq line eof))
 467           (format strm "~A~%" line))))))
 468
 469 (defun read-file-to-string (file)
 470   "Opens a reads a file. Returns the contents as a single string"
 471   (with-output-to-string (out)
 472     (with-open-file (in file :direction :input)
 473       (let ((eof (gensym)))
 474         (do ((line (read-line in nil eof)
 475                    (read-line in nil eof)))
 476             ((eq line eof))
 477           (format out "~A~%" line))))))
 478
 479 (defun read-file-to-strings (file)
 480   "Opens a reads a file. Returns the contents as a list of strings"
 481   (let ((lines '()))
 482     (with-open-file (in file :direction :input)
 483       (let ((eof (gensym)))
 484         (do ((line (read-line in nil eof)
 485                    (read-line in nil eof)))
 486             ((eq line eof))
 487           (push line lines)))
 488       (nreverse lines))))
 489
 490
 491 ;;; Formatting functions
 492
 493 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
 494   (multiple-value-bind (sec min hr dy mn yr wkday)
 495     (decode-universal-time
 496      (encode-universal-time s m hour day month year))
 497     (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
 498                    "Friday" "Saturday" "Sunday")
 499                  wkday)
 500             (elt '("January" "February" "March" "April" "May" "June"
 501                    "July" "August" "September" "October" "November"
 502                    "December")
 503                  (1- mn))
 504             (format nil "~A" dy) (format nil "~A" yr)
 505             (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
 506
 507
 508 (defun date-string (ut)
 509   (if (typep ut 'integer)
 510       (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
 511           (decode-universal-time ut)
 512         (declare (ignore daylight-p zone))
 513         (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"
 514                 dow
 515                 day
 516                 (1- mon)
 517                 year
 518                 hr min sec))))
 519