sly-parse.el (14522B)
1 ;; -*- lexical-binding: t; -*- 2 (require 'sly) 3 (require 'cl-lib) 4 5 (defun sly-parse-form-until (limit form-suffix) 6 "Parses form from point to `limit'." 7 ;; For performance reasons, this function does not use recursion. 8 (let ((todo (list (point))) ; stack of positions 9 (sexps) ; stack of expressions 10 (cursexp) 11 (curpos) 12 (depth 1)) ; This function must be called from the 13 ; start of the sexp to be parsed. 14 (while (and (setq curpos (pop todo)) 15 (progn 16 (goto-char curpos) 17 ;; (Here we also move over suppressed 18 ;; reader-conditionalized code! Important so CL-side 19 ;; of autodoc won't see that garbage.) 20 (ignore-errors (sly-forward-cruft)) 21 (< (point) limit))) 22 (setq cursexp (pop sexps)) 23 (cond 24 ;; End of an sexp? 25 ((and (or (looking-at "\\s)") (eolp)) sexps) 26 (cl-decf depth) 27 (push (nreverse cursexp) (car sexps))) 28 ;; Start of a new sexp? 29 ((looking-at "\\(\\s'\\|@\\)*\\s(") 30 (let ((subpt (match-end 0))) 31 (ignore-errors 32 (forward-sexp) 33 ;; (In case of error, we're at an incomplete sexp, and 34 ;; nothing's left todo after it.) 35 (push (point) todo)) 36 (push cursexp sexps) 37 (push subpt todo) ; to descend into new sexp 38 (push nil sexps) 39 (cl-incf depth))) 40 ;; In mid of an sexp.. 41 (t 42 (let ((pt1 (point)) 43 (pt2 (condition-case e 44 (progn (forward-sexp) (point)) 45 (scan-error 46 (cl-fourth e))))) ; end of sexp 47 (push (buffer-substring-no-properties pt1 pt2) cursexp) 48 (push pt2 todo) 49 (push cursexp sexps))))) 50 (when sexps 51 (setf (car sexps) (cl-nreconc form-suffix (car sexps))) 52 (while (> depth 1) 53 (push (nreverse (pop sexps)) (car sexps)) 54 (cl-decf depth)) 55 (nreverse (car sexps))))) 56 57 (defun sly-compare-char-syntax (get-char-fn syntax &optional unescaped) 58 "Returns t if the character that `get-char-fn' yields has 59 characer syntax of `syntax'. If `unescaped' is true, it's ensured 60 that the character is not escaped." 61 (let ((char (funcall get-char-fn (point))) 62 (char-before (funcall get-char-fn (1- (point))))) 63 (if (and char (eq (char-syntax char) (aref syntax 0))) 64 (if unescaped 65 (or (null char-before) 66 (not (eq (char-syntax char-before) ?\\))) 67 t) 68 nil))) 69 70 (defconst sly-cursor-marker 'slynk::%cursor-marker%) 71 72 ;; FIXME: stop this madness and just use `syntax-ppss' 73 ;; 74 (defun sly-parse-form-upto-point (&optional max-levels) 75 (save-restriction 76 (let ((ppss (syntax-ppss))) 77 ;; Don't parse more than 500 lines before point, so we don't spend 78 ;; too much time. NB. Make sure to go to beginning of line, and 79 ;; not possibly anywhere inside comments or strings. 80 (narrow-to-region (line-beginning-position -500) (point-max)) 81 (save-excursion 82 (let ((suffix (list sly-cursor-marker))) 83 (cond ((sly-compare-char-syntax #'char-after "(" t) 84 ;; We're at the start of some expression, so make sure 85 ;; that SLYNK::%CURSOR-MARKER% will come after that 86 ;; expression. If the expression is not balanced, make 87 ;; still sure that the marker does *not* come directly 88 ;; after the preceding expression. 89 (or (ignore-errors (forward-sexp) t) 90 (push "" suffix))) 91 ((or (bolp) (sly-compare-char-syntax #'char-before " " t)) 92 ;; We're after some expression, so we have to make sure 93 ;; that %CURSOR-MARKER% does *not* come directly after 94 ;; that expression. 95 (push "" suffix)) 96 ((sly-compare-char-syntax #'char-before "(" t) 97 ;; We're directly after an opening parenthesis, so we 98 ;; have to make sure that something comes before 99 ;; %CURSOR-MARKER%. 100 (push "" suffix)) 101 (t 102 ;; We're at a symbol, so make sure we get the whole symbol. 103 (sly-end-of-symbol))) 104 (let ((pt (point))) 105 (unless (zerop (car ppss)) 106 (ignore-errors (up-list (if max-levels (- max-levels) -5)))) 107 (ignore-errors (down-list)) 108 (sly-parse-form-until pt suffix))))))) 109 110 ;;;; Test cases 111 (defun sly-extract-context () 112 "Parse the context for the symbol at point. 113 Nil is returned if there's no symbol at point. Otherwise we detect 114 the following cases (the . shows the point position): 115 116 (defun n.ame (...) ...) -> (:defun name) 117 (defun (setf n.ame) (...) ...) -> (:defun (setf name)) 118 (defmethod n.ame (...) ...) -> (:defmethod name (...)) 119 (defun ... (...) (labels ((n.ame (...) -> (:labels (:defun ...) name) 120 (defun ... (...) (flet ((n.ame (...) -> (:flet (:defun ...) name) 121 (defun ... (...) ... (n.ame ...) ...) -> (:call (:defun ...) name) 122 (defun ... (...) ... (setf (n.ame ...) -> (:call (:defun ...) (setf name)) 123 124 (defmacro n.ame (...) ...) -> (:defmacro name) 125 (defsetf n.ame (...) ...) -> (:defsetf name) 126 (define-setf-expander n.ame (...) ...) -> (:define-setf-expander name) 127 (define-modify-macro n.ame (...) ...) -> (:define-modify-macro name) 128 (define-compiler-macro n.ame (...) ...) -> (:define-compiler-macro name) 129 (defvar n.ame (...) ...) -> (:defvar name) 130 (defparameter n.ame ...) -> (:defparameter name) 131 (defconstant n.ame ...) -> (:defconstant name) 132 (defclass n.ame ...) -> (:defclass name) 133 (defstruct n.ame ...) -> (:defstruct name) 134 (defpackage n.ame ...) -> (:defpackage name) 135 For other contexts we return the symbol at point." 136 (let ((name (sly-symbol-at-point))) 137 (if name 138 (let ((symbol (read name))) 139 (or (progn ;;ignore-errors 140 (sly-parse-context symbol)) 141 symbol))))) 142 143 (defun sly-parse-context (name) 144 (save-excursion 145 (cond ((sly-in-expression-p '(defun *)) `(:defun ,name)) 146 ((sly-in-expression-p '(defmacro *)) `(:defmacro ,name)) 147 ((sly-in-expression-p '(defgeneric *)) `(:defgeneric ,name)) 148 ((sly-in-expression-p '(setf *)) 149 ;;a setf-definition, but which? 150 (backward-up-list 1) 151 (sly-parse-context `(setf ,name))) 152 ((sly-in-expression-p '(defmethod *)) 153 (unless (looking-at "\\s ") 154 (forward-sexp 1)) ; skip over the methodname 155 (let (qualifiers arglist) 156 (cl-loop for e = (read (current-buffer)) 157 until (listp e) do (push e qualifiers) 158 finally (setq arglist e)) 159 `(:defmethod ,name ,@qualifiers 160 ,(sly-arglist-specializers arglist)))) 161 ((and (symbolp name) 162 (sly-in-expression-p `(,name))) 163 ;; looks like a regular call 164 (let ((toplevel (ignore-errors (sly-parse-toplevel-form)))) 165 (cond ((sly-in-expression-p `(setf (*))) ;a setf-call 166 (if toplevel 167 `(:call ,toplevel (setf ,name)) 168 `(setf ,name))) 169 ((not toplevel) 170 name) 171 ((sly-in-expression-p `(labels ((*)))) 172 `(:labels ,toplevel ,name)) 173 ((sly-in-expression-p `(flet ((*)))) 174 `(:flet ,toplevel ,name)) 175 (t 176 `(:call ,toplevel ,name))))) 177 ((sly-in-expression-p '(define-compiler-macro *)) 178 `(:define-compiler-macro ,name)) 179 ((sly-in-expression-p '(define-modify-macro *)) 180 `(:define-modify-macro ,name)) 181 ((sly-in-expression-p '(define-setf-expander *)) 182 `(:define-setf-expander ,name)) 183 ((sly-in-expression-p '(defsetf *)) 184 `(:defsetf ,name)) 185 ((sly-in-expression-p '(defvar *)) `(:defvar ,name)) 186 ((sly-in-expression-p '(defparameter *)) `(:defparameter ,name)) 187 ((sly-in-expression-p '(defconstant *)) `(:defconstant ,name)) 188 ((sly-in-expression-p '(defclass *)) `(:defclass ,name)) 189 ((sly-in-expression-p '(defpackage *)) `(:defpackage ,name)) 190 ((sly-in-expression-p '(defstruct *)) 191 `(:defstruct ,(if (consp name) 192 (car name) 193 name))) 194 (t 195 name)))) 196 197 198 (defun sly-in-expression-p (pattern) 199 "A helper function to determine the current context. 200 The pattern can have the form: 201 pattern ::= () ;matches always 202 | (*) ;matches inside a list 203 | (<symbol> <pattern>) ;matches if the first element in 204 ; the current list is <symbol> and 205 ; if <pattern> matches. 206 | ((<pattern>)) ;matches if we are in a nested list." 207 (save-excursion 208 (let ((path (reverse (sly-pattern-path pattern)))) 209 (cl-loop for p in path 210 always (ignore-errors 211 (cl-etypecase p 212 (symbol (sly-beginning-of-list) 213 (eq (read (current-buffer)) p)) 214 (number (backward-up-list p) 215 t))))))) 216 217 (defun sly-pattern-path (pattern) 218 ;; Compute the path to the * in the pattern to make matching 219 ;; easier. The path is a list of symbols and numbers. A number 220 ;; means "(down-list <n>)" and a symbol "(look-at <sym>)") 221 (if (null pattern) 222 '() 223 (cl-etypecase (car pattern) 224 ((member *) '()) 225 (symbol (cons (car pattern) (sly-pattern-path (cdr pattern)))) 226 (cons (cons 1 (sly-pattern-path (car pattern))))))) 227 228 (defun sly-beginning-of-list (&optional up) 229 "Move backward to the beginning of the current expression. 230 Point is placed before the first expression in the list." 231 (backward-up-list (or up 1)) 232 (down-list 1) 233 (skip-syntax-forward " ")) 234 235 (defun sly-end-of-list (&optional up) 236 (backward-up-list (or up 1)) 237 (forward-list 1) 238 (down-list -1)) 239 240 (defun sly-parse-toplevel-form () 241 (ignore-errors ; (foo) 242 (save-excursion 243 (goto-char (car (sly-region-for-defun-at-point))) 244 (down-list 1) 245 (forward-sexp 1) 246 (sly-parse-context (read (current-buffer)))))) 247 248 (defun sly-arglist-specializers (arglist) 249 (cond ((or (null arglist) 250 (member (cl-first arglist) '(&optional &key &rest &aux))) 251 (list)) 252 ((consp (cl-first arglist)) 253 (cons (cl-second (cl-first arglist)) 254 (sly-arglist-specializers (cl-rest arglist)))) 255 (t 256 (cons 't 257 (sly-arglist-specializers (cl-rest arglist)))))) 258 259 (defun sly-definition-at-point (&optional only-functional) 260 "Return object corresponding to the definition at point." 261 (let ((toplevel (sly-parse-toplevel-form))) 262 (if (or (symbolp toplevel) 263 (and only-functional 264 (not (member (car toplevel) 265 '(:defun :defgeneric :defmethod 266 :defmacro :define-compiler-macro))))) 267 (error "Not in a definition") 268 (sly-dcase toplevel 269 (((:defun :defgeneric) symbol) 270 (format "#'%s" symbol)) 271 (((:defmacro :define-modify-macro) symbol) 272 (format "(macro-function '%s)" symbol)) 273 ((:define-compiler-macro symbol) 274 (format "(compiler-macro-function '%s)" symbol)) 275 ((:defmethod symbol &rest args) 276 (declare (ignore args)) 277 (format "#'%s" symbol)) 278 (((:defparameter :defvar :defconstant) symbol) 279 (format "'%s" symbol)) 280 (((:defclass :defstruct) symbol) 281 (format "(find-class '%s)" symbol)) 282 ((:defpackage symbol) 283 (format "(or (find-package '%s) (error \"Package %s not found\"))" 284 symbol symbol)) 285 (t 286 (error "Not in a definition")))))) 287 288 (defsubst sly-current-parser-state () 289 ;; `syntax-ppss' does not save match data as it invokes 290 ;; `beginning-of-defun' implicitly which does not save match 291 ;; data. This issue has been reported to the Emacs maintainer on 292 ;; Feb27. 293 (syntax-ppss)) 294 295 (defun sly-inside-string-p () 296 (nth 3 (sly-current-parser-state))) 297 298 (defun sly-inside-comment-p () 299 (nth 4 (sly-current-parser-state))) 300 301 (defun sly-inside-string-or-comment-p () 302 (let ((state (sly-current-parser-state))) 303 (or (nth 3 state) (nth 4 state)))) 304 305 ;;; The following two functions can be handy when inspecting 306 ;;; source-location while debugging `M-.'. 307 ;;; 308 (defun sly-current-tlf-number () 309 "Return the current toplevel number." 310 (interactive) 311 (let ((original-pos (car (sly-region-for-defun-at-point))) 312 (n 0)) 313 (save-excursion 314 ;; We use this and no repeated `beginning-of-defun's to get 315 ;; reader conditionals right. 316 (goto-char (point-min)) 317 (while (progn (sly-forward-sexp) 318 (< (point) original-pos)) 319 (cl-incf n))) 320 n)) 321 322 ;;; This is similiar to `sly-enclosing-form-paths' in the 323 ;;; `sly-parse' contrib except that this does not do any duck-tape 324 ;;; parsing, and gets reader conditionals right. 325 (defun sly-current-form-path () 326 "Returns the path from the beginning of the current toplevel 327 form to the atom at point, or nil if we're in front of a tlf." 328 (interactive) 329 (let ((source-path nil)) 330 (save-excursion 331 ;; Moving forward to get reader conditionals right. 332 (cl-loop for inner-pos = (point) 333 for outer-pos = (cl-nth-value 1 (sly-current-parser-state)) 334 while outer-pos do 335 (goto-char outer-pos) 336 (unless (eq (char-before) ?#) ; when at #(...) continue. 337 (forward-char) 338 (let ((n 0)) 339 (while (progn (sly-forward-sexp) 340 (< (point) inner-pos)) 341 (cl-incf n)) 342 (push n source-path) 343 (goto-char outer-pos))))) 344 source-path)) 345 346 347 ;;; Compile hotspots 348 ;;; 349 (sly-byte-compile-hotspots 350 '(sly-parse-form-upto-point 351 sly-parse-form-until 352 sly-compare-char-syntax)) 353 354 355 (provide 'sly-parse)