src/glisp/util.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GLISP; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: Some common utilities for the Closure browser
   4 ;;;   Created: 1997-12-27
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1997-1999 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 ;; Changes
  30 ;;
  31 ;;  When        Who     What
  32 ;; ----------------------------------------------------------------------------
  33 ;;  1999-08-24  GB      = fixed MULTIPLE-VALUE-OR it now takes any number of
  34 ;;                        subforms
  35 ;;
  36
  37 (in-package :GLISP)
  38
  39 (defun neq (x y) (not (eq x y)))
  40
  41 (define-compiler-macro neq (x y)
  42   `(not (eq ,x ,y)))
  43
  44 (defmacro defsubst (name args &body body)
  45   `(runes:definline ,name ,args ,@body))
  46
  47 ;;; --------------------------------------------------------------------------------
  48 ;;;  Meta functions
  49
  50 (defun curry (fun &rest args)
  51   #'(lambda (&rest more)
  52       (apply fun (append args more))))
  53
  54 (defun rcurry (fun &rest args)
  55   #'(lambda (&rest more)
  56       (apply fun (append more args))))
  57
  58 (defun compose (f g)
  59   #'(lambda (&rest args)
  60       (funcall f (apply g args))))
  61
  62 (defun always (value)
  63   #'(lambda (&rest args)
  64       (declare (ignore args))
  65       value))
  66
  67 (defun true (&rest x)
  68   (declare (ignore x))
  69   t)
  70
  71 (defun false (&rest x)
  72   (declare (ignore x))
  73   nil)
  74
  75 ;;; --------------------------------------------------------------------------------
  76 ;;;  Promises
  77
  78 (defstruct (promise (:print-function print-promise))
  79   forced? value fun)
  80
  81 (defun print-promise (self sink depth)
  82   (declare (ignore depth))
  83   (if (promise-forced? self)
  84       (format sink "#<~S ~S ~S>" 'promise :forced (promise-value self))
  85     (format sink "#<~S ~S>" 'promise :lazy)))
  86
  87 (defmacro promise (form)
  88   `(make-promise :forced? nil :fun #'(lambda () ,form)))
  89
  90 (defun force (x)
  91   (if (promise-forced? x)
  92       (promise-value x)
  93     (setf (promise-forced? x) t
  94           (promise-value x) (funcall (promise-fun x)))))
  95
  96 ;;; --------------------------------------------------------------------------------
  97 ;;;  Some additional <op>f macros
  98
  99 (define-modify-macro maxf (&rest nums) max)
 100 (define-modify-macro minf (&rest nums) min)
 101 (define-modify-macro nconcf (&rest args) nconc)
 102
 103 ;; Man sollte mal ein generelles <op>f macro definieren, in etwa so
 104 ;; (funcallf #'nconc x 10)
 105
 106 ;;; Modifizierte Version von max / min.
 107
 108 (defun max* (&rest nums)
 109   (reduce (lambda (x y)
 110             (cond ((null x) y)
 111                   ((null y) x)
 112                   (t (max x y))))
 113           nums :initial-value nil))
 114
 115 (defun min* (&rest nums)
 116   (reduce (lambda (x y)
 117             (cond ((null x) y)
 118                   ((null y) x)
 119                   (t (min x y))))
 120           nums :initial-value nil))
 121
 122 ;;; --------------------------------------------------------------------------------
 123 ;;;  Debuging aids
 124
 125 (defmacro show (&rest exprs)
 126   `(format T "~&** [~S]~{~#[~:; ~] ~A = ~S~}." ',(current-function-name)
 127            (list ,@(mapcan (lambda (x)
 128                              (list (let ((*print-case* :downcase))
 129                                      (prin1-to-string x))
 130                                    x))
 131                            exprs))))
 132
 133 #+ALLEGRO
 134 (defun current-function-name ()
 135   (car COMPILER::.FUNCTIONS-DEFINED.))
 136
 137 #-ALLEGRO
 138 (defun current-function-name ()
 139   'ANONYMOUS)
 140
 141 ;;; --------------------------------------------------------------------------------
 142 ;;;  Multiple values
 143
 144 (defmacro multiple-value-or (&rest xs)
 145   (cond ((null xs)
 146          nil)
 147         ((null (cdr xs))
 148          (car xs))
 149         (t
 150          (let ((g (gensym)))
 151            `(LET ((,g (MULTIPLE-VALUE-LIST ,(car xs))))
 152                  (IF (CAR ,g)
 153                      (VALUES-LIST ,g)
 154                      (MULTIPLE-VALUE-OR ,@(cdr xs))))))))
 155
 156 (defun multiple-value-some (predicate &rest sequences)
 157   (values-list
 158    (apply #'some (lambda (&rest args)
 159                    (let ((res (multiple-value-list (apply predicate args))))
 160                      (if (car res)
 161                          res
 162                        nil)))
 163           sequences)))
 164
 165 ;;; --------------------------------------------------------------------------------
 166 ;;;  while and until
 167
 168 (defmacro while (test &body body)
 169   `(until (not ,test) ,@body))
 170
 171 (defmacro until (test &body body)
 172   `(do () (,test) ,@body))
 173
 174 ;;; --------------------------------------------------------------------------------
 175 ;;;  Sequences
 176
 177 (defun split-by-if (predicate seq &key (start 0) (nuke-empty-p nil))
 178   (let ((p0 (position-if predicate seq :start start)))
 179     (if p0
 180         (if (and nuke-empty-p (= start p0))
 181             (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p)
 182           (cons (subseq seq start p0)
 183                 (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p)))
 184       (if (and nuke-empty-p (= start (length seq)))
 185           nil
 186         (list (subseq seq start))))))
 187
 188 (defun split-by (item &rest args)
 189   (apply #'split-by-if (curry #'eql item) args))
 190
 191 (defun split-by-member (items &rest args)
 192   (apply #'split-by-if (rcurry #'member items) args))
 193
 194 ;;; --------------------------------------------------------------------------------
 195 ;;;  Strings
 196
 197 (defun white-space-p (ch)
 198   ;;(declare #.cl-user:+optimize-very-fast-trusted+)
 199   (or (eq ch #\Return)
 200       (eq ch #\Newline)
 201       (eq ch #\Space)
 202       (eq ch #\Tab)
 203       (eq ch #\Page)))
 204
 205 (define-compiler-macro white-space-p (ch)
 206   `(member ,ch '(#\Return #\Newline #\Space #\Tab #\Page)) )
 207
 208 (defun sanify-string (string &optional (begin? t) (end? t)
 209                                        (start 0))
 210   (let ((i (position-if #'white-space-p string :start start)))
 211     (cond (i
 212            (let ((j (position-if-not #'white-space-p string :start i)))
 213              (if j
 214                  (concatenate 'string (subseq string start i)
 215                               (if (and (= i start) begin?) "" " ")
 216                               (sanify-string string nil end? j))
 217                (concatenate 'string (subseq string start i)
 218                             (if (not end?) " " "")))))
 219           (t (subseq string start)))))
 220
 221 (defun sanify-rod (string &optional (begin? t) (end? t) (start 0))
 222   (let ((i (position-if #'runes:white-space-rune-p string :start start)))
 223     (cond (i
 224            (let ((j (position-if-not #'runes:white-space-rune-p
 225                                      string
 226                                      :start i)))
 227              (if j
 228                  (concatenate 'runes:rod (subseq string start i)
 229                               (if (and (= i start) begin?) '#() '#(32))
 230                               (sanify-rod string nil end? j))
 231                (concatenate 'runes:rod (subseq string start i)
 232                             (if (not end?) '#(32) '#())))))
 233           (t (subseq string start)))))
 234
 235 (defun split-string (bag string)
 236   (setq string (string-trim bag string))
 237   (cond ((= (length string) 0) nil)
 238         (t
 239          (let ((p (position bag string :test #'(lambda (x y) (member y x)))))
 240            (if p
 241                (cons (subseq string 0 p) (split-string bag (subseq string p)))
 242              (list string))) )))
 243
 244 (defun string-begin-equal (a b)
 245   "Returns non-NIL if the beginning of 'a' matches 'b'"
 246   (and (>= (length a) (length b))
 247        (string-equal a b :end1 (length b))) )
 248
 249 (defun string-begin= (a b)
 250   "Returns non-NIL if the beginning of 'a' matches 'b'"
 251   (and (>= (length a) (length b))
 252        (string= a b :end1 (length b))) )
 253
 254
 255 ;;; ------------------------------------------------------------------------------------------
 256 ;;;  Futures
 257 ;;;
 258
 259 #||
 260 (defstruct (future (:print-function print-future))
 261   (read-lock (mp/make-lock))
 262   (guess-lock (mp/make-lock))
 263   value)
 264
 265 (defun print-future (self sink depth)
 266   (if (future-guess-lock self)
 267       (format sink "#<~S unpredicted>" (type-of self))
 268     (if (and *print-level* (>= depth *print-level*))
 269         (format sink "#<~S predicted as ...>" (type-of self))
 270       (format sink "#<~S predicted as ~S>" (type-of self) (future-value self)))))
 271
 272 (defun future ()
 273   (let ((res (make-future)))
 274     (mp/seize-lock (future-guess-lock res))
 275     res))
 276
 277 (defun guess (future)
 278   (mp/with-lock ((future-read-lock future))
 279     (let ((lock (future-guess-lock future)))
 280       (when lock
 281         (mp/seize-lock lock))
 282       (future-value future))))
 283
 284 (defun predict (future value)
 285   (setf (future-value future) value)
 286   (let ((lock (future-guess-lock future)))
 287     (setf (future-guess-lock future) nil)
 288     (mp/release-lock lock))
 289   value)
 290
 291 ;;; Future lists
 292
 293 (defun fcar (x) (car (guess x)))
 294 (defun fcdr (x) (cdr (guess x)))
 295 (defun fnull (x) (null (guess x)))
 296 (defun fendp (x) (endp (guess x)))
 297
 298 (defmacro doflist ((var list &optional res) &body body)
 299   (let ((q (make-symbol "Q")))
 300     `(do ((,q ,list (fcdr ,q)))
 301          ((fendp ,q) ,res)
 302        (let ((,var (fcar ,q)))
 303          ,@body))))
 304
 305 (defun mapfcar (fun flist)
 306   (cond ((fendp flist) nil)
 307         ((cons (funcall fun (fcar flist)) (mapfcar fun (fcdr flist))))))
 308
 309 ||#
 310
 311 ;; Example:
 312
 313 ;;  (setq f (future))
 314
 315 ;; Thread 1:
 316 ;;  (doflist (k f) (print k))
 317
 318 ;; Thread 2:
 319 ;;  (setq f (cdr (predict f (cons 'foo (future)))))
 320 ;;  (setq f (cdr (predict f (cons 'bar (future)))))
 321 ;;  (predict f nil)
 322 ;;
 323
 324 ;;;; -----------------------------------------------------------------------------------------
 325 ;;;;  Homebrew stream classes
 326 ;;;;
 327
 328 ;; I am really tired of standard Common Lisp streams and thier incompatible
 329 implementations.
 330
 331 ;; A gstream is an objects with obeys to the following protocol:
 332
 333 ;; g/read-byte stream &optional (eof-error-p t) eof-value
 334 ;; g/unread-byte byte stream
 335 ;; g/read-char stream &optional (eof-error-p t) eof-value
 336 ;; g/unread-char char stream
 337 ;; g/write-char char stream
 338 ;; g/write-byte byte stream
 339 ;; g/finish-output stream
 340 ;; g/close stream &key abort
 341
 342 ;; Additionally the follwing generic functions are implemented based
 343 ;; on the above protocol and may be reimplemented for any custom
 344 ;; stream class for performance.
 345
 346 ;; g/write-string string stream &key start end
 347 ;; g/read-line stream &optional (eof-error-p t) eof-value
 348 ;; g/read-line* stream &optional (eof-error-p t) eof-value
 349 ;; g/read-byte-sequence sequence stream &key start end
 350 ;; g/read-char-sequence sequence stream &key start end
 351 ;; g/write-byte-sequence sequence stream &key start end
 352 ;; g/write-char-sequence sequence stream &key start end
 353
 354
 355 ;; The following classes exists
 356
 357 ;; gstream
 358 ;; use-char-for-byte-stream-flavour
 359 ;; use-byte-for-char-stream-flavour
 360 ;; cl-stream
 361 ;; cl-byte-stream
 362 ;; cl-char-stream
 363
 364 (defclass gstream () ())
 365
 366 ;;; use-char-for-byte-stream-flavour
 367
 368 (defclass use-char-for-byte-stream-flavour () ())
 369
 370 (defmethod g/read-byte ((self use-char-for-byte-stream-flavour) &optional (eof-error-p t) eof-value)
 371   (let ((r (g/read-char self eof-error-p :eof)))
 372     (if (eq r :eof)
 373         eof-value
 374       (char-code r))))
 375
 376 (defmethod g/unread-byte (byte (self use-char-for-byte-stream-flavour))
 377   (g/unread-char (or (and #+CMU (<= byte char-code-limit) (code-char byte))
 378                      (error "Cannot stuff ~D. into a character." byte))
 379                  self))
 380
 381 (defmethod g/write-byte (byte (self use-char-for-byte-stream-flavour))
 382   (g/write-char (or (and #+CMU (<= byte char-code-limit) (code-char byte))
 383                     (error "Cannot stuff ~D. into a character." byte))
 384                 self))
 385
 386 ;;; use-byte-for-char-stream-flavour
 387
 388 (defclass use-byte-for-char-stream-flavour () ())
 389
 390 (defmethod g/read-char ((self use-byte-for-char-stream-flavour) &optional (eof-error-p t) eof-value)
 391   (let ((byte (g/read-byte self eof-error-p :eof)))
 392     (if (eq byte :eof)
 393         eof-value
 394       (let ((res (and #+CMU (<= byte char-code-limit) (code-char byte))))
 395         (or res
 396             (error "The byte ~D. could not been represented as character in your LISP implementation." byte))))))
 397
 398 (defmethod g/unread-char (char (self use-byte-for-char-stream-flavour))
 399   (g/unread-byte (char-code char) self))
 400
 401 (defmethod g/write-char (char (self use-byte-for-char-stream-flavour))
 402   (g/write-byte (char-code char) self))
 403
 404 ;;; ------------------------------------------------------------
 405 ;;; Streams made up out of Common Lisp streams
 406
 407 ;;; cl-stream
 408
 409 (defclass cl-stream (gstream)
 410   ((cl-stream :initarg :cl-stream)))
 411
 412 (defmethod g/finish-output ((self cl-stream))
 413   (with-slots (cl-stream) self
 414     (finish-output cl-stream)))
 415
 416 (defmethod g/close ((self cl-stream) &key abort)
 417   (with-slots (cl-stream) self
 418     (close cl-stream :abort abort)))
 419
 420 ;;; cl-byte-stream
 421
 422 (defclass cl-byte-stream (use-byte-for-char-stream-flavour cl-stream)
 423   ((lookahead :initform nil)))
 424
 425 (defmethod g/read-byte ((self cl-byte-stream) &optional (eof-error-p t) eof-value)
 426   (with-slots (cl-stream lookahead) self
 427     (if lookahead
 428         (prog1 lookahead
 429           (setf lookahead nil))
 430       (read-byte cl-stream eof-error-p eof-value))))
 431
 432 (defmethod g/unread-byte (byte (self cl-byte-stream))
 433   (with-slots (cl-stream lookahead) self
 434     (if lookahead
 435         (error "You cannot unread twice.")
 436       (setf lookahead byte))))
 437
 438 (defmethod g/write-byte (byte (self cl-byte-stream))
 439   (with-slots (cl-stream) self
 440     (write-byte byte cl-stream)))
 441
 442 (defmethod g/read-byte-sequence (sequence (input cl-byte-stream) &key (start 0) (end (length sequence)))
 443   (with-slots (cl-stream) input
 444     (read-byte-sequence sequence cl-stream :start start :end end)))
 445
 446 (defmethod g/write-byte-sequence (sequence (sink cl-byte-stream) &key (start 0) (end (length sequence)))
 447   (with-slots (cl-stream) sink
 448     (cl:write-sequence sequence cl-stream :start start :end end)))
 449
 450 ;;; cl-char-stream
 451
 452 (defclass cl-char-stream (use-char-for-byte-stream-flavour cl-stream)
 453   ())
 454
 455 (defmethod g/read-char ((self cl-char-stream) &optional (eof-error-p t) eof-value)
 456   (with-slots (cl-stream) self
 457     (read-char cl-stream eof-error-p eof-value)))
 458
 459 (defmethod g/unread-char (char (self cl-char-stream))
 460   (with-slots (cl-stream) self
 461     (unread-char char cl-stream)))
 462
 463 (defmethod g/write-char (char (self cl-char-stream))
 464   (with-slots (cl-stream) self
 465     (write-char char cl-stream)))
 466
 467 ;;; ------------------------------------------------------------
 468 ;;; General or fall back stream methods
 469
 470 (defmethod g/write-string (string (stream t) &key (start 0) (end (length string)))
 471   (do ((i start (+ i 1)))
 472       ((>= i end))
 473     (g/write-char (char string i) stream)))
 474
 475 (defmethod g/read-line ((stream t) &optional (eof-error-p t) eof-value)
 476   (let ((res nil))
 477     (do ((c (g/read-char stream eof-error-p :eof)
 478             (g/read-char stream nil :eof)))
 479         ((or (eq c :eof) (char= c #\newline))
 480          (cond ((eq c :eof)
 481                 (values (if (null res) eof-value (coerce (nreverse res) 'string))
 482                         t))
 483                (t
 484                 (values (coerce (nreverse res) 'string)
 485                         nil))))
 486       (push c res))))
 487
 488 (defmethod g/read-line* ((stream t) &optional (eof-error-p t) eof-value)
 489   ;; Like read-line, but accepts CRNL, NL, CR as line termination
 490   (let ((res nil))
 491     (do ((c (g/read-char stream eof-error-p :eof)
 492             (g/read-char stream nil :eof)))
 493         ((or (eq c :eof) (char= c #\newline) (char= c #\return))
 494          (cond ((eq c :eof)
 495                 (values (if (null res) eof-value (coerce (nreverse res) 'string))
 496                         t))
 497                (t
 498                 (when (char= c #\return)
 499                   (let ((d (g/read-char stream nil :eof)))
 500                     (unless (or (eq d :eof) (char= d #\newline))
 501                       (g/unread-char d stream))))
 502                 (values (coerce (nreverse res) 'string)
 503                         nil))))
 504       (push c res))))
 505
 506 (defmethod g/read-byte-sequence (sequence (input t) &key (start 0) (end (length sequence)))
 507   (let ((i start) c)
 508     (loop
 509       (when (>= i end)
 510         (return i))
 511       (setf c (g/read-byte input nil :eof))
 512       (when (eq c :eof)
 513         (return i))
 514       (setf (elt sequence i) c)
 515       (incf i))))
 516
 517 (defmethod g/read-char-sequence (sequence (input t) &key (start 0) (end (length sequence)))
 518   (let ((i start) c)
 519     (loop
 520       (when (>= i end)
 521         (return i))
 522       (setf c (g/read-char input nil :eof))
 523       (when (eq c :eof)
 524         (return i))
 525       (setf (elt sequence i) c)
 526       (incf i))))
 527
 528 (defmethod g/write-byte-sequence (sequence (sink t) &key (start 0) (end (length sequence)))
 529   (do ((i start (+ i 1)))
 530       ((>= i end) i)
 531     (g/write-byte (aref sequence i) sink)))
 532
 533 ;;; ----------------------------------------------------------------------------------------------------
 534 ;;;  Vector streams
 535 ;;;
 536
 537 ;; Output
 538
 539 (defclass vector-output-stream (use-byte-for-char-stream-flavour)
 540   ((buffer :initarg :buffer)))
 541
 542 (defun g/make-vector-output-stream (&key (initial-size 100))
 543   (make-instance 'vector-output-stream
 544     :buffer (make-array initial-size :element-type '(unsigned-byte 8)
 545                         :fill-pointer 0
 546                         :adjustable t)))
 547
 548 (defmethod g/close ((self vector-output-stream) &key abort)
 549   (declare (ignorable self abort))
 550   nil)
 551
 552 (defmethod g/finish-output ((self vector-output-stream))
 553   nil)
 554
 555 (defmethod g/write-byte (byte (self vector-output-stream))
 556   (with-slots (buffer) self
 557     (vector-push-extend byte buffer 100)))
 558
 559 (defmethod g/write-byte-sequence (sequence (self vector-output-stream) &key (start 0) (end (length sequence)))
 560   (with-slots (buffer) self
 561     (adjust-array buffer (+ (length buffer) (- end start)))
 562     (replace buffer sequence :start1 (length buffer) :start2 start :end2 end)
 563     (setf (fill-pointer buffer) (+ (length buffer) (- end start)))
 564     end))
 565
 566 ;;; ----------------------------------------------------------------------------------------------------
 567 ;;;  Echo streams
 568
 569 #||
 570 (defclass echo-stream (use-byte-for-char-stream-flavour)
 571   ((echoed-to :initarg :echoed-to)))
 572
 573 (defun g/make-echo-stream (echoed-to)
 574   (make-instance 'echo-stream :echoed-to echoed-to))
 575 ||#
 576
 577 #||
 578
 579 Hmm unter PCL geht das nicht            ;-(
 580
 581 (defmethod g/read-byte ((stream stream) &optional (eof-error-p t) eof-value)
 582   (read-byte stream eof-error-p eof-value))
 583
 584 (defmethod g/read-char ((stream stream) &optional (eof-error-p t) eof-value)
 585   (read-char stream eof-error-p eof-value))
 586
 587 (defmethod g/unread-char (char (stream stream))
 588   (unread-char char stream))
 589
 590 (defmethod g/write-char (char (stream stream))
 591   (write-char char stream))
 592
 593 (defmethod g/write-byte (byte (stream stream))
 594   (write-byte byte stream))
 595
 596 (defmethod g/finish-output ((stream stream))
 597   (finish-output stream))
 598
 599 (defmethod g/close ((stream stream) &key abort)
 600   (close stream :abort abort))
 601
 602 ||#
 603
 604 ;;;; ----------------------------------------------------------------------------------------------------
 605
 606 #||
 607 (let ((null (make-symbol "NULL")))
 608
 609   (defstruct (future (:print-function print-future))
 610     (value null)
 611     (awaited-by nil))
 612
 613   (defun print-future (self sink depth)
 614     (if (eq (future-value self) null)
 615         (format sink "#<~S unpredicted>" (type-of self))
 616       (if (and *print-level* (>= depth *print-level*))
 617           (format sink "#<~S predicted as ...>" (type-of self))
 618         (format sink "#<~S predicted as ~S>" (type-of self) (future-value self)))))
 619
 620   (defun future ()
 621     (make-future))
 622
 623   (defun guess (future)
 624     (when (eq (future-value future) null)
 625       (setf (future-awaited-by future) (mp/current-process))
 626       (mp/process-wait "Awaiting future" (lambda () (not (eq (future-value future) null))))
 627       (setf (future-awaited-by future) nil))
 628     (future-value future))
 629
 630   (defun predict (future value)
 631     (setf (future-value future) value)
 632     (let ((aw (future-awaited-by future)))
 633       (when aw (mp/process-allow-schedule aw)))
 634     value)
 635   )
 636 ||#
 637
 638 (defun map-array (fun array &rest make-array-options)
 639   (let ((res (apply #'make-array (array-dimensions array) make-array-options)))
 640     (dotimes (i (array-total-size array))
 641       (setf (row-major-aref res i) (funcall fun (row-major-aref array i))))
 642     res))
 643
 644 ;;----------------------------------------------------------------------------------------------------
 645
 646 (defun g/peek-char (&optional (peek-type nil) (source *standard-input*)
 647                               (eof-error-p T) eof-value)
 648   (cond ((eq peek-type T)
 649          (do ((ch (g/read-char source eof-error-p '%the-eof-object%)
 650                   (g/read-char source eof-error-p '%the-eof-object%)))
 651              ((or (eq ch '%the-eof-object%)
 652                   (not (white-space-p ch)))
 653               (cond ((eq ch '%the-eof-object%) eof-value)
 654                     (t (g/unread-char ch source) ch)) )))
 655         ((eq peek-type NIL)
 656          (let ((ch (g/read-char source eof-error-p '%the-eof-object%)))
 657            (cond ((eq ch '%the-eof-object%) eof-value)
 658                  (t (g/unread-char ch source)
 659                     ch))))
 660         ((characterp peek-type)
 661          (do ((ch (g/read-char source eof-error-p '%the-eof-object%)
 662                   (g/read-char source eof-error-p '%the-eof-object%)))
 663              ((or (eq ch '%the-eof-object%) (eql ch peek-type))
 664               (cond ((eq ch '%the-eof-object%) eof-value)
 665                     (t (g/unread-char ch source) ch)) )) ) ))
 666
 667
 668
 669 (defun cl-byte-stream->gstream (stream)
 670   (make-instance 'cl-byte-stream :cl-stream stream))
 671
 672 (defun cl-char-stream->gstream (stream)
 673   (make-instance 'cl-char-stream :cl-stream stream))
 674
 675 ;;; ----------------------------------------------------------------------------------------------------
 676
 677 (defvar *all-temporary-files* nil
 678   "List of all temporary files.")
 679
 680 (defun find-temporary-file (&key (type nil))
 681   (let ((temp-dir "/tmp/*")             ;since Motif is only available on unix, we subtly assume a unix host.
 682         (stream nil))
 683     (labels ((invent-name ()
 684                (merge-pathnames (make-pathname
 685                                  :type type
 686                                  :name
 687                                  (let ((*print-base* 35))
 688                                    (format nil "ws_~S" (random (expt 36 7)))))
 689                                 temp-dir)))
 690       (unwind-protect
 691           (do ((name (invent-name) (invent-name)))
 692               ((setq stream (open name :direction :output :if-exists nil))
 693                (push name *all-temporary-files*)        ;remember this file
 694                name))
 695         (when stream
 696           (close stream)) ))))
 697
 698 (defun delete-temporary-file (filename)
 699   (setf *all-temporary-files* (delete filename *all-temporary-files*))
 700   (ignore-errors (delete-file filename)))
 701
 702 (defmacro with-temporary-file ((name-var &key type) &body body)
 703   (let ((name (gensym)))
 704     `(let* ((,name (find-temporary-file :type ,type))
 705             (,name-var ,name))
 706        (unwind-protect
 707            (progn ,@body)
 708          (when (open ,name :direction :probe)
 709            (delete-temporary-file ,name)))) ))
 710
 711 ;;;;
 712
 713 (defun set-equal (x y &rest options)
 714   (null (apply #'set-exclusive-or x y options)))
 715
 716 ;;;;
 717
 718 (defun maybe-parse-integer (string &key (radix 10))
 719   (cond ((not (stringp string)) nil)
 720         (t
 721          (let ((len (length string)))
 722            (cond ((= len 0) nil)
 723                  (t
 724                   (let ((start 0)
 725                         (vz +1)
 726                         (res 0))
 727                     (cond ((and (> len 1) (char= (char string 0) #\+))
 728                            (incf start))
 729                           ((and (> len 1) (char= (char string 0) #\-))
 730                            (setf vz -1)
 731                            (incf start)))
 732                     (do ((i start (+ i 1)))
 733                         ((= i len) (* vz res))
 734                       (let ((d (digit-char-p (char string i) radix)))
 735                         (if d
 736                             (setf res (+ (* radix res) d))
 737                           (return nil)))))))))))
 738
 739 ;;;
 740
 741 (defun nop (&rest ignore)
 742   (declare (ignore ignore))
 743   nil)
 744
 745 (defmacro with-structure-slots ((type &rest slots) obj &body body)
 746   ;; Something like 'with-slots' but for structures. Assumes that the structure
 747   ;; slot accessors have the default name. Note that the structure type must
 748   ;; been provided.
 749   (let ((obj-var (make-symbol "OBJ")))
 750     `(LET ((,obj-var ,obj))
 751        (SYMBOL-MACROLET ,(mapcar (lambda (slot)
 752                                    (list slot
 753                                          `(,(intern (concatenate 'string (symbol-name type) "-" (symbol-name slot))
 754                                                     (symbol-package type))
 755                                            ,obj-var)))
 756                                  slots)
 757          ,@body))))
 758
 759 ;;;; ----------------------------------------------------------------------------------------------------
 760
 761 ;; Wir helfen den Compiler mal etwas auf die Spruenge ...
 762 (defun compile-funcall (fn args)
 763   (cond ((eq fn '#'identity)
 764          (car args))
 765         ((eq fn '#'nop)
 766          `(progn ,args nil))
 767         ((and (consp fn) (eq (car fn) 'function))
 768          `(,(cadr fn) .,args))
 769         ((and (consp fn) (eq (car fn) 'lambda))
 770          `(,fn .,args))
 771         ((and (consp fn) (eq (car fn) 'curry))
 772          (compile-funcall (cadr fn) (append (cddr fn) args)))
 773         ((and (consp fn) (eq (car fn) 'rcurry))
 774          (compile-funcall (cadr fn) (append args (cddr fn))))
 775         (t
 776          (warn "Unable to inline funcall to ~S." fn)
 777          `(funcall ,fn .,args)) ))
 778
 779 (defmacro funcall* (fn &rest args)
 780   (compile-funcall fn args))
 781
 782 ;; Ich mag mapc viel lieber als dolist, nur viele Compiler optimieren
 783 ;; das nicht, deswegen das Macro hier. Einige Compiler haben auch kein
 784 ;; DEFINE-COMPILER-MACRO :-(
 785
 786 (defmacro mapc* (fn list)
 787   (let ((g (gensym)))
 788     `(dolist (,g ,list)
 789        ,(compile-funcall fn (list g)))))
 790
 791 ;; Das gleiche mit REDUCE und MAPCAR.
 792
 793 ;; REDUCE arbeitet sowohl fuer Vectoren als auch fuer Listen. Wir
 794 ;; haben allerdings leider keinen vernuenftigen Zugriff auf
 795 ;; Deklarationen; Man koennte mit TYPEP herangehen und hoffen, dass
 796 ;; der Compiler das optimiert, ich fuerchte aber dass das nicht
 797 ;; funktionieren wird. Und CLISP verwirft Deklarationen ja total. Also
 798 ;; zwei Versionen: LREDUCE* und VREDUCE*
 799
 800 (defmacro vreduce* (fun seq &rest rest &key (key '#'identity) from-end start end
 801                                             (initial-value nil initial-value?))
 802   (declare (ignore rest))
 803   (let (($start (make-symbol "start"))
 804         ($end (make-symbol "end"))
 805         ($i (make-symbol "i"))
 806         ($accu (make-symbol "accu"))
 807         ($seq (make-symbol "seq")))
 808     (cond (from-end
 809          (cond (initial-value?
 810                 `(LET* ((,$seq ,seq)
 811                         (,$start ,(or start 0))
 812                         (,$end ,(or end `(LENGTH ,$seq)))
 813                         (,$accu ,initial-value))
 814                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 815                    (DO ((,$i (- ,$end 1) (THE FIXNUM (- ,$i 1))))
 816                        ((< ,$i ,$start) ,$accu)
 817                      (DECLARE (TYPE FIXNUM ,$i))
 818                      (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)) )))
 819                (t
 820                 `(LET* ((,$seq ,seq)
 821                         (,$start ,(or start 0))
 822                         (,$end ,(or end `(LENGTH ,$seq))))
 823                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 824                    (COND ((= 0 (- ,$end ,$start))
 825                           (FUNCALL* ,fun))
 826                          (T
 827                           (LET ((,$accu (FUNCALL* ,key (AREF ,$seq (- ,$end 1)))))
 828                             (DO ((,$i (- ,$end 2) (THE FIXNUM (- ,$i 1))))
 829                                 ((< ,$i ,$start) ,$accu)
 830                               (DECLARE (TYPE FIXNUM ,$i))
 831                               (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)))))))) ))
 832         (t
 833          (cond (initial-value?
 834                 `(LET* ((,$seq ,seq)
 835                         (,$start ,(or start 0))
 836                         (,$end ,(or end `(LENGTH ,$seq)))
 837                         (,$accu ,initial-value))
 838                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 839                    (DO ((,$i ,$start (THE FIXNUM (+ ,$i 1))))
 840                        ((>= ,$i ,$end) ,$accu)
 841                      (DECLARE (TYPE FIXNUM ,$i))
 842                      (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i)))) )))
 843                (t
 844                 `(let* ((,$seq ,seq)
 845                         (,$start ,(or start 0))
 846                         (,$end ,(or end `(LENGTH ,$seq))))
 847                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 848                    (COND ((= 0 (- ,$end ,$start))
 849                           (FUNCALL* ,fun))
 850                          (T
 851                           (LET ((,$accu (FUNCALL* ,key (AREF ,$seq ,$start))))
 852                             (DO ((,$i (+ ,$start 1) (+ ,$i 1)))
 853                                 ((>= ,$i ,$end) ,$accu)
 854                               (DECLARE (TYPE FIXNUM ,$i))
 855                               (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i)))))))))))))))
 856
 857 (defmacro lreduce* (fun seq &rest rest &key (key '#'identity) from-end start end
 858                                             (initial-value nil initial-value?))
 859   (cond ((or start end from-end)
 860          `(reduce ,fun ,seq .,rest))
 861         (t
 862          (cond (initial-value?
 863                 (let (($accu (make-symbol "accu"))
 864                       ($k (make-symbol "k")))
 865                   `(LET* ((,$accu ,initial-value))
 866                      (DOLIST (,$k ,seq ,$accu)
 867                         (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k)))))))
 868                (t
 869                 (let (($accu (make-symbol "accu"))
 870                       ($seq (make-symbol "seq"))
 871                       ($k (make-symbol "k")))
 872                   `(LET* ((,$seq ,seq))
 873                          (IF (NULL ,$seq)
 874                              (FUNCALL* ,fun)
 875                              (LET ((,$accu (FUNCALL* ,key (CAR ,$seq))))
 876                                   (DOLIST (,$k (CDR ,$seq) ,$accu)
 877                                           (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k)))))))) ))) ))
 878
 879
 880 ;;; Wenn wir so weiter machen, koennen wir bald gleich unseren eigenen
 881 ;;; Compiler schreiben ;-)
 882
 883 #||
 884 (defmacro lreduce* (fun seq &rest x &key key &allow-other-keys)
 885   (let ((q (copy-list x)))
 886     (remf q :key)
 887     (cond (key
 888            `(reduce ,fun (map 'vector ,key ,seq) .,q))
 889           (t
 890            `(reduce ,fun ,seq .,q)))))
 891
 892 (defmacro vreduce* (fun seq &rest x &key key &allow-other-keys)
 893   (let ((q (copy-list x)))
 894     (remf q :key)
 895     (cond (key
 896            `(reduce ,fun (map 'vector ,key ,seq) .,q))
 897           (t
 898            `(reduce ,fun ,seq .,q)))))
 899
 900 ||#
 901
 902 ;; Stolen from Eclipse (http://elwoodcorp.com/eclipse/unique.htm
 903
 904 (defmacro with-unique-names ((&rest names) &body body)
 905   `(let (,@(mapcar (lambda (x) (list x `(gensym ',(concatenate 'string (symbol-name x) "-")))) names))
 906      .,body))
 907
 908
 909 (defun gstream-as-string (gstream &optional (buffer-size 4096))
 910   (let ((buffer (g/make-string buffer-size :adjustable t)))
 911     (do* ((i 0 j)
 912           (j (g/read-char-sequence buffer gstream :start 0 :end buffer-size)
 913              (g/read-char-sequence buffer gstream :start i :end (+ i buffer-size)) ))
 914         ((= j i) (subseq buffer 0 j))
 915       (adjust-array buffer (list (+ j buffer-size))) )))
 916
 917 ;;;; Generic hash tables
 918
 919 ;; TODO:
 920 ;; - automatic size adjustment
 921 ;; - sensible printer
 922 ;; - make-load-form?!
 923
 924 (defstruct g/hash-table
 925   hash-function                         ;hash function
 926   compare-function                      ;predicate to test for equality
 927   table                                 ;simple vector of chains
 928   size                                  ;size of hash table
 929   (nitems 0))                           ;number of items
 930
 931 (defun g/make-hash-table (&key (size 100) (hash-function #'sxhash) (compare-function #'eql))
 932   "Creates a generic hashtable;
 933    `size' is the default size of the table.
 934    `hash-function' (default #'sxhash) is a specific hash function
 935    `compare-function' (default #'eql) is a predicate to test for equality."
 936   (setf size (nearest-greater-prime size))
 937   (make-g/hash-table :hash-function hash-function
 938                      :compare-function compare-function
 939                      :table (make-array size :initial-element nil)
 940                      :size size
 941                      :nitems 0))
 942
 943 (defun g/hashget (hashtable key &optional (default nil))
 944   "Looks up the key `key' in the generic hash table `hashtable'.
 945    Returns three values:
 946    value     - value, which as associated with the key, or `default' is no value
 947                present.
 948    successp  - true, iff the key was found.
 949    key       - the original key in the hash table."
 950   ;; -> value ; successp ; key
 951   (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key)
 952                 (g/hash-table-size hashtable))))
 953     (let ((q (assoc key (aref (g/hash-table-table hashtable) j)
 954                     :test (g/hash-table-compare-function hashtable))))
 955       (if q
 956           (values (cdr q) t (car q))
 957         (values default nil)))))
 958
 959 (defun (setf g/hashget) (new-value hashtable key &optional (default nil))
 960   (declare (ignore default))
 961   (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key)
 962                 (g/hash-table-size hashtable))))
 963     (let ((q (assoc key (aref (g/hash-table-table hashtable) j)
 964                     :test (g/hash-table-compare-function hashtable))))
 965       (cond ((not (null q))
 966              (setf (cdr q) new-value))
 967             (t
 968              (push (cons key new-value)
 969                    (aref (g/hash-table-table hashtable) j))
 970              (incf (g/hash-table-nitems hashtable))))))
 971   new-value)
 972
 973 (defun resize-hash-table (hashtable new-size)
 974   "Adjust the size of a generic hash table. (the size is round to the next greater prime number)."
 975   (setf new-size (nearest-greater-prime new-size))
 976   (let ((new-table (make-array new-size :initial-element nil)))
 977     (dotimes (i (g/hash-table-size hashtable))
 978       (dolist (k (aref (g/hash-table-table hashtable) i))
 979         (push k (aref new-table
 980                       (mod (funcall (g/hash-table-hash-function hashtable) (car k))
 981                            new-size)))))
 982     (setf (g/hash-table-table hashtable) new-table
 983           (g/hash-table-size hashtable) new-size)
 984     hashtable))
 985
 986 (defun g/clrhash (hashtable)
 987   "Clears a generic hash table."
 988   (dotimes (i (g/hash-table-size hashtable))
 989     (setf (aref (g/hash-table-table hashtable) i) nil))
 990   (setf (g/hash-table-nitems hashtable) nil)
 991   hashtable)
 992
 993 ;; hash code utilities
 994
 995 (defconstant +fixnum-bits+
 996     (1- (integer-length most-positive-fixnum))
 997   "Pessimistic approximation of the number of bits of fixnums.")
 998
 999 (defconstant +fixnum-mask+
1000     (1- (expt 2 +fixnum-bits+))
1001   "Pessimistic approximation of the largest bit-mask, still being a fixnum.")
1002
1003 (defun stir-hash-codes (a b)
1004   "Stirs two hash codes together; always returns a fixnum.
1005    When applied sequenitally the first argument should be used as accumulator."
1006   ;; ich mach das mal wie Bruno
1007   (logand +fixnum-mask+
1008           (logxor (logior (logand +fixnum-mask+ (ash a 5))
1009                           (logand +fixnum-mask+ (ash a (- 5 +fixnum-bits+))))
1010                   b)))
1011
1012 (defun hash-sequence (sequence hash-function &optional (accu 0))
1013   "Applies the hash function `hash-function' to each element of `sequence' and
1014    stirs the resulting hash codes together using STIR-HASH-CODE starting from
1015    `accu'."
1016   (map nil (lambda (item)
1017              (setf accu (stir-hash-codes accu (funcall hash-function item))))
1018        sequence)
1019   accu)
1020
1021 ;; some specific hash functions
1022
1023 (defun hash/string-equal (string)
1024   "Hash function compatible with STRING-EQUAL."
1025   (hash-sequence string (lambda (char)
1026                           (sxhash (char-upcase char)))))
1027
1028 ;; some specific hash tables
1029
1030 (defun make-string-equal-hash-table (&rest options)
1031   "Constructs a new generic hash table using STRING-EQUAL as predicate."
1032   (apply #'g/make-hash-table
1033          :hash-function #'hash/string-equal
1034          :compare-function #'string-equal
1035          options))
1036
1037 ;; prime numbers
1038
1039 (defun primep (n)
1040   "Returns true, iff `n' is prime."
1041   (and (> n 2)
1042        (do ((i 2 (+ i 1)))
1043            ((> (* i i) n) t)
1044          (cond ((zerop (mod n i)) (return nil))))))
1045
1046 (defun nearest-greater-prime (n)
1047   "Returns the smallest prime number no less than `n'."
1048   (cond ((primep n) n)
1049         ((nearest-greater-prime (+ n 1)))))
1050
1051
1052 ;;;
1053
1054 (defun grind-documentation-string (string &optional (sink *standard-output*))
1055   ;; some people say:
1056   ;;   (defun foo ()
1057   ;;     "This function
1058   ;;   frobinates its two arguments.")
1059   ;; some say:
1060   ;;   (defun foo ()
1061   ;;     "This function
1062   ;;      frobinates its two arguments.")
1063   ;; instead.
1064   (let ((min-indention nil))
1065     ;; We sort this out by finding the minimum indent in all but the first line.
1066     (with-input-from-string (in string)
1067       (read-line in nil nil)            ;ignore first line
1068       (do ((x (read-line in nil nil) (read-line in nil nil)))
1069           ((null x))
1070         (let ((p (position-if-not (curry #'char= #\space) x)))
1071           (when p
1072             (setf min-indention (min* min-indention p))))))
1073     (setf min-indention (or min-indention 0))
1074     ;; Now we could dump the string
1075     (with-input-from-string (in string)
1076       ;; first line goes unindented
1077       (let ((x (read-line in nil nil)))
1078         (when x
1079           (fresh-line sink)
1080           (write-string x sink)))
1081       (do ((x (read-line in nil nil) (read-line in nil nil)))
1082           ((null x))
1083         (terpri sink)
1084         (when (< min-indention (length x))
1085           (write-string x sink :start min-indention)))))
1086   (values))
1087
1088 (defun ap (&rest strings)
1089   "A new apropos."
1090   (let ((res nil))
1091     (do-all-symbols (symbol)
1092       (unless (member symbol res)
1093         (when (every (lambda (string)
1094                        (search string (symbol-name symbol)))
1095                      strings)
1096           (push symbol res))))
1097     (dolist (k res)
1098       (print k)
1099       (when (fboundp k)
1100         (princ ", function"))
1101       (when (boundp k)
1102         (princ ", variable"))
1103       )))
1104