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.11 2002/12/04 16:49:23 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 let-when ((var test-form) &body body)
  24   `(let ((,var ,test-form))
  25       (when ,var ,@body)))
  26
  27 (defmacro let-if ((var test-form) if-true &optional if-false)
  28   `(let ((,var ,test-form))
  29       (if ,var ,if-true ,if-false)))
  30
  31 ;; Anaphoric macros
  32
  33 (defmacro aif (test then &optional else)
  34   `(let ((it ,test))
  35      (if it ,then ,else)))
  36
  37 (defmacro awhen (test-form &body body)
  38   `(aif ,test-form
  39         (progn ,@body)))
  40
  41 (defmacro awhile (expr &body body)
  42   `(do ((it ,expr ,expr))
  43        ((not it))
  44      ,@body))
  45
  46 (defmacro aand (&rest args)
  47   (cond ((null args) t)
  48         ((null (cdr args)) (car args))
  49         (t `(aif ,(car args) (aand ,@(cdr args))))))
  50
  51 (defmacro acond (&rest clauses)
  52   (if (null clauses)
  53       nil
  54       (let ((cl1 (car clauses))
  55             (sym (gensym)))
  56         `(let ((,sym ,(car cl1)))
  57            (if ,sym
  58                (let ((it ,sym)) ,@(cdr cl1))
  59                (acond ,@(cdr clauses)))))))
  60
  61 (defmacro alambda (parms &body body)
  62   `(labels ((self ,parms ,@body))
  63      #'self))
  64
  65
  66 (defmacro aif2 (test &optional then else)
  67   (let ((win (gensym)))
  68     `(multiple-value-bind (it ,win) ,test
  69        (if (or it ,win) ,then ,else))))
  70
  71 (defmacro awhen2 (test &body body)
  72   `(aif2 ,test
  73          (progn ,@body)))
  74
  75 (defmacro awhile2 (test &body body)
  76   (let ((flag (gensym)))
  77     `(let ((,flag t))
  78        (while ,flag
  79          (aif2 ,test
  80                (progn ,@body)
  81                (setq ,flag nil))))))
  82
  83 (defmacro acond2 (&rest clauses)
  84   (if (null clauses)
  85       nil
  86       (let ((cl1 (car clauses))
  87             (val (gensym))
  88             (win (gensym)))
  89         `(multiple-value-bind (,val ,win) ,(car cl1)
  90            (if (or ,val ,win)
  91                (let ((it ,val)) ,@(cdr cl1))
  92                (acond2 ,@(cdr clauses)))))))
  93
  94
  95 ;; Debugging
  96
  97 (defmacro mac (expr)
  98 "Expand a macro"
  99   `(pprint (macroexpand-1 ',expr)))
 100
 101 (defmacro print-form-and-results (form)
 102   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
 103
 104 (defun show (&optional (what :variables) (package *package*))
 105   (ecase what
 106     (:variables (show-variables package))
 107     (:functions (show-functions package))))
 108
 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))
 115                  (boundp sym))
 116         (format t "~&Symbol ~S~T -> ~S~%"
 117                 sym
 118                 (symbol-value sym))))))
 119
 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))
 126                  (fboundp sym))
 127         (format t "~&Function ~S~T -> ~S~%"
 128                 sym
 129                 (symbol-function sym))))))
 130
 131 #+allegro
 132 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
 133     ()
 134   :strings-convert t)
 135
 136
 137 ;; Ensure functions
 138
 139 (defmacro ensure-integer (obj)
 140   "Ensure object is an integer. If it is a string, then parse it"
 141   `(if (stringp ,obj)
 142       (parse-integer ,obj)
 143     ,obj))
 144
 145 ;; Lists
 146
 147 (defun mklist (obj)
 148   "Make into list if atom"
 149   (if (listp obj) obj (list obj)))
 150
 151 (defun filter (fn lst)
 152   "Filter a list by function, eliminate elements where fn returns nil"
 153   (let ((acc nil))
 154     (dolist (x lst)
 155       (let ((val (funcall fn x)))
 156         (if val (push val acc))))
 157     (nreverse acc)))
 158
 159
 160 ;; Functions
 161
 162 (defun memo-proc (fn)
 163   "Memoize results of call to fn, returns a closure with hash-table"
 164   (let ((cache (make-hash-table :test #'equal)))
 165     #'(lambda (&rest args)
 166         (multiple-value-bind (val foundp) (gethash args cache)
 167           (if foundp
 168               val
 169               (setf (gethash args cache)
 170                     (apply fn args)))))))
 171
 172 (defun memoize (fn-name)
 173   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
 174
 175 (defmacro defun-memo (fn args &body body)
 176   "Define a memoized function"
 177   `(memoize (defun ,fn ,args . ,body)))
 178
 179 (defmacro _f (op place &rest args)
 180   (multiple-value-bind (vars forms var set access)
 181                        (get-setf-expansion place)
 182     `(let* (,@(mapcar #'list vars forms)
 183             (,(car var) (,op ,access ,@args)))
 184        ,set)))
 185
 186 (defun compose (&rest fns)
 187   (if fns
 188       (let ((fn1 (car (last fns)))
 189             (fns (butlast fns)))
 190         #'(lambda (&rest args)
 191             (reduce #'funcall fns
 192                     :from-end t
 193                     :initial-value (apply fn1 args))))
 194       #'identity))
 195
 196 ;;; Loop macros
 197
 198 (defmacro until (test &body body)
 199   `(do ()
 200        (,test)
 201      ,@body))
 202
 203 (defmacro while (test &body body)
 204   `(do ()
 205        ((not ,test))
 206      ,@body))
 207
 208 (defmacro for ((var start stop) &body body)
 209   (let ((gstop (gensym)))
 210     `(do ((,var ,start (1+ ,var))
 211           (,gstop ,stop))
 212          ((> ,var ,gstop))
 213        ,@body)))
 214
 215 (defmacro with-each-stream-line ((var stream) &body body)
 216   (let ((eof (gensym))
 217         (eof-value (gensym))
 218         (strm (gensym)))
 219     `(let ((,strm ,stream)
 220            (,eof ',eof-value))
 221       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 222           ((eql ,var ,eof))
 223         ,@body))))
 224
 225 (defmacro with-each-file-line ((var file) &body body)
 226   (let ((stream (gensym)))
 227     `(with-open-file (,stream ,file :direction :input)
 228       (with-each-stream-line (,var ,stream)
 229         ,@body))))
 230
 231
 232 ;;; Keyword functions
 233
 234 (defun remove-keyword (key arglist)
 235   (loop for sublist = arglist then rest until (null sublist)
 236         for (elt arg . rest) = sublist
 237         unless (eq key elt) append (list elt arg)))
 238
 239 (defun remove-keywords (key-names args)
 240   (loop for ( name val ) on args by #'cddr
 241         unless (member (symbol-name name) key-names
 242                        :key #'symbol-name :test 'equal)
 243         append (list name val)))
 244
 245 (defmacro in (obj &rest choices)
 246   (let ((insym (gensym)))
 247     `(let ((,insym ,obj))
 248        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 249                      choices)))))
 250
 251 (defmacro mean (&rest args)
 252   `(/ (+ ,@args) ,(length args)))
 253
 254 (defmacro with-gensyms (syms &body body)
 255   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 256           syms)
 257      ,@body))
 258
 259
 260 ;;; Mapping
 261
 262 (defun mapappend (fn list)
 263   (apply #'append (mapcar fn list)))
 264
 265
 266 (defun mapcar-append-string-nontailrec (func v)
 267   "Concatenate results of mapcar lambda calls"
 268   (aif (car v)
 269        (concatenate 'string (funcall func it)
 270                     (mapcar-append-string-nontailrec func (cdr v)))
 271        ""))
 272
 273
 274 (defun mapcar-append-string (func v &optional (accum ""))
 275   "Concatenate results of mapcar lambda calls"
 276   (aif (car v)
 277        (mapcar-append-string
 278         func
 279         (cdr v)
 280         (concatenate 'string accum (funcall func it)))
 281        accum))
 282
 283 (defun mapcar2-append-string-nontailrec (func la lb)
 284   "Concatenate results of mapcar lambda call's over two lists"
 285   (let ((a (car la))
 286         (b (car lb)))
 287     (if (and a b)
 288       (concatenate 'string (funcall func a b)
 289                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 290       "")))
 291
 292 (defun mapcar2-append-string (func la lb &optional (accum ""))
 293   "Concatenate results of mapcar lambda call's over two lists"
 294   (let ((a (car la))
 295         (b (car lb)))
 296     (if (and a b)
 297         (mapcar2-append-string
 298          func
 299          (cdr la)
 300          (cdr lb)
 301          (concatenate 'string accum (funcall func a b)))
 302       accum)))
 303
 304
 305 ;;; Output
 306
 307 (defun indent-spaces (n &optional (stream *standard-output*))
 308   "Indent n*2 spaces to output stream"
 309   (when (numberp n)
 310     (let ((fmt (format nil "~~~DT" (+ n n))))
 311       (format stream fmt))))
 312
 313 (defun print-list (l &optional (output *standard-output*))
 314   "Print a list to a stream"
 315   (if (consp l)
 316     (progn
 317       (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
 318       t)
 319     nil))
 320
 321 (defun print-rows (rows &optional (ostrm *standard-output*))
 322   "Print a list of list rows to a stream"
 323   (dolist (r rows)
 324     (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
 325     (terpri ostrm)))
 326
 327
 328 ;;; Symbol functions
 329
 330 (defmacro concat-symbol (&rest args)
 331   `(intern (concatenate 'string ,@args)))
 332
 333 (defmacro concat-symbol-pkg (pkg &rest args)
 334   `(intern (concatenate 'string ,@args) ,pkg))
 335
 336
 337 ;;; IO
 338
 339
 340 (defstruct buf
 341   vec (start -1) (used -1) (new -1) (end -1))
 342
 343 (defun bref (buf n)
 344   (svref (buf-vec buf)
 345          (mod n (length (buf-vec buf)))))
 346
 347 (defun (setf bref) (val buf n)
 348   (setf (svref (buf-vec buf)
 349                (mod n (length (buf-vec buf))))
 350         val))
 351
 352 (defun new-buf (len)
 353   (make-buf :vec (make-array len)))
 354
 355 (defun buf-insert (x b)
 356   (setf (bref b (incf (buf-end b))) x))
 357
 358 (defun buf-pop (b)
 359   (prog1
 360     (bref b (incf (buf-start b)))
 361     (setf (buf-used b) (buf-start b)
 362           (buf-new  b) (buf-end   b))))
 363
 364 (defun buf-next (b)
 365   (when (< (buf-used b) (buf-new b))
 366     (bref b (incf (buf-used b)))))
 367
 368 (defun buf-reset (b)
 369   (setf (buf-used b) (buf-start b)
 370         (buf-new  b) (buf-end   b)))
 371
 372 (defun buf-clear (b)
 373   (setf (buf-start b) -1 (buf-used  b) -1
 374         (buf-new   b) -1 (buf-end   b) -1))
 375
 376 (defun buf-flush (b str)
 377   (do ((i (1+ (buf-used b)) (1+ i)))
 378       ((> i (buf-end b)))
 379     (princ (bref b i) str)))
 380
 381
 382 (defun file-subst (old new file1 file2)
 383   (with-open-file (in file1 :direction :input)
 384     (with-open-file (out file2 :direction :output
 385                          :if-exists :supersede)
 386       (stream-subst old new in out))))
 387
 388 (defun stream-subst (old new in out)
 389   (declare (string old new))
 390   (let* ((pos 0)
 391          (len (length old))
 392          (buf (new-buf len))
 393          (from-buf nil))
 394     (declare (fixnum pos len))
 395     (do ((c (read-char in nil :eof)
 396             (or (setf from-buf (buf-next buf))
 397                 (read-char in nil :eof))))
 398         ((eql c :eof))
 399       (declare (character c))
 400       (cond ((char= c (char old pos))
 401              (incf pos)
 402              (cond ((= pos len)            ; 3
 403                     (princ new out)
 404                     (setf pos 0)
 405                     (buf-clear buf))
 406                    ((not from-buf)         ; 2
 407                     (buf-insert c buf))))
 408             ((zerop pos)                   ; 1
 409              (princ c out)
 410              (when from-buf
 411                (buf-pop buf)
 412                (buf-reset buf)))
 413             (t                             ; 4
 414              (unless from-buf
 415                (buf-insert c buf))
 416              (princ (buf-pop buf) out)
 417              (buf-reset buf)
 418              (setf pos 0))))
 419     (buf-flush buf out)))
 420
 421
 422 ;;; Tree Functions
 423
 424 (defun remove-tree-if (pred tree)
 425   "Strip from tree of atoms that satistify predicate"
 426   (if (atom tree)
 427       (unless (funcall pred tree)
 428         tree)
 429     (let ((car-strip (remove-tree-if pred (car tree)))
 430           (cdr-strip (remove-tree-if pred (cdr tree))))
 431       (cond
 432        ((and car-strip (atom (cadr tree)) (null cdr-strip))
 433         (list car-strip))
 434        ((and car-strip cdr-strip)
 435         (cons car-strip cdr-strip))
 436        (car-strip
 437         car-strip)
 438        (cdr-strip
 439         cdr-strip)))))
 440
 441 (defun find-tree (sym tree)
 442   "Finds an atom as a car in tree and returns cdr tree at that positions"
 443   (if (or (null tree) (atom tree))
 444       nil
 445     (if (eql sym (car tree))
 446         (cdr tree)
 447       (aif (find-tree sym (car tree))
 448           it
 449         (aif (find-tree sym (cdr tree))
 450             it
 451           nil)))))
 452
 453 ;;; Files
 454
 455 (defun print-file-contents (file &optional (strm *standard-output*))
 456   "Opens a reads a file. Returns the contents as a single string"
 457   (when (probe-file file)
 458     (with-open-file (in file :direction :input)
 459       (let ((eof (gensym)))
 460         (do ((line (read-line in nil eof)
 461                    (read-line in nil eof)))
 462             ((eq line eof))
 463           (format strm "~A~%" line))))))
 464
 465 (defun read-file-to-string (file)
 466   "Opens a reads a file. Returns the contents as a single string"
 467   (with-output-to-string (out)
 468     (with-open-file (in file :direction :input)
 469       (let ((eof (gensym)))
 470         (do ((line (read-line in nil eof)
 471                    (read-line in nil eof)))
 472             ((eq line eof))
 473           (format out "~A~%" line))))))
 474
 475 (defun read-file-to-strings (file)
 476   "Opens a reads a file. Returns the contents as a list of strings"
 477   (let ((lines '()))
 478     (with-open-file (in file :direction :input)
 479       (let ((eof (gensym)))
 480         (do ((line (read-line in nil eof)
 481                    (read-line in nil eof)))
 482             ((eq line eof))
 483           (push line lines)))
 484       (nreverse lines))))
 485
 486
 487 ;;; Formatting functions
 488
 489 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
 490   (multiple-value-bind (sec min hr dy mn yr wkday)
 491     (decode-universal-time
 492      (encode-universal-time s m hour day month year))
 493     (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
 494                    "Friday" "Saturday" "Sunday")
 495                  wkday)
 496             (elt '("January" "February" "March" "April" "May" "June"
 497                    "July" "August" "September" "October" "November"
 498                    "December")
 499                  (1- mn))
 500             (format nil "~A" dy) (format nil "~A" yr)
 501             (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
 502
 503
 504 (defun date-string (ut)
 505   (if (typep ut 'integer)
 506       (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
 507           (decode-universal-time ut)
 508         (declare (ignore daylight-p zone))
 509         (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"
 510                 dow
 511                 day
 512                 (1- mon)
 513                 year
 514                 hr min sec))))
 515