| 1 | (in-package "ELISP")
|
|---|
| 2 |
|
|---|
| 3 | (defvar load-path nil)
|
|---|
| 4 | (defvar features nil)
|
|---|
| 5 | (defvar *buffer-locals* (make-hash-table))
|
|---|
| 6 | (defvar *current-buffer* nil)
|
|---|
| 7 | (define-symbol-macro major-mode (buffer-major-mode (current-buffer)))
|
|---|
| 8 |
|
|---|
| 9 |
|
|---|
| 10 | (cl:defun make-sparse-keymap (&optional string)
|
|---|
| 11 | (if string
|
|---|
| 12 | (list 'keymap string)
|
|---|
| 13 | (list 'keymap)))
|
|---|
| 14 |
|
|---|
| 15 | (cl:defun make-keymap (&optional string)
|
|---|
| 16 | (if string
|
|---|
| 17 | (list 'keymap string (make-vector 256))
|
|---|
| 18 | (list 'keymap (make-vector 256))))
|
|---|
| 19 |
|
|---|
| 20 | (cl:defun make-sparse-keymap (&optional string)
|
|---|
| 21 | (if string
|
|---|
| 22 | (list 'keymap string)
|
|---|
| 23 | (list 'keymap)))
|
|---|
| 24 |
|
|---|
| 25 | (cl:defun buffer-local-p (sym)
|
|---|
| 26 | (multiple-value-bind (expansion expanded) (macroexpand sym)
|
|---|
| 27 | (declare (ignore expansion))
|
|---|
| 28 | expanded))
|
|---|
| 29 |
|
|---|
| 30 | (cl:defun elisp-value (sym)
|
|---|
| 31 | (cl:let ((marker (gensym)))
|
|---|
| 32 | (multiple-value-bind (value exists)
|
|---|
| 33 | (gethash sym *buffer-locals*)
|
|---|
| 34 | (if exists
|
|---|
| 35 | (hemlock::variable-value sym)
|
|---|
| 36 | (eval sym)))))
|
|---|
| 37 |
|
|---|
| 38 | (cl:defun = (a b)
|
|---|
| 39 | (cond ((and (characterp a) (characterp b))
|
|---|
| 40 | (char= a b))
|
|---|
| 41 | ((and (numberp a) (characterp b))
|
|---|
| 42 | (cl:= a (char-code b)))
|
|---|
| 43 | ((and (characterp a) (numberp b))
|
|---|
| 44 | (cl:= (char-code a) b))
|
|---|
| 45 | ((and (numberp a) (numberp b))
|
|---|
| 46 | (cl:= a b))
|
|---|
| 47 | (t (error "Wrong type argument ~a" (if (or (numberp a) (characterp a))
|
|---|
| 48 | b
|
|---|
| 49 | a)))))
|
|---|
| 50 |
|
|---|
| 51 | (cl:defun make-variable-buffer-local (sym)
|
|---|
| 52 | (make-variable-foo-local sym :buffer))
|
|---|
| 53 |
|
|---|
| 54 | (cl:defun make-variable-foo-local (sym kind)
|
|---|
| 55 | "MAKE-VARIABLES-BUFFER-LOCAL
|
|---|
| 56 | Arguments SYMBOL
|
|---|
| 57 |
|
|---|
| 58 | Will make a variable buffer-local UNLESS it has prior special binding,
|
|---|
| 59 | this may be a grave incompatibility with Emacs Lisp.
|
|---|
| 60 |
|
|---|
| 61 | In a buffer where no dedicated value has been set, will use the
|
|---|
| 62 | default-value. The default value is set with SET-DEFAULT."
|
|---|
| 63 | (unless (hemlock::hemlock-bound-p sym)
|
|---|
| 64 | (setf (gethash sym *buffer-locals*) kind)
|
|---|
| 65 | (defhvar sym "Variable automatically set from ELISP" :mode :kind)
|
|---|
| 66 | ))
|
|---|
| 67 |
|
|---|
| 68 |
|
|---|
| 69 | ;;; Troublesome? Looks like it IM -- 2003-04-05
|
|---|
| 70 | (cl:defun set-default (sym value)
|
|---|
| 71 | "SET-DEFAULT
|
|---|
| 72 | Args: SYMBOL VALUE
|
|---|
| 73 |
|
|---|
| 74 | Will set the default value of (the buffer-local) SYMBOL to VALUE"
|
|---|
| 75 | (if (buffer-local-p sym)
|
|---|
| 76 | (setf (gethash *buffer-locals* (gethash sym *buffer-locals*)) value)
|
|---|
| 77 | (set sym value)))
|
|---|
| 78 |
|
|---|
| 79 | ;;; Troublesome? Looks like it IM -- 2003-04-05
|
|---|
| 80 | (cl:defun get-default (sym)
|
|---|
| 81 | "GET-DEFAULT
|
|---|
| 82 | Args: SYMBOL
|
|---|
| 83 |
|
|---|
| 84 | Returns the default value for SYMBOL"
|
|---|
| 85 | (if (buffer-local-p sym)
|
|---|
| 86 | (gethash *buffer-locals* (gethash sym *buffer-locals*))
|
|---|
| 87 | (symbol-value sym)))
|
|---|
| 88 |
|
|---|
| 89 | (cl:defmacro interactive (&rest spec)
|
|---|
| 90 | (declare (ignore spec))
|
|---|
| 91 | nil)
|
|---|
| 92 |
|
|---|
| 93 | ;;; This really should generate a glue function to handle the differences
|
|---|
| 94 | ;;; betwen emacs command calling conventions and Hemlock ccc.
|
|---|
| 95 | ;;; Basically, what we need is a layer that does all the prompting that
|
|---|
| 96 | ;;; would've been done on an interactive call in emacs. Probably simplest
|
|---|
| 97 | ;;; to just generate a lambda with the right stuff prompted for, then have
|
|---|
| 98 | ;;; that call the function proper.
|
|---|
| 99 | (cl:defmacro defun (name args &body body)
|
|---|
| 100 | (cl:let ((real-args (elisp-internals:find-lambda-list-variables args))
|
|---|
| 101 | (body (walk-code `(defun ,name ,args ,@body)))
|
|---|
| 102 | (maybe-docstring (car body))
|
|---|
| 103 | (interactive-p (member 'interactive body :key #'(lambda (x) (when (consp x) (car x))))))
|
|---|
| 104 | (if interactive-p
|
|---|
| 105 | `(prog1
|
|---|
| 106 | (cl:defun ,name ,args
|
|---|
| 107 | (declare (special ,@real-args))
|
|---|
| 108 | ,@(cdddr body))
|
|---|
| 109 | (make-command ,(string-downcase (string name))
|
|---|
| 110 | ,(if (stringp maybe-docstring)
|
|---|
| 111 | maybe-docstring
|
|---|
| 112 | (format nil "This implements the elisp command for function ~a." (string name))) ,(elisp-internals:interactive-glue (cadr (car interactive-p)) name)))
|
|---|
| 113 |
|
|---|
| 114 | `(cl:defun ,name ,args
|
|---|
| 115 | (declare (special ,@real-args))
|
|---|
| 116 | ,@(cdddr body)))))
|
|---|
| 117 |
|
|---|
| 118 | (cl:defmacro let (inits &body body)
|
|---|
| 119 | (cl:let ((vars (loop for var in inits
|
|---|
| 120 | collect (cl:if (symbolp var) var (car var)))))
|
|---|
| 121 | `(cl:let ,inits
|
|---|
| 122 | (declare (special ,@vars))
|
|---|
| 123 | ,@body)))
|
|---|
| 124 |
|
|---|
| 125 | (cl:defmacro if (test true &rest falses)
|
|---|
| 126 | `(cl:if ,test ,true (progn ,@falses)))
|
|---|
| 127 |
|
|---|
| 128 | (cl:defmacro lexical-let (&rest body)
|
|---|
| 129 | `(cl:let ,@body ))
|
|---|
| 130 |
|
|---|
| 131 | (cl:defmacro setq (&rest rest)
|
|---|
| 132 | `(cl:setf ,@rest))
|
|---|
| 133 |
|
|---|
| 134 | (cl:defun provide (feature)
|
|---|
| 135 | (cl:push feature features))
|
|---|
| 136 |
|
|---|
| 137 | (cl:defun require (feature &optional filename noerror)
|
|---|
| 138 | (let ((*readtable* elisp-internals:*elisp-readtable*))
|
|---|
| 139 | (or
|
|---|
| 140 | (car (member feature features))
|
|---|
| 141 | (loop for directory in load-path
|
|---|
| 142 | if (elisp-internals:require-load directory feature filename)
|
|---|
| 143 | return feature)
|
|---|
| 144 | (unless noerror
|
|---|
| 145 | (error "Cannot open file ~a." (if filename
|
|---|
| 146 | filename
|
|---|
| 147 | (cl:string-downcase feature)))))))
|
|---|
| 148 |
|
|---|
| 149 | ;; Done via CL:DEFUN since the code walker wreaks havoc with the loop macro.
|
|---|
| 150 | ;; Keep these together for sanity's sake
|
|---|
| 151 | (cl:defun load-library (library-name)
|
|---|
| 152 | (loop for directory in load-path
|
|---|
| 153 | do (loop for ext in '(".el" "")
|
|---|
| 154 | for name = (format nil "~a/~a~a" directory library-name ext)
|
|---|
| 155 | if (cl:probe-file name)
|
|---|
| 156 | do (return-from load-library
|
|---|
| 157 | (let (*package* (find-package "ELISP-USER"))
|
|---|
| 158 | (let ((*readtable* elisp-internals:*elisp-readtable*))
|
|---|
| 159 | (cl:load name)))))))
|
|---|
| 160 |
|
|---|
| 161 | (cl:defun load-file (filename)
|
|---|
| 162 | (let ((*readtable* elisp-internals:*elisp-readtable*)
|
|---|
| 163 | (*package* (find-package "ELISP-USER")))
|
|---|
| 164 | (load filename)))
|
|---|
| 165 |
|
|---|
| 166 | (make-command "load-file" "Load a file, elisp style" #'(lambda (p) (declare (ignore p)) (load-file (hemlock-internals:prompt-for-file :prompt "Load file: "))))
|
|---|
| 167 | (make-command "load-library" "Load a library, elisp-style" #'(lambda (p) (declare (ignore p)) (load-library (hemlock-internals:prompt-for-string :prompt "Load library: "))))
|
|---|
| 168 | ;; End of things kept together
|
|---|
| 169 |
|
|---|
| 170 | ;; Unfinished, including at least *one* function taht isn't implemented
|
|---|
| 171 | ;; (and will be hell to make portably, I'm afraid)
|
|---|
| 172 | (cl:defun expand-file-name (name &optional default-directory)
|
|---|
| 173 | (cl:let ((result (search "~" name)))
|
|---|
| 174 | (if result
|
|---|
| 175 | (cl:let ((name (subseq name result)))
|
|---|
| 176 | (if (char= (cl:aref name 1) #\/)
|
|---|
| 177 | (merge-pathnames (subseq name 2) (elisp-internals:get-user-homedir))
|
|---|
| 178 | (cl:let ((username (subseq name 1 (search "/" name)))
|
|---|
| 179 | (directory (subseq name (1+ (search "/" name)))))
|
|---|
| 180 | (merge-pathnames directory (elisp-internals:get-user-homedir username)))))
|
|---|
| 181 | name
|
|---|
| 182 | )))
|
|---|
| 183 |
|
|---|
| 184 | (cl:defmacro while (test &body body)
|
|---|
| 185 | `(cl:do ()
|
|---|
| 186 | ((not ,test) nil)
|
|---|
| 187 | ,@body))
|
|---|
| 188 |
|
|---|
| 189 | (cl:defmacro aset (array index new-element)
|
|---|
| 190 | `(setf (cl:aref ,array ,index) ,new-element))
|
|---|
| 191 |
|
|---|
| 192 | (cl:defmacro assq (key list)
|
|---|
| 193 | `(cl:assoc ,key ,list :test 'eq))
|
|---|
| 194 |
|
|---|
| 195 | (cl:defmacro assoc (key list)
|
|---|
| 196 | `(cl:assoc ,key ,list :test 'equal))
|
|---|
| 197 |
|
|---|
| 198 | (cl:defun % (x y)
|
|---|
| 199 | "Return the remainder of X divided by Y, both X and Y must be integers"
|
|---|
| 200 | (declare (integer x y))
|
|---|
| 201 | (mod x y))
|
|---|
| 202 |
|
|---|
| 203 | (cl:defun car-safe (object)
|
|---|
| 204 | (when (consp object)
|
|---|
| 205 | (car object)))
|
|---|
| 206 |
|
|---|
| 207 | (cl:defun cdr-safe (object)
|
|---|
| 208 | (when (consp object)
|
|---|
| 209 | (cdr object)))
|
|---|
| 210 |
|
|---|
| 211 | (cl:defun car-less-than-car (a b)
|
|---|
| 212 | (< (car a) (car b)))
|
|---|
| 213 |
|
|---|
| 214 | (cl:defun bool-vector-p (array)
|
|---|
| 215 | (and (simple-vector-p array)
|
|---|
| 216 | (eq (element-type array) 'bit)))
|
|---|
| 217 |
|
|---|
| 218 | (cl:defun aref (vector &rest indices)
|
|---|
| 219 | (if (bool-vector-p vector)
|
|---|
| 220 | (= 1 (apply #'cl:aref vector indices))
|
|---|
| 221 | (apply #'cl:aref vector indices)))
|
|---|
| 222 |
|
|---|
| 223 | (cl:defun make-bool-vector (length init)
|
|---|
| 224 | (make-array (list length) :element-type bit :initial-element (if init 1 0)))
|
|---|
| 225 |
|
|---|
| 226 | (cl:defun delq (element list)
|
|---|
| 227 | (cl:delete element list :test #'cl:eq))
|
|---|
| 228 |
|
|---|
| 229 | (cl:defun fset (symbol function)
|
|---|
| 230 | (cl:setf (symbol-function symbol) function))
|
|---|
| 231 |
|
|---|
| 232 | (cl:defmacro autoload (function file &optional docstring interactive type)
|
|---|
| 233 | (cond ((and docstring interactive)
|
|---|
| 234 | `(defun ,function (&rest args)
|
|---|
| 235 | ,docstring
|
|---|
| 236 | (interactive)
|
|---|
| 237 | (unless (gethash ',function elisp-internals::*autoloads* nil)
|
|---|
| 238 | (setf (gethash ',function elisp-internals::*autoloads*) t)
|
|---|
| 239 | (load ,file))
|
|---|
| 240 | (apply ',function args)))
|
|---|
| 241 | ((and docstring (not interactive))
|
|---|
| 242 | `(defun ,function (&rest args)
|
|---|
| 243 | ,docstring
|
|---|
| 244 | (unless (gethash ',function elisp-internals::*autoloads* nil)
|
|---|
| 245 | (setf (gethash ',function elisp-internals::*autoloads*) t)
|
|---|
| 246 | (load ,file))
|
|---|
| 247 | (apply ',function args)))
|
|---|
| 248 | (interactive
|
|---|
| 249 | `(defun ,function (&rest args)
|
|---|
| 250 | (interactive)
|
|---|
| 251 | (unless (gethash ',function elisp-internals::*autoloads* nil)
|
|---|
| 252 | (setf (gethash ',function elisp-internals::*autoloads*) t)
|
|---|
| 253 | (load ,file))
|
|---|
| 254 | (apply ',function args)))
|
|---|
| 255 | (t
|
|---|
| 256 | `(defun ,function (&rest args)
|
|---|
| 257 | (unless (gethash ',function elisp-internals::*autoloads* nil)
|
|---|
| 258 | (setf (gethash ',function elisp-internals::*autoloads*) t)
|
|---|
| 259 | (load ,file))
|
|---|
| 260 | (apply ',function args)))))
|
|---|
