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 implementations.
 329
 330 ;; A gstream is an objects with obeys to the following protocol:
 331
 332 ;; g/read-byte stream &optional (eof-error-p t) eof-value
 333 ;; g/unread-byte byte stream
 334 ;; g/read-char stream &optional (eof-error-p t) eof-value
 335 ;; g/unread-char char stream
 336 ;; g/write-char char stream
 337 ;; g/write-byte byte stream
 338 ;; g/finish-output stream
 339 ;; g/close stream &key abort
 340
 341 ;; Additionally the follwing generic functions are implemented based
 342 ;; on the above protocol and may be reimplemented for any custom
 343 ;; stream class for performance.
 344
 345 ;; g/write-string string stream &key start end
 346 ;; g/read-line stream &optional (eof-error-p t) eof-value
 347 ;; g/read-line* stream &optional (eof-error-p t) eof-value
 348 ;; g/read-byte-sequence sequence stream &key start end
 349 ;; g/read-char-sequence sequence stream &key start end
 350 ;; g/write-byte-sequence sequence stream &key start end
 351 ;; g/write-char-sequence sequence stream &key start end
 352
 353
 354 ;; The following classes exists
 355
 356 ;; gstream
 357 ;; use-char-for-byte-stream-flavour
 358 ;; use-byte-for-char-stream-flavour
 359 ;; cl-stream
 360 ;; cl-byte-stream
 361 ;; cl-char-stream
 362
 363 (defclass gstream () ())
 364
 365 ;;; use-char-for-byte-stream-flavour
 366
 367 (defclass use-char-for-byte-stream-flavour () ())
 368
 369 (defmethod g/read-byte ((self use-char-for-byte-stream-flavour) &optional (eof-error-p t) eof-value)
 370   (let ((r (g/read-char self eof-error-p :eof)))
 371     (if (eq r :eof)
 372         eof-value
 373       (char-code r))))
 374
 375 (defmethod g/unread-byte (byte (self use-char-for-byte-stream-flavour))
 376   (g/unread-char (or (and #+CMU (<= byte char-code-limit) (code-char byte))
 377                      (error "Cannot stuff ~D. into a character." byte))
 378                  self))
 379
 380 (defmethod g/write-byte (byte (self use-char-for-byte-stream-flavour))
 381   (g/write-char (or (and #+CMU (<= byte char-code-limit) (code-char byte))
 382                     (error "Cannot stuff ~D. into a character." byte))
 383                 self))
 384
 385 ;;; use-byte-for-char-stream-flavour
 386
 387 (defclass use-byte-for-char-stream-flavour () ())
 388
 389 (defmethod g/read-char ((self use-byte-for-char-stream-flavour) &optional (eof-error-p t) eof-value)
 390   (let ((byte (g/read-byte self eof-error-p :eof)))
 391     (if (eq byte :eof)
 392         eof-value
 393       (let ((res (and #+CMU (<= byte char-code-limit) (code-char byte))))
 394         (or res
 395             (error "The byte ~D. could not been represented as character in your LISP implementation." byte))))))
 396
 397 (defmethod g/unread-char (char (self use-byte-for-char-stream-flavour))
 398   (g/unread-byte (char-code char) self))
 399
 400 (defmethod g/write-char (char (self use-byte-for-char-stream-flavour))
 401   (g/write-byte (char-code char) self))
 402
 403 ;;; ------------------------------------------------------------
 404 ;;; Streams made up out of Common Lisp streams
 405
 406 ;;; cl-stream
 407
 408 (defclass cl-stream (gstream)
 409   ((cl-stream :initarg :cl-stream)))
 410
 411 (defmethod g/finish-output ((self cl-stream))
 412   (with-slots (cl-stream) self
 413     (finish-output cl-stream)))
 414
 415 (defmethod g/close ((self cl-stream) &key abort)
 416   (with-slots (cl-stream) self
 417     (close cl-stream :abort abort)))
 418
 419 ;;; cl-byte-stream
 420
 421 (defclass cl-byte-stream (use-byte-for-char-stream-flavour cl-stream)
 422   ((lookahead :initform nil)))
 423
 424 (defmethod g/read-byte ((self cl-byte-stream) &optional (eof-error-p t) eof-value)
 425   (with-slots (cl-stream lookahead) self
 426     (if lookahead
 427         (prog1 lookahead
 428           (setf lookahead nil))
 429       (read-byte cl-stream eof-error-p eof-value))))
 430
 431 (defmethod g/unread-byte (byte (self cl-byte-stream))
 432   (with-slots (cl-stream lookahead) self
 433     (if lookahead
 434         (error "You cannot unread twice.")
 435       (setf lookahead byte))))
 436
 437 (defmethod g/write-byte (byte (self cl-byte-stream))
 438   (with-slots (cl-stream) self
 439     (write-byte byte cl-stream)))
 440
 441 (defmethod g/read-byte-sequence (sequence (input cl-byte-stream) &key (start 0) (end (length sequence)))
 442   (with-slots (cl-stream) input
 443     (read-byte-sequence sequence cl-stream :start start :end end)))
 444
 445 (defmethod g/write-byte-sequence (sequence (sink cl-byte-stream) &key (start 0) (end (length sequence)))
 446   (with-slots (cl-stream) sink
 447     (cl:write-sequence sequence cl-stream :start start :end end)))
 448
 449 ;;; cl-char-stream
 450
 451 (defclass cl-char-stream (use-char-for-byte-stream-flavour cl-stream)
 452   ())
 453
 454 (defmethod g/read-char ((self cl-char-stream) &optional (eof-error-p t) eof-value)
 455   (with-slots (cl-stream) self
 456     (read-char cl-stream eof-error-p eof-value)))
 457
 458 (defmethod g/unread-char (char (self cl-char-stream))
 459   (with-slots (cl-stream) self
 460     (unread-char char cl-stream)))
 461
 462 (defmethod g/write-char (char (self cl-char-stream))
 463   (with-slots (cl-stream) self
 464     (write-char char cl-stream)))
 465
 466 ;;; ------------------------------------------------------------
 467 ;;; General or fall back stream methods
 468
 469 (defmethod g/write-string (string (stream t) &key (start 0) (end (length string)))
 470   (do ((i start (+ i 1)))
 471       ((>= i end))
 472     (g/write-char (char string i) stream)))
 473
 474 (defmethod g/read-line ((stream t) &optional (eof-error-p t) eof-value)
 475   (let ((res nil))
 476     (do ((c (g/read-char stream eof-error-p :eof)
 477             (g/read-char stream nil :eof)))
 478         ((or (eq c :eof) (char= c #\newline))
 479          (cond ((eq c :eof)
 480                 (values (if (null res) eof-value (coerce (nreverse res) 'string))
 481                         t))
 482                (t
 483                 (values (coerce (nreverse res) 'string)
 484                         nil))))
 485       (push c res))))
 486
 487 (defmethod g/read-line* ((stream t) &optional (eof-error-p t) eof-value)
 488   ;; Like read-line, but accepts CRNL, NL, CR as line termination
 489   (let ((res nil))
 490     (do ((c (g/read-char stream eof-error-p :eof)
 491             (g/read-char stream nil :eof)))
 492         ((or (eq c :eof) (char= c #\newline) (char= c #\return))
 493          (cond ((eq c :eof)
 494                 (values (if (null res) eof-value (coerce (nreverse res) 'string))
 495                         t))
 496                (t
 497                 (when (char= c #\return)
 498                   (let ((d (g/read-char stream nil :eof)))
 499                     (unless (or (eq d :eof) (char= d #\newline))
 500                       (g/unread-char d stream))))
 501                 (values (coerce (nreverse res) 'string)
 502                         nil))))
 503       (push c res))))
 504
 505 (defmethod g/read-byte-sequence (sequence (input t) &key (start 0) (end (length sequence)))
 506   (let ((i start) c)
 507     (loop
 508       (when (>= i end)
 509         (return i))
 510       (setf c (g/read-byte input nil :eof))
 511       (when (eq c :eof)
 512         (return i))
 513       (setf (elt sequence i) c)
 514       (incf i))))
 515
 516 (defmethod g/read-char-sequence (sequence (input t) &key (start 0) (end (length sequence)))
 517   (let ((i start) c)
 518     (loop
 519       (when (>= i end)
 520         (return i))
 521       (setf c (g/read-char input nil :eof))
 522       (when (eq c :eof)
 523         (return i))
 524       (setf (elt sequence i) c)
 525       (incf i))))
 526
 527 (defmethod g/write-byte-sequence (sequence (sink t) &key (start 0) (end (length sequence)))
 528   (do ((i start (+ i 1)))
 529       ((>= i end) i)
 530     (g/write-byte (aref sequence i) sink)))
 531
 532 ;;; ----------------------------------------------------------------------------------------------------
 533 ;;;  Vector streams
 534 ;;;
 535
 536 ;; Output
 537
 538 (defclass vector-output-stream (use-byte-for-char-stream-flavour)
 539   ((buffer :initarg :buffer)))
 540
 541 (defun g/make-vector-output-stream (&key (initial-size 100))
 542   (make-instance 'vector-output-stream
 543     :buffer (make-array initial-size :element-type '(unsigned-byte 8)
 544                         :fill-pointer 0
 545                         :adjustable t)))
 546
 547 (defmethod g/close ((self vector-output-stream) &key abort)
 548   (declare (ignorable self abort))
 549   nil)
 550
 551 (defmethod g/finish-output ((self vector-output-stream))
 552   nil)
 553
 554 (defmethod g/write-byte (byte (self vector-output-stream))
 555   (with-slots (buffer) self
 556     (vector-push-extend byte buffer 100)))
 557
 558 (defmethod g/write-byte-sequence (sequence (self vector-output-stream) &key (start 0) (end (length sequence)))
 559   (with-slots (buffer) self
 560     (adjust-array buffer (+ (length buffer) (- end start)))
 561     (replace buffer sequence :start1 (length buffer) :start2 start :end2 end)
 562     (setf (fill-pointer buffer) (+ (length buffer) (- end start)))
 563     end))
 564
 565 ;;; ----------------------------------------------------------------------------------------------------
 566 ;;;  Echo streams
 567
 568 #||
 569 (defclass echo-stream (use-byte-for-char-stream-flavour)
 570   ((echoed-to :initarg :echoed-to)))
 571
 572 (defun g/make-echo-stream (echoed-to)
 573   (make-instance 'echo-stream :echoed-to echoed-to))
 574 ||#
 575
 576 #||
 577
 578 Hmm unter PCL geht das nicht            ;-(
 579
 580 (defmethod g/read-byte ((stream stream) &optional (eof-error-p t) eof-value)
 581   (read-byte stream eof-error-p eof-value))
 582
 583 (defmethod g/read-char ((stream stream) &optional (eof-error-p t) eof-value)
 584   (read-char stream eof-error-p eof-value))
 585
 586 (defmethod g/unread-char (char (stream stream))
 587   (unread-char char stream))
 588
 589 (defmethod g/write-char (char (stream stream))
 590   (write-char char stream))
 591
 592 (defmethod g/write-byte (byte (stream stream))
 593   (write-byte byte stream))
 594
 595 (defmethod g/finish-output ((stream stream))
 596   (finish-output stream))
 597
 598 (defmethod g/close ((stream stream) &key abort)
 599   (close stream :abort abort))
 600
 601 ||#
 602
 603 ;;;; ----------------------------------------------------------------------------------------------------
 604
 605 #||
 606 (let ((null (make-symbol "NULL")))
 607
 608   (defstruct (future (:print-function print-future))
 609     (value null)
 610     (awaited-by nil))
 611
 612   (defun print-future (self sink depth)
 613     (if (eq (future-value self) null)
 614         (format sink "#<~S unpredicted>" (type-of self))
 615       (if (and *print-level* (>= depth *print-level*))
 616           (format sink "#<~S predicted as ...>" (type-of self))
 617         (format sink "#<~S predicted as ~S>" (type-of self) (future-value self)))))
 618
 619   (defun future ()
 620     (make-future))
 621
 622   (defun guess (future)
 623     (when (eq (future-value future) null)
 624       (setf (future-awaited-by future) (mp/current-process))
 625       (mp/process-wait "Awaiting future" (lambda () (not (eq (future-value future) null))))
 626       (setf (future-awaited-by future) nil))
 627     (future-value future))
 628
 629   (defun predict (future value)
 630     (setf (future-value future) value)
 631     (let ((aw (future-awaited-by future)))
 632       (when aw (mp/process-allow-schedule aw)))
 633     value)
 634   )
 635 ||#
 636
 637 (defun map-array (fun array &rest make-array-options)
 638   (let ((res (apply #'make-array (array-dimensions array) make-array-options)))
 639     (dotimes (i (array-total-size array))
 640       (setf (row-major-aref res i) (funcall fun (row-major-aref array i))))
 641     res))
 642
 643 ;;----------------------------------------------------------------------------------------------------
 644
 645 (defun g/peek-char (&optional (peek-type nil) (source *standard-input*)
 646                               (eof-error-p T) eof-value)
 647   (cond ((eq peek-type T)
 648          (do ((ch (g/read-char source eof-error-p '%the-eof-object%)
 649                   (g/read-char source eof-error-p '%the-eof-object%)))
 650              ((or (eq ch '%the-eof-object%)
 651                   (not (white-space-p ch)))
 652               (cond ((eq ch '%the-eof-object%) eof-value)
 653                     (t (g/unread-char ch source) ch)) )))
 654         ((eq peek-type NIL)
 655          (let ((ch (g/read-char source eof-error-p '%the-eof-object%)))
 656            (cond ((eq ch '%the-eof-object%) eof-value)
 657                  (t (g/unread-char ch source)
 658                     ch))))
 659         ((characterp peek-type)
 660          (do ((ch (g/read-char source eof-error-p '%the-eof-object%)
 661                   (g/read-char source eof-error-p '%the-eof-object%)))
 662              ((or (eq ch '%the-eof-object%) (eql ch peek-type))
 663               (cond ((eq ch '%the-eof-object%) eof-value)
 664                     (t (g/unread-char ch source) ch)) )) ) ))
 665
 666
 667
 668 (defun cl-byte-stream->gstream (stream)
 669   (make-instance 'cl-byte-stream :cl-stream stream))
 670
 671 (defun cl-char-stream->gstream (stream)
 672   (make-instance 'cl-char-stream :cl-stream stream))
 673
 674 ;;; ----------------------------------------------------------------------------------------------------
 675
 676 (defvar *all-temporary-files* nil
 677   "List of all temporary files.")
 678
 679 (defun find-temporary-file (&key (type nil))
 680   (let ((temp-dir "/tmp/*")             ;since Motif is only available on unix, we subtly assume a unix host.
 681         (stream nil))
 682     (labels ((invent-name ()
 683                (merge-pathnames (make-pathname
 684                                  :type type
 685                                  :name
 686                                  (let ((*print-base* 35))
 687                                    (format nil "ws_~S" (random (expt 36 7)))))
 688                                 temp-dir)))
 689       (unwind-protect
 690           (do ((name (invent-name) (invent-name)))
 691               ((setq stream (open name :direction :output :if-exists nil))
 692                (push name *all-temporary-files*)        ;remember this file
 693                name))
 694         (when stream
 695           (close stream)) ))))
 696
 697 (defun delete-temporary-file (filename)
 698   (setf *all-temporary-files* (delete filename *all-temporary-files*))
 699   (ignore-errors (delete-file filename)))
 700
 701 (defmacro with-temporary-file ((name-var &key type) &body body)
 702   (let ((name (gensym)))
 703     `(let* ((,name (find-temporary-file :type ,type))
 704             (,name-var ,name))
 705        (unwind-protect
 706            (progn ,@body)
 707          (when (open ,name :direction :probe)
 708            (delete-temporary-file ,name)))) ))
 709
 710 ;;;;
 711
 712 (defun set-equal (x y &rest options)
 713   (null (apply #'set-exclusive-or x y options)))
 714
 715 ;;;;
 716
 717 (defun maybe-parse-integer (string &key (radix 10))
 718   (cond ((not (stringp string)) nil)
 719         (t
 720          (let ((len (length string)))
 721            (cond ((= len 0) nil)
 722                  (t
 723                   (let ((start 0)
 724                         (vz +1)
 725                         (res 0))
 726                     (cond ((and (> len 1) (char= (char string 0) #\+))
 727                            (incf start))
 728                           ((and (> len 1) (char= (char string 0) #\-))
 729                            (setf vz -1)
 730                            (incf start)))
 731                     (do ((i start (+ i 1)))
 732                         ((= i len) (* vz res))
 733                       (let ((d (digit-char-p (char string i) radix)))
 734                         (if d
 735                             (setf res (+ (* radix res) d))
 736                           (return nil)))))))))))
 737
 738 ;;;
 739
 740 (defun nop (&rest ignore)
 741   (declare (ignore ignore))
 742   nil)
 743
 744 (defmacro with-structure-slots ((type &rest slots) obj &body body)
 745   ;; Something like 'with-slots' but for structures. Assumes that the structure
 746   ;; slot accessors have the default name. Note that the structure type must
 747   ;; been provided.
 748   (let ((obj-var (make-symbol "OBJ")))
 749     `(LET ((,obj-var ,obj))
 750        (SYMBOL-MACROLET ,(mapcar (lambda (slot)
 751                                    (list slot
 752                                          `(,(intern (concatenate 'string (symbol-name type) "-" (symbol-name slot))
 753                                                     (symbol-package type))
 754                                            ,obj-var)))
 755                                  slots)
 756          ,@body))))
 757
 758 ;;;; ----------------------------------------------------------------------------------------------------
 759
 760 ;; Wir helfen den Compiler mal etwas auf die Spruenge ...
 761 (defun compile-funcall (fn args)
 762   (cond ((eq fn '#'identity)
 763          (car args))
 764         ((eq fn '#'nop)
 765          `(progn ,args nil))
 766         ((and (consp fn) (eq (car fn) 'function))
 767          `(,(cadr fn) .,args))
 768         ((and (consp fn) (eq (car fn) 'lambda))
 769          `(,fn .,args))
 770         ((and (consp fn) (eq (car fn) 'curry))
 771          (compile-funcall (cadr fn) (append (cddr fn) args)))
 772         ((and (consp fn) (eq (car fn) 'rcurry))
 773          (compile-funcall (cadr fn) (append args (cddr fn))))
 774         (t
 775          (warn "Unable to inline funcall to ~S." fn)
 776          `(funcall ,fn .,args)) ))
 777
 778 (defmacro funcall* (fn &rest args)
 779   (compile-funcall fn args))
 780
 781 ;; Ich mag mapc viel lieber als dolist, nur viele Compiler optimieren
 782 ;; das nicht, deswegen das Macro hier. Einige Compiler haben auch kein
 783 ;; DEFINE-COMPILER-MACRO :-(
 784
 785 (defmacro mapc* (fn list)
 786   (let ((g (gensym)))
 787     `(dolist (,g ,list)
 788        ,(compile-funcall fn (list g)))))
 789
 790 ;; Das gleiche mit REDUCE und MAPCAR.
 791
 792 ;; REDUCE arbeitet sowohl fuer Vectoren als auch fuer Listen. Wir
 793 ;; haben allerdings leider keinen vernuenftigen Zugriff auf
 794 ;; Deklarationen; Man koennte mit TYPEP herangehen und hoffen, dass
 795 ;; der Compiler das optimiert, ich fuerchte aber dass das nicht
 796 ;; funktionieren wird. Und CLISP verwirft Deklarationen ja total. Also
 797 ;; zwei Versionen: LREDUCE* und VREDUCE*
 798
 799 (defmacro vreduce* (fun seq &rest rest &key (key '#'identity) from-end start end
 800                                             (initial-value nil initial-value?))
 801   (declare (ignore rest))
 802   (let (($start (make-symbol "start"))
 803         ($end (make-symbol "end"))
 804         ($i (make-symbol "i"))
 805         ($accu (make-symbol "accu"))
 806         ($seq (make-symbol "seq")))
 807     (cond (from-end
 808          (cond (initial-value?
 809                 `(LET* ((,$seq ,seq)
 810                         (,$start ,(or start 0))
 811                         (,$end ,(or end `(LENGTH ,$seq)))
 812                         (,$accu ,initial-value))
 813                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 814                    (DO ((,$i (- ,$end 1) (THE FIXNUM (- ,$i 1))))
 815                        ((< ,$i ,$start) ,$accu)
 816                      (DECLARE (TYPE FIXNUM ,$i))
 817                      (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)) )))
 818                (t
 819                 `(LET* ((,$seq ,seq)
 820                         (,$start ,(or start 0))
 821                         (,$end ,(or end `(LENGTH ,$seq))))
 822                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 823                    (COND ((= 0 (- ,$end ,$start))
 824                           (FUNCALL* ,fun))
 825                          (T
 826                           (LET ((,$accu (FUNCALL* ,key (AREF ,$seq (- ,$end 1)))))
 827                             (DO ((,$i (- ,$end 2) (THE FIXNUM (- ,$i 1))))
 828                                 ((< ,$i ,$start) ,$accu)
 829                               (DECLARE (TYPE FIXNUM ,$i))
 830                               (SETF ,$accu (FUNCALL* ,fun (FUNCALL* ,key (AREF ,$seq ,$i)) ,$accu)))))))) ))
 831         (t
 832          (cond (initial-value?
 833                 `(LET* ((,$seq ,seq)
 834                         (,$start ,(or start 0))
 835                         (,$end ,(or end `(LENGTH ,$seq)))
 836                         (,$accu ,initial-value))
 837                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 838                    (DO ((,$i ,$start (THE FIXNUM (+ ,$i 1))))
 839                        ((>= ,$i ,$end) ,$accu)
 840                      (DECLARE (TYPE FIXNUM ,$i))
 841                      (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i)))) )))
 842                (t
 843                 `(let* ((,$seq ,seq)
 844                         (,$start ,(or start 0))
 845                         (,$end ,(or end `(LENGTH ,$seq))))
 846                    (DECLARE (TYPE FIXNUM ,$start ,$end))
 847                    (COND ((= 0 (- ,$end ,$start))
 848                           (FUNCALL* ,fun))
 849                          (T
 850                           (LET ((,$accu (FUNCALL* ,key (AREF ,$seq ,$start))))
 851                             (DO ((,$i (+ ,$start 1) (+ ,$i 1)))
 852                                 ((>= ,$i ,$end) ,$accu)
 853                               (DECLARE (TYPE FIXNUM ,$i))
 854                               (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key (AREF ,$seq ,$i)))))))))))))))
 855
 856 (defmacro lreduce* (fun seq &rest rest &key (key '#'identity) from-end start end
 857                                             (initial-value nil initial-value?))
 858   (cond ((or start end from-end)
 859          `(reduce ,fun ,seq .,rest))
 860         (t
 861          (cond (initial-value?
 862                 (let (($accu (make-symbol "accu"))
 863                       ($k (make-symbol "k")))
 864                   `(LET* ((,$accu ,initial-value))
 865                      (DOLIST (,$k ,seq ,$accu)
 866                         (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k)))))))
 867                (t
 868                 (let (($accu (make-symbol "accu"))
 869                       ($seq (make-symbol "seq"))
 870                       ($k (make-symbol "k")))
 871                   `(LET* ((,$seq ,seq))
 872                          (IF (NULL ,$seq)
 873                              (FUNCALL* ,fun)
 874                              (LET ((,$accu (FUNCALL* ,key (CAR ,$seq))))
 875                                   (DOLIST (,$k (CDR ,$seq) ,$accu)
 876                                           (SETF ,$accu (FUNCALL* ,fun ,$accu (FUNCALL* ,key ,$k)))))))) ))) ))
 877
 878
 879 ;;; Wenn wir so weiter machen, koennen wir bald gleich unseren eigenen
 880 ;;; Compiler schreiben ;-)
 881
 882 #||
 883 (defmacro lreduce* (fun seq &rest x &key key &allow-other-keys)
 884   (let ((q (copy-list x)))
 885     (remf q :key)
 886     (cond (key
 887            `(reduce ,fun (map 'vector ,key ,seq) .,q))
 888           (t
 889            `(reduce ,fun ,seq .,q)))))
 890
 891 (defmacro vreduce* (fun seq &rest x &key key &allow-other-keys)
 892   (let ((q (copy-list x)))
 893     (remf q :key)
 894     (cond (key
 895            `(reduce ,fun (map 'vector ,key ,seq) .,q))
 896           (t
 897            `(reduce ,fun ,seq .,q)))))
 898
 899 ||#
 900
 901 ;; Stolen from Eclipse (http://elwoodcorp.com/eclipse/unique.htm
 902
 903 (defmacro with-unique-names ((&rest names) &body body)
 904   `(let (,@(mapcar (lambda (x) (list x `(gensym ',(concatenate 'string (symbol-name x) "-")))) names))
 905      .,body))
 906
 907
 908 (defun gstream-as-string (gstream &optional (buffer-size 4096))
 909   (let ((buffer (g/make-string buffer-size :adjustable t)))
 910     (do* ((i 0 j)
 911           (j (g/read-char-sequence buffer gstream :start 0 :end buffer-size)
 912              (g/read-char-sequence buffer gstream :start i :end (+ i buffer-size)) ))
 913         ((= j i) (subseq buffer 0 j))
 914       (adjust-array buffer (list (+ j buffer-size))) )))
 915
 916 ;;;; Generic hash tables
 917
 918 ;; TODO:
 919 ;; - automatic size adjustment
 920 ;; - sensible printer
 921 ;; - make-load-form?!
 922
 923 (defstruct g/hash-table
 924   hash-function                         ;hash function
 925   compare-function                      ;predicate to test for equality
 926   table                                 ;simple vector of chains
 927   size                                  ;size of hash table
 928   (nitems 0))                           ;number of items
 929
 930 (defun g/make-hash-table (&key (size 100) (hash-function #'sxhash) (compare-function #'eql))
 931   "Creates a generic hashtable;
 932    `size' is the default size of the table.
 933    `hash-function' (default #'sxhash) is a specific hash function
 934    `compare-function' (default #'eql) is a predicate to test for equality."
 935   (setf size (nearest-greater-prime size))
 936   (make-g/hash-table :hash-function hash-function
 937                      :compare-function compare-function
 938                      :table (make-array size :initial-element nil)
 939                      :size size
 940                      :nitems 0))
 941
 942 (defun g/hashget (hashtable key &optional (default nil))
 943   "Looks up the key `key' in the generic hash table `hashtable'.
 944    Returns three values:
 945    value     - value, which as associated with the key, or `default' is no value
 946                present.
 947    successp  - true, iff the key was found.
 948    key       - the original key in the hash table."
 949   ;; -> value ; successp ; key
 950   (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key)
 951                 (g/hash-table-size hashtable))))
 952     (let ((q (assoc key (aref (g/hash-table-table hashtable) j)
 953                     :test (g/hash-table-compare-function hashtable))))
 954       (if q
 955           (values (cdr q) t (car q))
 956         (values default nil)))))
 957
 958 (defun (setf g/hashget) (new-value hashtable key &optional (default nil))
 959   (declare (ignore default))
 960   (let ((j (mod (funcall (g/hash-table-hash-function hashtable) key)
 961                 (g/hash-table-size hashtable))))
 962     (let ((q (assoc key (aref (g/hash-table-table hashtable) j)
 963                     :test (g/hash-table-compare-function hashtable))))
 964       (cond ((not (null q))
 965              (setf (cdr q) new-value))
 966             (t
 967              (push (cons key new-value)
 968                    (aref (g/hash-table-table hashtable) j))
 969              (incf (g/hash-table-nitems hashtable))))))
 970   new-value)
 971
 972 (defun resize-hash-table (hashtable new-size)
 973   "Adjust the size of a generic hash table. (the size is round to the next greater prime number)."
 974   (setf new-size (nearest-greater-prime new-size))
 975   (let ((new-table (make-array new-size :initial-element nil)))
 976     (dotimes (i (g/hash-table-size hashtable))
 977       (dolist (k (aref (g/hash-table-table hashtable) i))
 978         (push k (aref new-table
 979                       (mod (funcall (g/hash-table-hash-function hashtable) (car k))
 980                            new-size)))))
 981     (setf (g/hash-table-table hashtable) new-table
 982           (g/hash-table-size hashtable) new-size)
 983     hashtable))
 984
 985 (defun g/clrhash (hashtable)
 986   "Clears a generic hash table."
 987   (dotimes (i (g/hash-table-size hashtable))
 988     (setf (aref (g/hash-table-table hashtable) i) nil))
 989   (setf (g/hash-table-nitems hashtable) nil)
 990   hashtable)
 991
 992 ;; hash code utilities
 993
 994 (defconstant +fixnum-bits+
 995     (1- (integer-length most-positive-fixnum))
 996   "Pessimistic approximation of the number of bits of fixnums.")
 997
 998 (defconstant +fixnum-mask+
 999     (1- (expt 2 +fixnum-bits+))
1000   "Pessimistic approximation of the largest bit-mask, still being a fixnum.")
1001
1002 (defun stir-hash-codes (a b)
1003   "Stirs two hash codes together; always returns a fixnum.
1004    When applied sequenitally the first argument should be used as accumulator."
1005   ;; ich mach das mal wie Bruno
1006   (logand +fixnum-mask+
1007           (logxor (logior (logand +fixnum-mask+ (ash a 5))
1008                           (logand +fixnum-mask+ (ash a (- 5 +fixnum-bits+))))
1009                   b)))
1010
1011 (defun hash-sequence (sequence hash-function &optional (accu 0))
1012   "Applies the hash function `hash-function' to each element of `sequence' and
1013    stirs the resulting hash codes together using STIR-HASH-CODE starting from
1014    `accu'."
1015   (map nil (lambda (item)
1016              (setf accu (stir-hash-codes accu (funcall hash-function item))))
1017        sequence)
1018   accu)
1019
1020 ;; some specific hash functions
1021
1022 (defun hash/string-equal (string)
1023   "Hash function compatible with STRING-EQUAL."
1024   (hash-sequence string (lambda (char)
1025                           (sxhash (char-upcase char)))))
1026
1027 ;; some specific hash tables
1028
1029 (defun make-string-equal-hash-table (&rest options)
1030   "Constructs a new generic hash table using STRING-EQUAL as predicate."
1031   (apply #'g/make-hash-table
1032          :hash-function #'hash/string-equal
1033          :compare-function #'string-equal
1034          options))
1035
1036 ;; prime numbers
1037
1038 (defun primep (n)
1039   "Returns true, iff `n' is prime."
1040   (and (> n 2)
1041        (do ((i 2 (+ i 1)))
1042            ((> (* i i) n) t)
1043          (cond ((zerop (mod n i)) (return nil))))))
1044
1045 (defun nearest-greater-prime (n)
1046   "Returns the smallest prime number no less than `n'."
1047   (cond ((primep n) n)
1048         ((nearest-greater-prime (+ n 1)))))
1049
1050
1051 ;;;
1052
1053 (defun grind-documentation-string (string &optional (sink *standard-output*))
1054   ;; some people say:
1055   ;;   (defun foo ()
1056   ;;     "This function
1057   ;;   frobinates its two arguments.")
1058   ;; some say:
1059   ;;   (defun foo ()
1060   ;;     "This function
1061   ;;      frobinates its two arguments.")
1062   ;; instead.
1063   (let ((min-indention nil))
1064     ;; We sort this out by finding the minimum indent in all but the first line.
1065     (with-input-from-string (in string)
1066       (read-line in nil nil)            ;ignore first line
1067       (do ((x (read-line in nil nil) (read-line in nil nil)))
1068           ((null x))
1069         (let ((p (position-if-not (curry #'char= #\space) x)))
1070           (when p
1071             (setf min-indention (min* min-indention p))))))
1072     (setf min-indention (or min-indention 0))
1073     ;; Now we could dump the string
1074     (with-input-from-string (in string)
1075       ;; first line goes unindented
1076       (let ((x (read-line in nil nil)))
1077         (when x
1078           (fresh-line sink)
1079           (write-string x sink)))
1080       (do ((x (read-line in nil nil) (read-line in nil nil)))
1081           ((null x))
1082         (terpri sink)
1083         (when (< min-indention (length x))
1084           (write-string x sink :start min-indention)))))
1085   (values))
1086
1087 (defun ap (&rest strings)
1088   "A new apropos."
1089   (let ((res nil))
1090     (do-all-symbols (symbol)
1091       (unless (member symbol res)
1092         (when (every (lambda (string)
1093                        (search string (symbol-name symbol)))
1094                      strings)
1095           (push symbol res))))
1096     (dolist (k res)
1097       (print k)
1098       (when (fboundp k)
1099         (princ ", function"))
1100       (when (boundp k)
1101         (princ ", variable"))
1102       )))
1103