utilities.lisp

   1 (in-package :gsharp-utilities)
   2
   3 ;;; Destructively insert the element in the list at the position
   4 ;;; indicated.  The position must be greater than or equal to zero and
   5 ;;; less than or equal to the length of the list.
   6 (defun ninsert-element (element list position)
   7   (if (zerop position)
   8       (push element list)
   9       (push element (cdr (nthcdr (1- position) list))))
  10   list)
  11
  12 ;;; The following hack is due to Gilbert Baumann.  It allows us to
  13 ;;; dynamically mix in classes into a class without the latter being
  14 ;;; aware of it.
  15
  16 ;; First of all we need to keep track of added mixins, we use a hash
  17 ;; table here. Better would be to stick this information to the victim
  18 ;; class itself.
  19
  20 (defvar *stealth-mixins* (make-hash-table))
  21
  22 (defmacro class-stealth-mixins (class)
  23   `(gethash ,class *stealth-mixins*))
  24
  25 (defmacro define-stealth-mixin (name super-classes victim-class
  26                                 &rest for-defclass)
  27   "Like DEFCLASS but adds the newly defined class to the super classes
  28 of 'victim-class'."
  29   `(progn
  30     ;; First define the class we talk about
  31     (defclass ,name ,super-classes ,@for-defclass)
  32
  33     ;; Add the class to the mixins of the victim
  34     (clim-mop:ensure-class
  35      ',victim-class
  36      :direct-superclasses (adjoin ',name
  37                                   (and (find-class ',victim-class nil)
  38                                        (class-direct-superclasses
  39                                         (find-class ',victim-class)))
  40                                   :test #'class-equalp))
  41
  42     ;; Register it as a new mixin for the victim class
  43     (pushnew ',name (class-stealth-mixins ',victim-class))
  44
  45     ;; When one wants to [re]define the victim class the new mixin
  46     ;; should be present too. We do this by 'patching' ensure-class:
  47     (defmethod clim-mop:ensure-class-using-class :around
  48       (class (name (eql ',victim-class))
  49        &rest arguments
  50        &key (direct-superclasses nil direct-superclasses-p)
  51        &allow-other-keys)
  52       (cond (direct-superclasses-p
  53              ;; Silently modify the super classes to include our new
  54              ;; mixin.
  55              (dolist (k (class-stealth-mixins name))
  56                (pushnew k direct-superclasses
  57                         :test #'class-equalp))
  58              (apply #'call-next-method class name
  59                     :direct-superclasses direct-superclasses
  60                     arguments))
  61             (t
  62              (call-next-method))))
  63     ;;
  64     ',name))
  65
  66 ;; The 'direct-superclasses' argument to ensure-class is a list of
  67 ;; either classes or their names. Since we want to avoid duplicates,
  68 ;; we need an appropriate equivalence predicate:
  69
  70 (defun class-equalp (c1 c2)
  71   (when (symbolp c1) (setf c1 (find-class c1)))
  72   (when (symbolp c2) (setf c2 (find-class c2)))
  73   (eq c1 c2))
  74
  75 ;;; Unicode utilities
  76
  77 (defparameter *char-to-unicode-table* (make-hash-table))
  78 (defparameter *unicode-to-char-table* (make-hash-table))
  79
  80 (defun char-to-unicode (char)
  81   (or (gethash char *char-to-unicode-table*) 0))
  82
  83 (defun unicode-to-char (unicode)
  84   (or (gethash unicode *unicode-to-char-table*) #\_))
  85
  86 (defun set-char-unicode-correspondance (char unicode)
  87   (setf (gethash char *char-to-unicode-table*) unicode
  88         (gethash unicode *unicode-to-char-table*) char))
  89
  90 (loop for char in '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
  91                     #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)
  92       for code from 65
  93       do (set-char-unicode-correspondance char code))
  94
  95 (loop for char in '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
  96                     #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)
  97       for code from 97
  98       do (set-char-unicode-correspondance char code))
  99
 100 (loop for char in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
 101       for code from 48
 102       do (set-char-unicode-correspondance char code))
 103
 104