| 1 | (in-package "ELISP-INTERNALS")
|
|---|
| 2 |
|
|---|
| 3 | (defvar *my-symbols* nil)
|
|---|
| 4 | (defvar *cl-symbols* nil)
|
|---|
| 5 | (defvar *cl-kluge-symbols* nil)
|
|---|
| 6 | (defvar *autoloads* (make-hash-table))
|
|---|
| 7 |
|
|---|
| 8 | (cl:defun find-lambda-list-variables (list)
|
|---|
| 9 | (loop for elem in list
|
|---|
| 10 | if (and (symbolp elem)
|
|---|
| 11 | (not (member elem '(&optional &rest))))
|
|---|
| 12 | collect elem))
|
|---|
| 13 |
|
|---|
| 14 | (cl:defun generate-cl-package ()
|
|---|
| 15 | (when (and (null *my-symbols*)
|
|---|
| 16 | (null *cl-symbols*)
|
|---|
| 17 | (null *cl-kluge-symbols*))
|
|---|
| 18 | (setf *my-symbols* (make-hash-table :test 'equal))
|
|---|
| 19 | (loop for sym being the present-symbols of (find-package "ELISP")
|
|---|
| 20 | do (cl:let ((name (symbol-name sym)))
|
|---|
| 21 | (setf (gethash name *my-symbols*) name)))
|
|---|
| 22 | (setf *cl-kluge-symbols*
|
|---|
| 23 | (loop for sym being the external-symbol
|
|---|
| 24 | of (find-package "COMMON-LISP")
|
|---|
| 25 | collect sym))
|
|---|
| 26 | (setf *cl-symbols*
|
|---|
| 27 | (loop for sym in *cl-kluge-symbols*
|
|---|
| 28 | when (and (not (gethash (symbol-name sym) *my-symbols*))
|
|---|
| 29 | (fboundp sym))
|
|---|
| 30 | collect (symbol-name sym)))
|
|---|
| 31 | (cl:let ((rv (with-output-to-string (s)
|
|---|
| 32 | (format s "(in-package \"ELISP\")~%")
|
|---|
| 33 | (loop for symname in *cl-symbols*
|
|---|
| 34 | do
|
|---|
| 35 | (format s "(cl:defmacro cl-~a (&rest args)~%`(cl:~a ,@args))~%~%~%" symname symname)
|
|---|
| 36 | finally (format s "(export '~a (find-package \"ELISP\"))~%" *cl-kluge-symbols*)))))
|
|---|
| 37 | (with-input-from-string (stream rv)
|
|---|
| 38 | (load stream)))))
|
|---|
| 39 |
|
|---|
| 40 | (cl:defun require-load (directory feature filename)
|
|---|
| 41 | (if filename
|
|---|
| 42 | (cl:let ((fname (format nil "~a/~a" directory filename)))
|
|---|
| 43 | (when (cl:probe-file fname)
|
|---|
| 44 | (cl:let ((*package* (cl:find-package "ELISP-USER")))
|
|---|
| 45 | (load fname)
|
|---|
| 46 | (cl:if (member feature elisp::features)
|
|---|
| 47 | feature))))
|
|---|
| 48 | (cl:let ((fname-1
|
|---|
| 49 | (format nil "~a.el" (cl:string-downcase feature)))
|
|---|
| 50 | (fname-2
|
|---|
| 51 | (format nil "~a" (cl:string-downcase feature))))
|
|---|
| 52 | (or (require-load directory feature fname-1)
|
|---|
| 53 | (require-load directory feature fname-2)))))
|
|---|
| 54 |
|
|---|
| 55 | ;;; Almost there!
|
|---|
| 56 | ;;; Basic thought: "generate a lambda expression that acts as a shim"
|
|---|
| 57 | ;;; NB: Does not handle "*" (read-only buffer signals error) or
|
|---|
| 58 | ;;; "@" (magic find-window-specifying--set-window indicator)
|
|---|
| 59 | (cl:defun interactive-glue (initform function)
|
|---|
| 60 | (if initform
|
|---|
| 61 | (cl:let ((args (cl:with-input-from-string (s initform)
|
|---|
| 62 | (cl:loop for l = (cl:read-line s nil nil)
|
|---|
| 63 | while l collect l))))
|
|---|
| 64 | (multiple-value-bind (types prompt)
|
|---|
| 65 | (cl:loop for l in args
|
|---|
| 66 | collect (aref l 0) into type
|
|---|
| 67 | collect (subseq l 1) into prompt
|
|---|
| 68 | finally (return (values type prompt)))
|
|---|
| 69 | `(lambda (p)
|
|---|
| 70 | (funcall #',function
|
|---|
| 71 | ,@(cl:loop for type in types
|
|---|
| 72 | for pr in prompt
|
|---|
| 73 | for extracollect = nil
|
|---|
| 74 | collect
|
|---|
| 75 | (case type
|
|---|
| 76 | (#\a ;; unimplemented -- function
|
|---|
| 77 | )
|
|---|
| 78 | (#\b ;; existing buffer
|
|---|
| 79 | `(hemlock-internals:prompt-for-buffer
|
|---|
| 80 | :prompt :pr
|
|---|
| 81 | :must-exist nil))
|
|---|
| 82 | (#\B ; unimplemented -- buffer name
|
|---|
| 83 | ; Note, this may need a wrapper to
|
|---|
| 84 | ; coerce stuff to buffers
|
|---|
| 85 | `(hemlock-internals:prompt-for-buffer
|
|---|
| 86 | :prompt :pr
|
|---|
| 87 | :must-exist nil))
|
|---|
| 88 | (#\c ;; unimplemented -- character
|
|---|
| 89 | )
|
|---|
| 90 | (#\d '(hemlock-internals::current-point))
|
|---|
| 91 | (#\D ;; unimplemented -- directory name
|
|---|
| 92 | )
|
|---|
| 93 | (#\e ;; unimplemented -- event
|
|---|
| 94 | )
|
|---|
| 95 | (#\f ;; existing file
|
|---|
| 96 | `(hemlock-internals:prompt-for-file
|
|---|
| 97 | :prompt ,pr
|
|---|
| 98 | :must-exist t))
|
|---|
| 99 | (#\F ;; file name
|
|---|
| 100 | `(hemlock-internals:prompt-for-file
|
|---|
| 101 | :prompt ,pr
|
|---|
| 102 | :must-exist nil))
|
|---|
| 103 | (#\i nil)
|
|---|
| 104 | (#\k ;; unimplemented -- key sequence
|
|---|
| 105 | )
|
|---|
| 106 | (#\K ;; unimplemented -- key sequence
|
|---|
| 107 | )
|
|---|
| 108 | (#\m '(hemlock::current-mark))
|
|---|
| 109 | (#\M ;; any string
|
|---|
| 110 | `(hemlock-internals:prompt-for-string
|
|---|
| 111 | :prompt ,pr))
|
|---|
| 112 | (#\n ;; number read
|
|---|
| 113 | `(hemlock-internals:prompt-for-integer
|
|---|
| 114 | :prompt ,pr))
|
|---|
| 115 | (#\N ;; raw prefix or #\n
|
|---|
| 116 | `(cl:if p
|
|---|
| 117 | p
|
|---|
| 118 | (hemlock-internals:prompt-for-integer
|
|---|
| 119 | :prompt ,pr)))
|
|---|
| 120 | (#\p ;; raw prefix as number
|
|---|
| 121 | '(cl:if p p 0))
|
|---|
| 122 | (#\P 'p)
|
|---|
| 123 | (#\r
|
|---|
| 124 | (setf extracollect
|
|---|
| 125 | '(cl:let ((mark (hemlock::current-mark))
|
|---|
| 126 | (point (hemlock-internals::current-point)))
|
|---|
| 127 | (if (<= (hemlock-internals::mark-charpos mark)
|
|---|
| 128 | (hemlock-internals::mark-charpos point))
|
|---|
| 129 | point
|
|---|
| 130 | mark)))
|
|---|
| 131 | '(cl:let ((mark (hemlock::current-mark))
|
|---|
| 132 | (point (hemlock-internals::current-point)))
|
|---|
| 133 | (if (<= (hemlock-internals::mark-charpos mark)
|
|---|
| 134 | (hemlock-internals::mark-charpos point))
|
|---|
| 135 | mark
|
|---|
| 136 | point)))
|
|---|
| 137 | (#\s ; any string
|
|---|
| 138 | `(hemlock-internals:prompt-for-string
|
|---|
| 139 | :prompt ,pr))
|
|---|
| 140 | (#\S ; any symbol
|
|---|
| 141 | `(intern (hemlock-internals:prompt-for-string
|
|---|
| 142 | :prompt ,pr)
|
|---|
| 143 | *package*))
|
|---|
| 144 | (#\v ; variable name
|
|---|
| 145 | `(hemlock-internals:prompt-for-variable
|
|---|
| 146 | :prompt ,pr)
|
|---|
| 147 | )
|
|---|
| 148 | (#\x ; lisp expr read but not eval
|
|---|
| 149 | `(hemlock-internals:prompt-for-expression
|
|---|
| 150 | :prompt ,pr))
|
|---|
| 151 | (#\X ; lisp expr, read and evalled
|
|---|
| 152 | `(eval (hemlock-internals:prompt-for-expression
|
|---|
| 153 | :prompt ,pr))
|
|---|
| 154 | ))
|
|---|
| 155 | if extracollect
|
|---|
| 156 | collect extracollect
|
|---|
| 157 | )))))
|
|---|
| 158 | `(lambda (arg) (declare (ignore arg)) (,function))))
|
|---|
| 159 |
|
|---|
| 160 | (defun get-user-homedir (&optional username)
|
|---|
| 161 | (unless username
|
|---|
| 162 | (user-homedir-pathname)))
|
|---|
