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