src/global.lisp

   1 (in-package :lice)
   2
   3 (defconstant +debug-v+ 1)
   4 (defconstant +debug-vv+ 2)
   5 (defconstant +debug-vvv+ 3)
   6
   7 (defparameter *debug-level* +debug-v+)
   8 ;;(defparameter *debug-level* +debug-vvv+)
   9
  10 (defun dformat (lvl &rest fmt-args)
  11   (when (>= *debug-level* lvl)
  12     (with-open-file (f #p"/tmp/debug" :direction :output :if-exists :append
  13                         :if-does-not-exist :create)
  14       (apply 'format f fmt-args))))
  15
  16 (defmacro verbose-body (&body body)
  17   "Print each sexpr in BODY and its return value."
  18   (let ((ret (gensym "RET")))
  19     (loop for i in body
  20           collect `(let ((,ret ,i))
  21                      (format t "~s => ~s~%" ,i ,ret)
  22                      ,ret))))
  23
  24 (defun last1 (l)
  25   "Return the last elt of the list."
  26   (car (last l)))
  27
  28 (defun nconc1 (list item)
  29   "destructively append ITEM to the end of L"
  30   (nconc list (list item)))
  31
  32 ;; (defun grow-vector (vector amt initial-element)
  33 ;;   "grow the vector's size by AMT elements"
  34 ;;   (adjust-array vector (+ (length vector) amt)
  35 ;;              :initial-element initial-element
  36 ;;              :fill-pointer t))
  37
  38 ;; (defun vector-append (vector1 vector2)
  39 ;;   "append vector2 to the end of vector1."
  40 ;;   (let ((len (length vector1)))
  41 ;;     (grow-vector vector1 (length vector2) (elt vector2 0))
  42 ;;     (replace vector1 vector2 :start1 (1+ len) :start2 1)))
  43
  44 (define-condition lice-condition ()
  45   () (:documentation "The base condition for all lice related errors."))
  46
  47 (define-condition wrong-type-argument (lice-condition)
  48     ((:type :initarg :type :accessor wrong-type-argument-type)))
  49
  50 ;; (defun fmt (fmt &rest args)
  51 ;;   "A movitz hack function. FORMAT basically doesn't work, so i use this to get around it."
  52 ;;   (let ((s (make-array 100 :fill-pointer 0 :element-type 'character)))
  53 ;;     (apply #'format s fmt args)
  54 ;;     s))
  55
  56 #+movitz
  57 (defun read-from-string (string)
  58   "Read the string and return an sexpr. This is a MOVITZ hack
  59   because it doesn't have read-from-string."
  60   (muerte::simple-read-from-string string))
  61
  62 ;;; Lisp function we like to have
  63
  64 (defmacro while (test &body body)
  65   "If TEST yields non-nil, eval BODY... and repeat.
  66 The order of execution is thus TEST, BODY, TEST, BODY and so on
  67 until TEST returns nil."
  68   (if body
  69       `(loop while ,test do ,@body)
  70       `(loop while ,test)))
  71
  72 (defvar *quit-code* 7
  73   "The terminal char code for the interrupt key.")
  74
  75 (defvar *inhibit-quit* nil
  76   ;; XXX: this is not correct docs
  77   "Non-nil inhibits C-g quitting from happening immediately.
  78 Note that `quit-flag' will still be set by typing C-g,
  79 so a quit will be signaled as soon as `inhibit-quit' is nil.
  80 To prevent this happening, set `quit-flag' to nil
  81 before making `inhibit-quit' nil.")
  82
  83 (defvar *waiting-for-input* nil
  84   "T when we're waiting for .. input")
  85
  86 (defvar *quit-flag* nil
  87   "Set to T when the user hit the quit key")
  88
  89 (defmacro depricate (symbol refer-to)
  90   "A macro to mark a symbol as depricated. This is done with
  91 function in emacs whose purpose is better done another
  92 way. For example, a set- function replaced by a setf function. "
  93   `(setf (get (quote ,symbol) :depricated) (quote ,refer-to)))
  94
  95 (defun read-string-with-escapes (stream close)
  96   "read in a string and handle \\f \\n \\r \\t \\v escape characters."
  97   (with-output-to-string (out)
  98     (do ((char (read-char stream nil :eof) (read-char stream nil :eof)))
  99         ((or (eq char :eof) (char= char close))
 100          (if (eq char :eof)
 101              (error 'end-of-file :stream stream)))
 102       (when (char= char #\\)
 103         (setq char (read-char stream nil :eof))
 104         (case char
 105           (:eof (error 'end-of-file :stream stream))
 106           (#\f (setq char #\Page))
 107           (#\n (setq char #\Newline))
 108           (#\r (setq char #\Return))
 109           (#\t (setq char #\Tab))
 110           (#\v (setq char #\Vt))))
 111         (write-char char out))))
 112
 113 ;; LiCE handles a few escape codes like GNU Emacs
 114 (set-macro-character #\" #'read-string-with-escapes)
 115
 116 (defun run-hooks (&rest hooks)
 117   "Run each hook in HOOKS.
 118 Each argument should be a symbol, a hook variable.
 119 These symbols are processed in the order specified.
 120 If a hook symbol has a non-nil value, that value may be a function
 121 or a list of functions to be called to run the hook.
 122 If the value is a function, it is called with no arguments.
 123 If it is a list, the elements are called, in order, with no arguments.
 124
 125 Major modes should not use this function directly to run their mode
 126 hook; they should use `run-mode-hooks' instead.
 127
 128 Do not use `make-local-variable' to make a hook variable buffer-local.
 129 Instead, use `add-hook' and specify t for the LOCAL argument."
 130   (mapc (lambda (h)
 131           (when (symbolp h)
 132             (setf h (symbol-value h)))
 133           (mapc 'funcall h))
 134         hooks))
 135
 136 (defun add-hook (hook function &optional append local)
 137   "Add to the value of HOOK the function function.
 138 FUNCTION is not added if already present.
 139 FUNCTION is added (if necessary) at the beginning of the hook list
 140 unless the optional argument append is non-nil, in which case
 141 function is added at the end.
 142
 143 The optional fourth argument, LOCAL, if non-nil, says to modify
 144 the hook's buffer-local value rather than its default value.
 145 This makes the hook buffer-local if needed, and it makes t a member
 146 of the buffer-local value.  That acts as a flag to run the hook
 147 functions in the default value as well as in the local value.
 148
 149 HOOK should be a symbol, and FUNCTION may be any valid function.  If
 150 HOOK is void, it is first set to nil.  If HOOK's value is a single
 151 function, it is changed to a list of functions."
 152   (declare (ignore append local))
 153   (pushnew function (symbol-value hook)))
 154
 155 (defun remove-hook (hook function &optional local)
 156   "Remove from the value of HOOK the function FUNCTION.
 157 HOOK should be a symbol, and FUNCTION may be any valid function.  If
 158 FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
 159 list of hooks to run in HOOK, then nothing is done.  See `add-hook'.
 160
 161 The optional third argument, LOCAL, if non-nil, says to modify
 162 the hook's buffer-local value rather than its default value."
 163   (declare (ignore local))
 164   (setf (symbol-value hook) (remove function (symbol-value hook))))
 165
 166 (defun int-to-string (n)
 167   "Return the decimal representation of number as a string.
 168 Uses a minus sign if negative.
 169 number may be an integer or a floating point number."
 170   (check-type n number)
 171   (prin1-to-string n))
 172
 173 (defun split-string (string &optional (separators "
 174 "))
 175   "Splits STRING into substrings where there are matches for SEPARATORS.
 176 Each match for SEPARATORS is a splitting point.
 177 The substrings between the splitting points are made into a list
 178 which is returned.
 179 ***If SEPARATORS is absent, it defaults to \"[ \f\t\n\r\v]+\".
 180
 181 If there is match for SEPARATORS at the beginning of STRING, we do not
 182 include a null substring for that.  Likewise, if there is a match
 183 at the end of STRING, we don't include a null substring for that.
 184
 185 Modifies the match data; use `save-match-data' if necessary."
 186   ;; FIXME: This let is here because movitz doesn't 'lend optional'
 187   (let ((seps separators))
 188     (labels ((sep (c)
 189                   (find c seps :test #'char=)))
 190       (loop for i = (position-if (complement #'sep) string)
 191             then (position-if (complement #'sep) string :start j)
 192             while i
 193             as j = (position-if #'sep string :start i)
 194             collect (subseq string i j)
 195             while j))))
 196
 197 ;; A cheap memoizer. Obviously, a hashtable would be better.
 198
 199 (defstruct memoize-state
 200   (data (vector nil nil nil nil nil nil nil nil nil nil nil nil))
 201   (test 'equal)
 202   (pt 0))
 203
 204 (defun memoize-store (state thing value)
 205   (incf (memoize-state-pt state))
 206   (when (>= (memoize-state-pt state)
 207             (length (memoize-state-data state)))
 208     (setf (memoize-state-pt state) 0))
 209   (setf (svref (memoize-state-data state) (memoize-state-pt state)) (cons thing value))
 210   value)
 211
 212 (defmacro memoize (mem-var thing compute)
 213   "Check if we've computed a value for thing. if so, use it. if
 214 not compute it, store the result, and return it."
 215   (let ((match (gensym "MATCH")))
 216     `(let ((,match (find ,thing (memoize-state-data ,mem-var) :key 'first :test (memoize-state-test ,mem-var))))
 217        (if ,match
 218            (cdr ,match)
 219            (memoize-store ,mem-var ,thing ,compute)))))
 220
 221 (defun add-to-list (list-var element &optional append)
 222   "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
 223 The test for presence of ELEMENT is done with `equal'.
 224 If ELEMENT is added, it is added at the beginning of the list,
 225 unless the optional argument APPEND is non-nil, in which case
 226 ELEMENT is added at the end.
 227
 228 The return value is the new value of LIST-VAR.
 229
 230 If you want to use `add-to-list' on a variable that is not defined
 231 until a certain package is loaded, you should put the call to `add-to-list'
 232 into a hook function that will be run only after loading the package.
 233 `eval-after-load' provides one way to do this.  In some cases
 234 other hooks, such as major mode hooks, can do the job."
 235   (if (member element (symbol-value list-var))
 236       (symbol-value list-var)
 237     (set list-var
 238          (if append
 239              (append (symbol-value list-var) (list element))
 240            (cons element (symbol-value list-var))))))
 241
 242 (defmacro defsubst (name lambda-list &body body)
 243   "Define an inline function.  The syntax is just like that of `defun'."
 244   `(progn
 245      (declaim (inline ,name))
 246      (defun ,name ,lambda-list
 247        ,@body)))
 248
 249
 250 (defvar *debug-on-error* t
 251   "Non-nil means enter the debugger if an unhandled error is signaled.")
 252
 253 (defvar *debug-on-quit* nil
 254   "Non-nil means enter the debugger if quit is signaled (C-g, for example).")
 255
 256 (defvar debug-ignored-errors nil
 257   "*List of errors for which the debugger should not be called.
 258 Each element may be a condition-name or a regexp that matches error messages.
 259 If any element applies to a given error, that error skips the debugger
 260 and just returns to top level.
 261 This overrides the variable `debug-on-error'.
 262 It does not apply to errors handled by `condition-case'.")
 263
 264 (defun purecopy (thing)
 265   "Make a copy of object OBJ in pure storage.
 266 Recursively copies contents of vectors and cons cells.
 267 Does not copy symbols.  Copies strings without text properties."
 268   thing)
 269
 270 (defun garbage-collect ()
 271   "Reclaim storage for Lisp objects no longer needed."
 272   (warn "unimplemented garbage-collect"))
 273
 274 (provide :lice-0.1/global)