├── .github └── workflows │ └── lint.yml ├── .gitignore ├── LICENSE ├── README.md ├── backend ├── abcl.lisp ├── allegro.lisp ├── backend.lisp ├── ccl.lisp ├── clasp.lisp ├── clisp.lisp ├── cmucl.lisp ├── corman.lisp ├── ecl.lisp ├── gray.lisp ├── lispworks.lisp ├── match.lisp ├── mezzano.lisp ├── mkcl.lisp ├── rpc.lisp ├── sbcl.lisp ├── scl.lisp ├── source-file-cache.lisp └── source-path-parser.lisp ├── contrib ├── micros-arglists.lisp ├── micros-asdf.lisp ├── micros-buffer-streams.lisp ├── micros-c-p-c.lisp ├── micros-clipboard.lisp ├── micros-fancy-inspector.lisp ├── micros-fuzzy.lisp ├── micros-hyperdoc.lisp ├── micros-indentation.lisp ├── micros-listener-hooks.lisp ├── micros-macrostep.lisp ├── micros-mrepl.lisp ├── micros-package-fu.lisp ├── micros-presentation-streams.lisp ├── micros-presentations.lisp ├── micros-pretty-eval.lisp ├── micros-repl.lisp ├── micros-sbcl-exts.lisp ├── micros-snapshot.lisp ├── micros-sprof.lisp ├── micros-systems.lisp ├── micros-test-runner.lisp ├── micros-trace-dialog.lisp ├── micros-trace.lisp ├── micros-util.lisp └── walker │ ├── TODO │ ├── data-and-control-flow.lisp │ ├── defmethod-form.lisp │ ├── defun-form.lisp │ ├── example.lisp │ ├── loop-form.lisp │ ├── package.lisp │ ├── tests │ ├── test-cases.lisp │ └── tests.lisp │ ├── types.lisp │ ├── utils.lisp │ └── walker.lisp ├── lsp-api-load-systems.lisp ├── lsp-api.lisp ├── micros.asd ├── micros.lisp └── packages.lisp /.github/workflows/lint.yml: -------------------------------------------------------------------------------- 1 | # This is a basic workflow to help you get started with Actions 2 | 3 | name: CI 4 | 5 | # Controls when the workflow will run 6 | on: 7 | # Triggers the workflow on push or pull request events but only for the "main" branch 8 | push: 9 | branches: [ "*" ] 10 | pull_request: 11 | branches: [ "*" ] 12 | 13 | # Allows you to run this workflow manually from the Actions tab 14 | workflow_dispatch: 15 | 16 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 17 | jobs: 18 | # This workflow contains a single job called "build" 19 | build: 20 | # The type of runner that the job will run on 21 | runs-on: ubuntu-latest 22 | 23 | # Steps represent a sequence of tasks that will be executed as part of the job 24 | steps: 25 | # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it 26 | - uses: actions/checkout@v3 27 | - name: Install Roswell 28 | env: 29 | LISP: ${{ matrix.lisp }} 30 | run: | 31 | curl -L https://raw.githubusercontent.com/roswell/roswell/v22.12.14.113/scripts/install-for-ci.sh | sh 32 | 33 | # Runs a set of commands using the runners shell 34 | - name: Run a multi-line script 35 | run: | 36 | export PATH=$HOME/.roswell/bin:$PATH 37 | ros install cxxxr/sblint 38 | mkdir $HOME/common-lisp 39 | cd $HOME/common-lisp 40 | git clone https://github.com/lem-project/micros.git 41 | cd micros 42 | sblint 43 | 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.fasl 3 | *.abcl 4 | *.abcl-tmp 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 lem-project 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # micros 2 | Micro slime/swank with forked SLIME 3 | 4 | ## Motivation 5 | ### Tight coupling of slime with emacs 6 | https://github.com/lem-project/lem/issues/688 7 | 8 | With every version update of SLIME, incompatible changes are being made. 9 | Up to version v2.27, it worked fine with Lem, but there seems to be quite a drastic change from around v2.28, and the behavior has changed. 10 | For example, a significant disruptive change in the past can be found at slime/slime@78ad57b. 11 | If not addressed on the client-side, the REPL will hang up. 12 | Also, the output to the REPL has become a bottleneck, and asdf:load-system has become considerably slow. 13 | Besides, there are other areas where behavior has changed due to minor changes in behavior. 14 | 15 | As a policy of SLIME, it is strongly integrated with Emacs, and it seems that it does not consider other implementations much. 16 | Continually keeping up with updates to SLIME is too costly and unrealistic, but if left unattended, it will stop working, so constant response is required. 17 | 18 | ### lem's own extensions 19 | By separating it from SLIME and making it a separate project, 20 | it will be easier to add custom features to Lem. This is useful, 21 | for example, when adding functionality for the Language Server Protocol. 22 | 23 | ## License 24 | MIT 25 | -------------------------------------------------------------------------------- /backend/gray.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; swank-gray.lisp --- Gray stream based IO redirection. 4 | ;;; 5 | ;;; Created 2003 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package micros/backend) 12 | 13 | #.(progn 14 | (defvar *gray-stream-symbols* 15 | '(fundamental-character-output-stream 16 | stream-write-char 17 | stream-write-string 18 | stream-fresh-line 19 | stream-force-output 20 | stream-finish-output 21 | 22 | fundamental-character-input-stream 23 | stream-read-char 24 | stream-peek-char 25 | stream-read-line 26 | stream-listen 27 | stream-unread-char 28 | stream-clear-input 29 | stream-line-column 30 | stream-read-char-no-hang 31 | 32 | #+sbcl stream-file-position)) 33 | nil) 34 | 35 | (defpackage micros/gray 36 | (:use cl micros/backend) 37 | (:import-from #.(gray-package-name) . #.*gray-stream-symbols*) 38 | (:export . #.*gray-stream-symbols*)) 39 | 40 | (in-package micros/gray) 41 | 42 | (defclass slime-output-stream (fundamental-character-output-stream) 43 | ((output-fn :initarg :output-fn) 44 | (buffer :initform (make-string 8000)) 45 | (fill-pointer :initform 0) 46 | (column :initform 0) 47 | (lock :initform (make-lock :name "buffer write lock")) 48 | (flush-thread :initarg :flush-thread 49 | :initform nil 50 | :accessor flush-thread) 51 | (flush-scheduled :initarg :flush-scheduled 52 | :initform nil 53 | :accessor flush-scheduled))) 54 | 55 | (defun maybe-schedule-flush (stream) 56 | (when (and (flush-thread stream) 57 | (not (flush-scheduled stream))) 58 | (setf (flush-scheduled stream) t) 59 | (send (flush-thread stream) t))) 60 | 61 | (defmacro with-slime-output-stream (stream &body body) 62 | `(with-slots (lock output-fn buffer fill-pointer column) ,stream 63 | (call-with-lock-held lock (lambda () ,@body)))) 64 | 65 | (defmethod stream-write-char ((stream slime-output-stream) char) 66 | (with-slime-output-stream stream 67 | (setf (schar buffer fill-pointer) char) 68 | (incf fill-pointer) 69 | (incf column) 70 | (when (char= #\newline char) 71 | (setf column 0)) 72 | (if (= fill-pointer (length buffer)) 73 | (finish-output stream) 74 | (maybe-schedule-flush stream))) 75 | char) 76 | 77 | (defmethod stream-write-string ((stream slime-output-stream) string 78 | &optional start end) 79 | (with-slime-output-stream stream 80 | (let* ((start (or start 0)) 81 | (end (or end (length string))) 82 | (len (length buffer)) 83 | (count (- end start)) 84 | (free (- len fill-pointer))) 85 | (when (>= count free) 86 | (stream-finish-output stream)) 87 | (cond ((< count len) 88 | (replace buffer string :start1 fill-pointer 89 | :start2 start :end2 end) 90 | (incf fill-pointer count) 91 | (maybe-schedule-flush stream)) 92 | (t 93 | (funcall output-fn (subseq string start end)))) 94 | (let ((last-newline (position #\newline string :from-end t 95 | :start start :end end))) 96 | (setf column (if last-newline 97 | (- end last-newline 1) 98 | (+ column count)))))) 99 | string) 100 | 101 | (defmethod stream-line-column ((stream slime-output-stream)) 102 | (with-slime-output-stream stream column)) 103 | 104 | (defmethod stream-finish-output ((stream slime-output-stream)) 105 | (with-slime-output-stream stream 106 | (unless (zerop fill-pointer) 107 | (funcall output-fn (subseq buffer 0 fill-pointer)) 108 | (setf fill-pointer 0)) 109 | (setf (flush-scheduled stream) nil)) 110 | nil) 111 | 112 | #+(and sbcl sb-thread) 113 | (defmethod stream-force-output :around ((stream slime-output-stream)) 114 | ;; Workaround for deadlocks between the world-lock and auto-flush-thread 115 | ;; buffer write lock. 116 | ;; 117 | ;; Another alternative would be to grab the world-lock here, but that's less 118 | ;; future-proof, and could introduce other lock-ordering issues in the 119 | ;; future. 120 | (handler-case 121 | (sb-sys:with-deadline (:seconds 0.1) 122 | (call-next-method)) 123 | (sb-sys:deadline-timeout () 124 | nil))) 125 | 126 | (defmethod stream-force-output ((stream slime-output-stream)) 127 | (stream-finish-output stream)) 128 | 129 | (defmethod stream-fresh-line ((stream slime-output-stream)) 130 | (with-slime-output-stream stream 131 | (cond ((zerop column) nil) 132 | (t (terpri stream) t)))) 133 | 134 | #+sbcl 135 | (defmethod stream-file-position ((stream slime-output-stream) &optional position) 136 | (declare (ignore position)) 137 | nil) 138 | 139 | (defclass slime-input-stream (fundamental-character-input-stream) 140 | ((input-fn :initarg :input-fn) 141 | (buffer :initform "") (index :initform 0) 142 | (lock :initform (make-lock :name "buffer read lock")))) 143 | 144 | (defmethod stream-read-char ((s slime-input-stream)) 145 | (call-with-lock-held 146 | (slot-value s 'lock) 147 | (lambda () 148 | (with-slots (buffer index input-fn) s 149 | (when (= index (length buffer)) 150 | (let ((string (funcall input-fn))) 151 | (cond ((zerop (length string)) 152 | (return-from stream-read-char :eof)) 153 | (t 154 | (setf buffer string) 155 | (setf index 0))))) 156 | (assert (plusp (length buffer))) 157 | (prog1 (aref buffer index) (incf index)))))) 158 | 159 | (defmethod stream-listen ((s slime-input-stream)) 160 | (call-with-lock-held 161 | (slot-value s 'lock) 162 | (lambda () 163 | (with-slots (buffer index) s 164 | (< index (length buffer)))))) 165 | 166 | (defmethod stream-unread-char ((s slime-input-stream) char) 167 | (call-with-lock-held 168 | (slot-value s 'lock) 169 | (lambda () 170 | (with-slots (buffer index) s 171 | (decf index) 172 | (cond ((eql (aref buffer index) char) 173 | (setf (aref buffer index) char)) 174 | (t 175 | (warn "stream-unread-char: ignoring ~S (expected ~S)" 176 | char (aref buffer index))))))) 177 | nil) 178 | 179 | (defmethod stream-clear-input ((s slime-input-stream)) 180 | (call-with-lock-held 181 | (slot-value s 'lock) 182 | (lambda () 183 | (with-slots (buffer index) s 184 | (setf buffer "" 185 | index 0)))) 186 | nil) 187 | 188 | (defmethod stream-line-column ((s slime-input-stream)) 189 | nil) 190 | 191 | (defmethod stream-read-char-no-hang ((s slime-input-stream)) 192 | (call-with-lock-held 193 | (slot-value s 'lock) 194 | (lambda () 195 | (with-slots (buffer index) s 196 | (when (< index (length buffer)) 197 | (prog1 (aref buffer index) (incf index))))))) 198 | 199 | #+sbcl 200 | (defmethod stream-file-position ((stream slime-input-stream) &optional position) 201 | (declare (ignore position)) 202 | nil) 203 | 204 | 205 | ;;; 206 | 207 | (defimplementation make-auto-flush-thread (stream) 208 | (if (typep stream 'slime-output-stream) 209 | (setf (flush-thread stream) 210 | (spawn (lambda () (auto-flush-loop stream 0.08 t)) 211 | :name "auto-flush-thread")) 212 | (spawn (lambda () (auto-flush-loop stream *auto-flush-interval*)) 213 | :name "auto-flush-thread"))) 214 | 215 | (defimplementation make-output-stream (write-string) 216 | (make-instance 'slime-output-stream :output-fn write-string)) 217 | 218 | (defimplementation make-input-stream (read-string) 219 | (make-instance 'slime-input-stream :input-fn read-string)) 220 | -------------------------------------------------------------------------------- /backend/match.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; SELECT-MATCH macro (and IN macro) 3 | ;; 4 | ;; Copyright 1990 Stephen Adams 5 | ;; 6 | ;; You are free to copy, distribute and make derivative works of this 7 | ;; source provided that this copyright notice is displayed near the 8 | ;; beginning of the file. No liability is accepted for the 9 | ;; correctness or performance of the code. If you modify the code 10 | ;; please indicate this fact both at the place of modification and in 11 | ;; this copyright message. 12 | ;; 13 | ;; Stephen Adams 14 | ;; Department of Electronics and Computer Science 15 | ;; University of Southampton 16 | ;; SO9 5NH, UK 17 | ;; 18 | ;; sra@ecs.soton.ac.uk 19 | ;; 20 | 21 | ;; 22 | ;; Synopsis: 23 | ;; 24 | ;; (select-match expression 25 | ;; (pattern action+)*) 26 | ;; 27 | ;; --- or --- 28 | ;; 29 | ;; (select-match expression 30 | ;; pattern => expression 31 | ;; pattern => expression 32 | ;; ...) 33 | ;; 34 | ;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1) 35 | ;; | symbol ;matches anything 36 | ;; | 'anything ;must be EQUAL 37 | ;; | (pattern = pattern) ;both patterns must match 38 | ;; | (#'function pattern) ;predicate test 39 | ;; | (pattern . pattern) ;cons cell 40 | ;; 41 | 42 | ;; Example 43 | ;; 44 | ;; (select-match item 45 | ;; (('if e1 e2 e3) 'if-then-else) ;(1) 46 | ;; ((#'oddp k) 'an-odd-integer) ;(2) 47 | ;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3) 48 | ;; (other 'anything-else)) ;(4) 49 | ;; 50 | ;; Notes 51 | ;; 52 | ;; . Each pattern is tested in turn. The first match is taken. 53 | ;; 54 | ;; . If no pattern matches, an error is signalled. 55 | ;; 56 | ;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e. 57 | ;; numbers, strings, characters, etc.) match things which are EQUAL. 58 | ;; 59 | ;; . Quoted patterns (which are CONSTANTP) are constants. 60 | ;; 61 | ;; . Symbols match anything. The symbol is bound to the matched item 62 | ;; for the execution of the actions. 63 | ;; For example, (SELECT-MATCH '(1 2 3) 64 | ;; (1 . X) => X) 65 | ;; returns (2 3) because X is bound to the cdr of the candidate. 66 | ;; 67 | ;; . The two pattern match (p1 = p2) can be used to name parts 68 | ;; of the matched structure. For example, (ALL = (HD . TL)) 69 | ;; matches a cons cell. ALL is bound to the cons cell, HD to its car 70 | ;; and TL to its tail. 71 | ;; 72 | ;; . A predicate test applies the predicate to the item being matched. 73 | ;; If the predicate returns NIL then the match fails. 74 | ;; If it returns truth, then the nested pattern is matched. This is 75 | ;; often just a symbol like K in the example. 76 | ;; 77 | ;; . Care should be taken with the domain values for predicate matches. 78 | ;; If, in the above eg, item is not an integer, an error would occur 79 | ;; during the test. A safer pattern would be 80 | ;; (#'integerp (#'oddp k)) 81 | ;; This would only test for oddness of the item was an integer. 82 | ;; 83 | ;; . A single symbol will match anything so it can be used as a default 84 | ;; case, like OTHER above. 85 | ;; 86 | 87 | (in-package micros/match) 88 | 89 | (defmacro match (expression &body patterns) 90 | `(select-match ,expression ,@patterns)) 91 | 92 | (defmacro select-match (expression &rest patterns) 93 | (let* ((do-let (not (atom expression))) 94 | (key (if do-let (gensym) expression)) 95 | (cbody (expand-select-patterns key patterns)) 96 | (cform `(cond . ,cbody))) 97 | (if do-let 98 | `(let ((,key ,expression)) ,cform) 99 | cform))) 100 | 101 | (defun expand-select-patterns (key patterns) 102 | (if (eq (second patterns) '=>) 103 | (expand-select-patterns-style-2 key patterns) 104 | (expand-select-patterns-style-1 key patterns))) 105 | 106 | (defun expand-select-patterns-style-1 (key patterns) 107 | (if (null patterns) 108 | `((t (error "Case select pattern match failure on ~S" ,key))) 109 | (let* ((pattern (caar patterns)) 110 | (actions (cdar patterns)) 111 | (rest (cdr patterns)) 112 | (test (compile-select-test key pattern)) 113 | (bindings (compile-select-bindings key pattern actions))) 114 | `(,(if bindings `(,test (let ,bindings . ,actions)) 115 | `(,test . ,actions)) 116 | . ,(unless (eq test t) 117 | (expand-select-patterns-style-1 key rest)))))) 118 | 119 | (defun expand-select-patterns-style-2 (key patterns) 120 | (cond ((null patterns) 121 | `((t (error "Case select pattern match failure on ~S" ,key)))) 122 | (t (when (or (< (length patterns) 3) 123 | (not (eq (second patterns) '=>))) 124 | (error "Illegal patterns: ~S" patterns)) 125 | (let* ((pattern (first patterns)) 126 | (actions (list (third patterns))) 127 | (rest (cdddr patterns)) 128 | (test (compile-select-test key pattern)) 129 | (bindings (compile-select-bindings key pattern actions))) 130 | `(,(if bindings `(,test (let ,bindings . ,actions)) 131 | `(,test . ,actions)) 132 | . ,(unless (eq test t) 133 | (expand-select-patterns-style-2 key rest))))))) 134 | 135 | (defun compile-select-test (key pattern) 136 | (let ((tests (remove t (compile-select-tests key pattern)))) 137 | (cond 138 | ;; note AND does this anyway, but this allows us to tell if 139 | ;; the pattern will always match. 140 | ((null tests) t) 141 | ((= (length tests) 1) (car tests)) 142 | (t `(and . ,tests))))) 143 | 144 | (defun compile-select-tests (key pattern) 145 | (cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql) 146 | ((symbolp pattern) 'eq) 147 | (t 'equal)) 148 | ,key ,pattern))) 149 | ((symbolp pattern) '(t)) 150 | ((select-double-match? pattern) 151 | (append 152 | (compile-select-tests key (first pattern)) 153 | (compile-select-tests key (third pattern)))) 154 | ((select-predicate? pattern) 155 | (append 156 | `((,(second (first pattern)) ,key)) 157 | (compile-select-tests key (second pattern)))) 158 | ((consp pattern) 159 | (append 160 | `((consp ,key)) 161 | (compile-select-tests (cs-car key) (car 162 | pattern)) 163 | (compile-select-tests (cs-cdr key) (cdr 164 | pattern)))) 165 | (t (error "Illegal select pattern: ~S" pattern)))) 166 | 167 | 168 | (defun compile-select-bindings (key pattern action) 169 | (cond ((constantp pattern) '()) 170 | ((symbolp pattern) 171 | (if (select-in-tree pattern action) 172 | `((,pattern ,key)) 173 | '())) 174 | ((select-double-match? pattern) 175 | (append 176 | (compile-select-bindings key (first pattern) action) 177 | (compile-select-bindings key (third pattern) action))) 178 | ((select-predicate? pattern) 179 | (compile-select-bindings key (second pattern) action)) 180 | ((consp pattern) 181 | (append 182 | (compile-select-bindings (cs-car key) (car pattern) 183 | action) 184 | (compile-select-bindings (cs-cdr key) (cdr pattern) 185 | action))))) 186 | 187 | (defun select-in-tree (atom tree) 188 | (or (eq atom tree) 189 | (if (consp tree) 190 | (or (select-in-tree atom (car tree)) 191 | (select-in-tree atom (cdr tree)))))) 192 | 193 | (defun select-double-match? (pattern) 194 | ;; ( = ) 195 | (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern)) 196 | (null (cdddr pattern)) 197 | (eq (second pattern) '=))) 198 | 199 | (defun select-predicate? (pattern) 200 | ;; ((function ) ) 201 | (and (consp pattern) 202 | (consp (cdr pattern)) 203 | (null (cddr pattern)) 204 | (consp (first pattern)) 205 | (consp (cdr (first pattern))) 206 | (null (cddr (first pattern))) 207 | (eq (caar pattern) 'function))) 208 | 209 | (defun cs-car (exp) 210 | (cs-car/cdr 'car exp 211 | '((car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr) 212 | (cdar . cadar) (cddr . caddr) 213 | (caaar . caaaar) (caadr . caaadr) (cadar . caadar) 214 | (caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr) 215 | (cddar . caddar) (cdddr . cadddr)))) 216 | 217 | (defun cs-cdr (exp) 218 | (cs-car/cdr 'cdr exp 219 | '((car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr) 220 | (cdar . cddar) (cddr . cdddr) 221 | (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) 222 | (caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr) 223 | (cddar . cdddar) (cdddr . cddddr)))) 224 | 225 | (defun cs-car/cdr (op exp table) 226 | (if (and (consp exp) (= (length exp) 2)) 227 | (let ((replacement (assoc (car exp) table))) 228 | (if replacement 229 | `(,(cdr replacement) ,(second exp)) 230 | `(,op ,exp))) 231 | `(,op ,exp))) 232 | 233 | ;; (setf c1 '(select-match x (a 1) (b 2 3 4))) 234 | ;; (setf c2 '(select-match (car y) 235 | ;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+ 236 | ;; else)))) 237 | ;; (setf c3 '(select-match (caddr y) 238 | ;; ((all = (x y)) (list x y all)) 239 | ;; ((a '= b) (list 'assign a b)) 240 | ;; ((#'oddp k) (1+ k))))) 241 | 242 | 243 | -------------------------------------------------------------------------------- /backend/rpc.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- indent-tabs-mode: nil; coding: latin-1-unix -*- 2 | ;;; 3 | ;;; swank-rpc.lisp -- Pass remote calls and responses between lisp systems. 4 | ;;; 5 | ;;; Created 2010, Terje Norderhaug 6 | ;;; 7 | ;;; This code has been placed in the Public Domain. All warranties 8 | ;;; are disclaimed. 9 | ;;; 10 | 11 | (in-package micros/rpc) 12 | 13 | 14 | ;;;;; Input 15 | 16 | (defparameter *validate-input* nil 17 | "Set to true to require input that more strictly conforms to the protocol") 18 | 19 | (define-condition swank-reader-error (reader-error) 20 | ((packet :type string :initarg :packet 21 | :reader swank-reader-error.packet) 22 | (cause :type reader-error :initarg :cause 23 | :reader swank-reader-error.cause))) 24 | 25 | (defun read-message (stream package &key (validate-input *validate-input*)) 26 | (let ((packet (read-packet stream))) 27 | (handler-case (values (read-form packet package :validate-input validate-input)) 28 | (reader-error (c) 29 | (error 'swank-reader-error 30 | :packet packet :cause c))))) 31 | 32 | (defun read-packet (stream) 33 | (let* ((length (parse-header stream)) 34 | (octets (read-chunk stream length))) 35 | (handler-case (micros/backend:utf8-to-string octets) 36 | (error (c) 37 | (error 'swank-reader-error 38 | :packet (asciify octets) 39 | :cause c))))) 40 | 41 | (defun asciify (packet) 42 | (with-output-to-string (*standard-output*) 43 | (loop for code across (etypecase packet 44 | (string (map 'vector #'char-code packet)) 45 | (vector packet)) 46 | do (cond ((<= code #x7f) (write-char (code-char code))) 47 | (t (format t "\\x~x" code)))))) 48 | 49 | (defun parse-header (stream) 50 | (parse-integer (map 'string #'code-char (read-chunk stream 6)) 51 | :radix 16)) 52 | 53 | (defun read-chunk (stream length) 54 | (let* ((buffer (make-array length :element-type '(unsigned-byte 8))) 55 | (count (read-sequence buffer stream))) 56 | (cond ((= count length) 57 | buffer) 58 | ((zerop count) 59 | (error 'end-of-file :stream stream)) 60 | (t 61 | (error "Short read: length=~D count=~D" length count))))) 62 | 63 | (defun read-form (string package &key ((:validate-input *validate-input*) nil)) 64 | (with-standard-io-syntax 65 | (let ((*package* package)) 66 | (if *validate-input* 67 | (validating-read string) 68 | (read-from-string string))))) 69 | 70 | (defun validating-read (string) 71 | (with-input-from-string (*standard-input* string) 72 | (simple-read))) 73 | 74 | (defun simple-read () 75 | "Read a form that conforms to the protocol, otherwise signal an error." 76 | (let ((c (read-char))) 77 | (case c 78 | (#\( (loop collect (simple-read) 79 | while (ecase (read-char) 80 | (#\) nil) 81 | (#\space t)))) 82 | (#\' `(quote ,(simple-read))) 83 | (t 84 | (cond 85 | ((digit-char-p c) 86 | (parse-integer 87 | (map 'simple-string #'identity 88 | (loop for ch = c then (read-char nil nil) 89 | while (and ch (digit-char-p ch)) 90 | collect ch 91 | finally (unread-char ch))))) 92 | ((or (member c '(#\: #\")) (alpha-char-p c)) 93 | (unread-char c) 94 | (read-preserving-whitespace)) 95 | (t (error "Invalid character ~:c" c))))))) 96 | 97 | 98 | ;;;;; Output 99 | 100 | (defun write-message (message package stream) 101 | (let* ((string (prin1-to-string-for-emacs message package)) 102 | (octets (handler-case (micros/backend:string-to-utf8 string) 103 | (error (c) (encoding-error c string)))) 104 | (length (length octets))) 105 | (write-header stream length) 106 | (write-sequence octets stream) 107 | (finish-output stream))) 108 | 109 | ;; FIXME: for now just tell emacs that we and an encoding problem. 110 | (defun encoding-error (condition string) 111 | (micros/backend:string-to-utf8 112 | (prin1-to-string-for-emacs 113 | `(:reader-error 114 | ,(asciify string) 115 | ,(format nil "Error during string-to-utf8: ~a" 116 | (or (ignore-errors (asciify (princ-to-string condition))) 117 | (asciify (princ-to-string (type-of condition)))))) 118 | (find-package :cl)))) 119 | 120 | (defun write-header (stream length) 121 | (declare (type (unsigned-byte 24) length)) 122 | ;;(format *trace-output* "length: ~d (#x~x)~%" length length) 123 | (loop for c across (format nil "~6,'0x" length) 124 | do (write-byte (char-code c) stream))) 125 | 126 | (defun switch-to-double-floats (x) 127 | (typecase x 128 | (double-float x) 129 | (float (coerce x 'double-float)) 130 | (null x) 131 | (list (loop for (x . cdr) on x 132 | collect (switch-to-double-floats x) into result 133 | until (atom cdr) 134 | finally (return (append result (switch-to-double-floats cdr))))) 135 | (t x))) 136 | 137 | (defun prin1-to-string-for-emacs (object package) 138 | (with-standard-io-syntax 139 | (let ((*print-case* :downcase) 140 | (*print-readably* nil) 141 | (*print-pretty* nil) 142 | (*package* package) 143 | ;; Emacs has only double floats. 144 | (*read-default-float-format* 'double-float)) 145 | (prin1-to-string (switch-to-double-floats object))))) 146 | 147 | 148 | #| TEST/DEMO: 149 | 150 | (defparameter *transport* 151 | (with-output-to-string (out) 152 | (write-message '(:message (hello "world")) *package* out) 153 | (write-message '(:return 5) *package* out) 154 | (write-message '(:emacs-rex NIL) *package* out))) 155 | 156 | *transport* 157 | 158 | (with-input-from-string (in *transport*) 159 | (loop while (peek-char T in NIL) 160 | collect (read-message in *package*))) 161 | 162 | |# 163 | -------------------------------------------------------------------------------- /backend/source-file-cache.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-file cache 2 | ;;; 3 | ;;; To robustly find source locations in CMUCL and SBCL it's useful to 4 | ;;; have the exact source code that the loaded code was compiled from. 5 | ;;; In this source we can accurately find the right location, and from 6 | ;;; that location we can extract a "snippet" of code to show what the 7 | ;;; definition looks like. Emacs can use this snippet in a best-match 8 | ;;; search to locate the right definition, which works well even if 9 | ;;; the buffer has been modified. 10 | ;;; 11 | ;;; The idea is that if a definition previously started with 12 | ;;; `(define-foo bar' then it probably still does. 13 | ;;; 14 | ;;; Whenever we see that the file on disk has the same 15 | ;;; `file-write-date' as a location we're looking for we cache the 16 | ;;; whole file inside Lisp. That way we will still have the matching 17 | ;;; version even if the file is later modified on disk. If the file is 18 | ;;; later recompiled and reloaded then we replace our cache entry. 19 | ;;; 20 | ;;; This code has been placed in the Public Domain. All warranties 21 | ;;; are disclaimed. 22 | 23 | (defpackage micros/source-file-cache 24 | (:use cl) 25 | (:import-from micros/backend 26 | defimplementation buffer-first-change 27 | guess-external-format 28 | find-external-format) 29 | (:export 30 | get-source-code 31 | source-cache-get ;FIXME: isn't it odd that both are exported? 32 | 33 | *source-snippet-size* 34 | read-snippet 35 | read-snippet-from-string 36 | )) 37 | 38 | (in-package micros/source-file-cache) 39 | 40 | (defvar *cache-sourcecode* t 41 | "When true complete source files are cached. 42 | The cache is used to keep known good copies of the source text which 43 | correspond to the loaded code. Finding definitions is much more 44 | reliable when the exact source is available, so we cache it in case it 45 | gets edited on disk later.") 46 | 47 | (defvar *source-file-cache* (make-hash-table :test 'equal) 48 | "Cache of source file contents. 49 | Maps from truename to source-cache-entry structure.") 50 | 51 | (defstruct (source-cache-entry 52 | (:conc-name source-cache-entry.) 53 | (:constructor make-source-cache-entry (text date))) 54 | text date) 55 | 56 | (defimplementation buffer-first-change (filename) 57 | "Load a file into the cache when the user modifies its buffer. 58 | This is a win if the user then saves the file and tries to M-. into it." 59 | (unless (source-cached-p filename) 60 | (ignore-errors 61 | (source-cache-get filename (file-write-date filename)))) 62 | nil) 63 | 64 | (defun get-source-code (filename code-date) 65 | "Return the source code for FILENAME as written on DATE in a string. 66 | If the exact version cannot be found then return the current one from disk." 67 | (or (source-cache-get filename code-date) 68 | (read-file filename))) 69 | 70 | (defun source-cache-get (filename date) 71 | "Return the source code for FILENAME as written on DATE in a string. 72 | Return NIL if the right version cannot be found." 73 | (when *cache-sourcecode* 74 | (let ((entry (gethash filename *source-file-cache*))) 75 | (cond ((and entry (equal date (source-cache-entry.date entry))) 76 | ;; Cache hit. 77 | (source-cache-entry.text entry)) 78 | ((or (null entry) 79 | (not (equal date (source-cache-entry.date entry)))) 80 | ;; Cache miss. 81 | (if (equal (file-write-date filename) date) 82 | ;; File on disk has the correct version. 83 | (let ((source (read-file filename))) 84 | (setf (gethash filename *source-file-cache*) 85 | (make-source-cache-entry source date)) 86 | source) 87 | nil)))))) 88 | 89 | (defun source-cached-p (filename) 90 | "Is any version of FILENAME in the source cache?" 91 | (if (gethash filename *source-file-cache*) t)) 92 | 93 | (defun read-file (filename) 94 | "Return the entire contents of FILENAME as a string." 95 | (with-open-file (s filename :direction :input 96 | :external-format (or (guess-external-format filename) 97 | (find-external-format "latin-1") 98 | :default)) 99 | (let* ((string (make-string (file-length s))) 100 | (length (read-sequence string s))) 101 | (subseq string 0 length)))) 102 | 103 | ;;;; Snippets 104 | 105 | (defvar *source-snippet-size* 256 106 | "Maximum number of characters in a snippet of source code. 107 | Snippets at the beginning of definitions are used to tell Emacs what 108 | the definitions looks like, so that it can accurately find them by 109 | text search.") 110 | 111 | (defun read-snippet (stream &optional position) 112 | "Read a string of upto *SOURCE-SNIPPET-SIZE* characters from STREAM. 113 | If POSITION is given, set the STREAM's file position first." 114 | (when position 115 | (file-position stream position)) 116 | #+sbcl (skip-comments-and-whitespace stream) 117 | (read-upto-n-chars stream *source-snippet-size*)) 118 | 119 | (defun read-snippet-from-string (string &optional position) 120 | (with-input-from-string (s string) 121 | (read-snippet s position))) 122 | 123 | (defun skip-comments-and-whitespace (stream) 124 | (case (peek-char nil stream nil nil) 125 | ((#\Space #\Tab #\Newline #\Linefeed #\Page) 126 | (read-char stream) 127 | (skip-comments-and-whitespace stream)) 128 | (#\; 129 | (read-line stream) 130 | (skip-comments-and-whitespace stream)))) 131 | 132 | (defun read-upto-n-chars (stream n) 133 | "Return a string of upto N chars from STREAM." 134 | (let* ((string (make-string n)) 135 | (chars (read-sequence string stream))) 136 | (subseq string 0 chars))) 137 | -------------------------------------------------------------------------------- /backend/source-path-parser.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Source-paths 2 | 3 | ;;; CMUCL/SBCL use a data structure called "source-path" to locate 4 | ;;; subforms. The compiler assigns a source-path to each form in a 5 | ;;; compilation unit. Compiler notes usually contain the source-path 6 | ;;; of the error location. 7 | ;;; 8 | ;;; Compiled code objects don't contain source paths, only the 9 | ;;; "toplevel-form-number" and the (sub-) "form-number". To get from 10 | ;;; the form-number to the source-path we need the entire toplevel-form 11 | ;;; (i.e. we have to read the source code). CMUCL has already some 12 | ;;; utilities to do this translation, but we use some extended 13 | ;;; versions, because we need more exact position info. Apparently 14 | ;;; Hemlock is happy with the position of the toplevel-form; we also 15 | ;;; need the position of subforms. 16 | ;;; 17 | ;;; We use a special readtable to get the positions of the subforms. 18 | ;;; The readtable stores the start and end position for each subform in 19 | ;;; hashtable for later retrieval. 20 | ;;; 21 | ;;; This code has been placed in the Public Domain. All warranties 22 | ;;; are disclaimed. 23 | 24 | ;;; Taken from swank-cmucl.lisp, by Helmut Eller 25 | 26 | (defpackage micros/source-path-parser 27 | (:use cl) 28 | (:export 29 | read-source-form 30 | source-path-string-position 31 | source-path-file-position 32 | source-path-source-position 33 | 34 | sexp-in-bounds-p 35 | sexp-ref) 36 | (:shadow ignore-errors)) 37 | 38 | (in-package micros/source-path-parser) 39 | 40 | ;; Some test to ensure the required conformance 41 | (let ((rt (copy-readtable nil))) 42 | (assert (or (not (get-macro-character #\space rt)) 43 | (nth-value 1 (get-macro-character #\space rt)))) 44 | (assert (not (get-macro-character #\\ rt)))) 45 | 46 | (eval-when (:compile-toplevel) 47 | (defmacro ignore-errors (&rest forms) 48 | ;;`(progn . ,forms) ; for debugging 49 | `(cl:ignore-errors . ,forms))) 50 | 51 | (defun make-sharpdot-reader (orig-sharpdot-reader) 52 | (lambda (s c n) 53 | ;; We want things like M-. to work regardless of any #.-fu in 54 | ;; the source file that is to be visited. (For instance, when a 55 | ;; file contains #. forms referencing constants that do not 56 | ;; currently exist in the image.) 57 | (ignore-errors (funcall orig-sharpdot-reader s c n)))) 58 | 59 | (defun make-source-recorder (fn source-map) 60 | "Return a macro character function that does the same as FN, but 61 | additionally stores the result together with the stream positions 62 | before and after of calling FN in the hashtable SOURCE-MAP." 63 | (lambda (stream char) 64 | (let ((start (1- (file-position stream))) 65 | (values (multiple-value-list (funcall fn stream char))) 66 | (end (file-position stream))) 67 | #+(or) 68 | (format t "[~D \"~{~A~^, ~}\" ~D ~D ~S]~%" 69 | start values end (char-code char) char) 70 | (when values 71 | (destructuring-bind (&optional existing-start &rest existing-end) 72 | (car (gethash (car values) source-map)) 73 | ;; Some macros may return what a sub-call to another macro 74 | ;; produced, e.g. "#+(and) (a)" may end up saving (a) twice, 75 | ;; once from #\# and once from #\(. If the saved form 76 | ;; is a subform, don't save it again. 77 | (unless (and existing-start existing-end 78 | (<= start existing-start end) 79 | (<= start existing-end end)) 80 | (push (cons start end) (gethash (car values) source-map))))) 81 | (values-list values)))) 82 | 83 | (defun make-source-recording-readtable (readtable source-map) 84 | (declare (type readtable readtable) (type hash-table source-map)) 85 | "Return a source position recording copy of READTABLE. 86 | The source locations are stored in SOURCE-MAP." 87 | (flet ((install-special-sharpdot-reader (rt) 88 | (let ((fun (ignore-errors 89 | (get-dispatch-macro-character #\# #\. rt)))) 90 | (when fun 91 | (let ((wrapper (make-sharpdot-reader fun))) 92 | (set-dispatch-macro-character #\# #\. wrapper rt))))) 93 | (install-wrappers (rt) 94 | (dotimes (code 128) 95 | (let ((char (code-char code))) 96 | (multiple-value-bind (fun nt) (get-macro-character char rt) 97 | (when fun 98 | (let ((wrapper (make-source-recorder fun source-map))) 99 | (set-macro-character char wrapper nt rt)))))))) 100 | (let ((rt (copy-readtable readtable))) 101 | (install-special-sharpdot-reader rt) 102 | (install-wrappers rt) 103 | rt))) 104 | 105 | ;; FIXME: try to do this with *READ-SUPPRESS* = t to avoid interning. 106 | ;; Should be possible as we only need the right "list structure" and 107 | ;; not the right atoms. 108 | (defun read-and-record-source-map (stream) 109 | "Read the next object from STREAM. 110 | Return the object together with a hashtable that maps 111 | subexpressions of the object to stream positions." 112 | (let* ((source-map (make-hash-table :test #'eq)) 113 | (*readtable* (make-source-recording-readtable *readtable* source-map)) 114 | (*read-suppress* nil) 115 | (start (file-position stream)) 116 | (form (ignore-errors (read stream))) 117 | (end (file-position stream))) 118 | ;; ensure that at least FORM is in the source-map 119 | (unless (gethash form source-map) 120 | (push (cons start end) (gethash form source-map))) 121 | (values form source-map))) 122 | 123 | (defun starts-with-p (string prefix) 124 | (declare (type string string prefix)) 125 | (not (mismatch string prefix 126 | :end1 (min (length string) (length prefix)) 127 | :test #'char-equal))) 128 | 129 | (defun extract-package (line) 130 | (declare (type string line)) 131 | (let ((name (cadr (read-from-string line)))) 132 | (find-package name))) 133 | 134 | #+(or) 135 | (progn 136 | (assert (extract-package "(in-package cl)")) 137 | (assert (extract-package "(cl:in-package cl)")) 138 | (assert (extract-package "(in-package \"CL\")")) 139 | (assert (extract-package "(in-package #:cl)"))) 140 | 141 | ;; FIXME: do something cleaner than this. 142 | (defun readtable-for-package (package) 143 | ;; KLUDGE: due to the load order we can't reference the swank 144 | ;; package. 145 | (funcall (read-from-string "micros::guess-buffer-readtable") 146 | (string-upcase (package-name package)))) 147 | 148 | ;; Search STREAM for a "(in-package ...)" form. Use that to derive 149 | ;; the values for *PACKAGE* and *READTABLE*. 150 | ;; 151 | ;; IDEA: move GUESS-READER-STATE to swank.lisp so that all backends 152 | ;; use the same heuristic and to avoid the need to access 153 | ;; micros::guess-buffer-readtable from here. 154 | (defun guess-reader-state (stream) 155 | (let* ((point (file-position stream)) 156 | (pkg *package*)) 157 | (file-position stream 0) 158 | (loop for line = (read-line stream nil nil) do 159 | (when (not line) (return)) 160 | (when (or (starts-with-p line "(in-package ") 161 | (starts-with-p line "(cl:in-package ")) 162 | (let ((p (extract-package line))) 163 | (when p (setf pkg p))) 164 | (return))) 165 | (file-position stream point) 166 | (values (readtable-for-package pkg) pkg))) 167 | 168 | (defun skip-whitespace (stream) 169 | (peek-char t stream nil nil)) 170 | 171 | ;; Skip over N toplevel forms. 172 | (defun skip-toplevel-forms (n stream) 173 | (let ((*read-suppress* t)) 174 | (dotimes (i n) 175 | (read stream)) 176 | (skip-whitespace stream))) 177 | 178 | (defun read-source-form (n stream) 179 | "Read the Nth toplevel form number with source location recording. 180 | Return the form and the source-map." 181 | (multiple-value-bind (*readtable* *package*) (guess-reader-state stream) 182 | (let (#+sbcl 183 | (*features* (append *features* 184 | (symbol-value (find-symbol "+INTERNAL-FEATURES+" 'sb-impl))))) 185 | (skip-toplevel-forms n stream) 186 | (read-and-record-source-map stream)))) 187 | 188 | (defun source-path-stream-position (path stream) 189 | "Search the source-path PATH in STREAM and return its position." 190 | (check-source-path path) 191 | (destructuring-bind (tlf-number . path) path 192 | (multiple-value-bind (form source-map) (read-source-form tlf-number stream) 193 | (source-path-source-position (cons 0 path) form source-map)))) 194 | 195 | (defun check-source-path (path) 196 | (unless (and (consp path) 197 | (every #'integerp path)) 198 | (error "The source-path ~S is not valid." path))) 199 | 200 | (defun source-path-string-position (path string) 201 | (with-input-from-string (s string) 202 | (source-path-stream-position path s))) 203 | 204 | (defun source-path-file-position (path filename) 205 | ;; We go this long way round, and don't directly operate on the file 206 | ;; stream because FILE-POSITION (used above) is not totally savy even 207 | ;; on file character streams; on SBCL, FILE-POSITION returns the binary 208 | ;; offset, and not the character offset---screwing up on Unicode. 209 | (let ((toplevel-number (first path)) 210 | (buffer)) 211 | (with-open-file (file filename) 212 | (skip-toplevel-forms (1+ toplevel-number) file) 213 | (let ((endpos (file-position file))) 214 | (setq buffer (make-array (list endpos) :element-type 'character 215 | :initial-element #\Space)) 216 | (assert (file-position file 0)) 217 | (read-sequence buffer file :end endpos))) 218 | (source-path-string-position path buffer))) 219 | 220 | (defgeneric sexp-in-bounds-p (sexp i) 221 | (:method ((list list) i) 222 | (< i (loop for e on list 223 | count t))) 224 | (:method ((sexp t) i) nil)) 225 | 226 | (defgeneric sexp-ref (sexp i) 227 | (:method ((s list) i) (elt s i))) 228 | 229 | (defun source-path-source-position (path form source-map) 230 | "Return the start position of PATH from FORM and SOURCE-MAP. All 231 | subforms along the path are considered and the start and end position 232 | of the deepest (i.e. smallest) possible form is returned." 233 | ;; compute all subforms along path 234 | (let ((forms (loop for i in path 235 | for f = form then (if (sexp-in-bounds-p f i) 236 | (sexp-ref f i)) 237 | collect f))) 238 | ;; select the first subform present in source-map 239 | (loop for form in (nreverse forms) 240 | for ((start . end) . rest) = (gethash form source-map) 241 | when (and start end (not rest)) 242 | return (return (values start end))))) 243 | -------------------------------------------------------------------------------- /contrib/micros-buffer-streams.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-buffer-streams.lisp --- Streams that output to a buffer 2 | ;;; 3 | ;;; Authors: Ed Langley 4 | ;;; 5 | ;;; License: This code has been placed in the Public Domain. All warranties 6 | ;;; are disclaimed. 7 | 8 | (in-package :micros) 9 | 10 | (defpackage :micros/buffer-streams 11 | (:use :cl) 12 | (:import-from :swank 13 | defslimefun 14 | add-hook 15 | encode-message 16 | send-event 17 | find-thread 18 | dcase 19 | current-socket-io 20 | send-to-emacs 21 | current-thread-id 22 | wait-for-event 23 | 24 | *emacs-connection* 25 | *event-hook*) 26 | (:export make-buffer-output-stream)) 27 | 28 | (in-package :micros/buffer-streams) 29 | 30 | (defun get-temporary-identifier () 31 | (intern (symbol-name (gensym "BUFFER")) 32 | :keyword)) 33 | 34 | (defun make-buffer-output-stream (&optional (target-identifier (get-temporary-identifier))) 35 | (micros:ed-rpc '#:slime-make-buffer-stream-target (current-thread-id) target-identifier) 36 | (values (micros:make-output-stream-for-target *emacs-connection* target-identifier) 37 | target-identifier)) 38 | -------------------------------------------------------------------------------- /contrib/micros-c-p-c.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-c-p-c.lisp -- ILISP style Compound Prefix Completion 2 | ;; 3 | ;; Author: Luke Gorrie 4 | ;; Edi Weitz 5 | ;; Matthias Koeppe 6 | ;; Tobias C. Rittweiler 7 | ;; and others 8 | ;; 9 | ;; License: Public Domain 10 | ;; 11 | 12 | 13 | (in-package :micros) 14 | 15 | (defslimefun completions (string default-package-name) 16 | "Return a list of completions for a symbol designator STRING. 17 | 18 | The result is the list (COMPLETION-SET COMPLETED-PREFIX), where 19 | COMPLETION-SET is the list of all matching completions, and 20 | COMPLETED-PREFIX is the best (partial) completion of the input 21 | string. 22 | 23 | Simple compound matching is supported on a per-hyphen basis: 24 | 25 | (completions \"m-v-\" \"COMMON-LISP\") 26 | ==> ((\"multiple-value-bind\" \"multiple-value-call\" 27 | \"multiple-value-list\" \"multiple-value-prog1\" 28 | \"multiple-value-setq\" \"multiple-values-limit\") 29 | \"multiple-value\") 30 | 31 | \(For more advanced compound matching, see FUZZY-COMPLETIONS.) 32 | 33 | If STRING is package qualified the result list will also be 34 | qualified. If string is non-qualified the result strings are 35 | also not qualified and are considered relative to 36 | DEFAULT-PACKAGE-NAME. 37 | 38 | The way symbols are matched depends on the symbol designator's 39 | format. The cases are as follows: 40 | FOO - Symbols with matching prefix and accessible in the buffer package. 41 | PKG:FOO - Symbols with matching prefix and external in package PKG. 42 | PKG::FOO - Symbols with matching prefix and accessible in package PKG. 43 | " 44 | (multiple-value-bind (name package-name package internal-p) 45 | (parse-completion-arguments string default-package-name) 46 | (let* ((symbol-set (symbol-completion-set 47 | name package-name package internal-p 48 | (make-compound-prefix-matcher #\-))) 49 | (package-set (package-completion-set 50 | name package-name package internal-p 51 | (make-compound-prefix-matcher '(#\. #\-)))) 52 | (completion-set 53 | (format-completion-set (nconc symbol-set package-set) 54 | internal-p package-name))) 55 | (when completion-set 56 | (list completion-set (longest-compound-prefix completion-set)))))) 57 | 58 | 59 | ;;;;; Find completion set 60 | 61 | (defun symbol-completion-set (name package-name package internal-p matchp) 62 | "Return the set of completion-candidates as strings." 63 | (mapcar (completion-output-symbol-converter name) 64 | (and package 65 | (mapcar #'symbol-name 66 | (find-matching-symbols name 67 | package 68 | (and (not internal-p) 69 | package-name) 70 | matchp))))) 71 | 72 | (defun package-completion-set (name package-name package internal-p matchp) 73 | (declare (ignore package internal-p)) 74 | (mapcar (completion-output-package-converter name) 75 | (and (not package-name) 76 | (find-matching-packages name matchp)))) 77 | 78 | (defun find-matching-symbols (string package external test) 79 | "Return a list of symbols in PACKAGE matching STRING. 80 | TEST is called with two strings. If EXTERNAL is true, only external 81 | symbols are returned." 82 | (let ((completions '()) 83 | (converter (completion-output-symbol-converter string))) 84 | (flet ((symbol-matches-p (symbol) 85 | (and (or (not external) 86 | (symbol-external-p symbol package)) 87 | (funcall test string 88 | (funcall converter (symbol-name symbol)))))) 89 | (do-symbols* (symbol package) 90 | (when (symbol-matches-p symbol) 91 | (push symbol completions)))) 92 | completions)) 93 | 94 | (defun find-matching-symbols-in-list (string list test) 95 | "Return a list of symbols in LIST matching STRING. 96 | TEST is called with two strings." 97 | (let ((completions '()) 98 | (converter (completion-output-symbol-converter string))) 99 | (flet ((symbol-matches-p (symbol) 100 | (funcall test string 101 | (funcall converter (symbol-name symbol))))) 102 | (dolist (symbol list) 103 | (when (symbol-matches-p symbol) 104 | (push symbol completions)))) 105 | (remove-duplicates completions))) 106 | 107 | (defun find-matching-packages (name matcher) 108 | "Return a list of package names matching NAME with MATCHER. 109 | MATCHER is a two-argument predicate." 110 | (let ((converter (completion-output-package-converter name))) 111 | (remove-if-not (lambda (x) 112 | (funcall matcher name (funcall converter x))) 113 | (mapcar (lambda (pkgname) 114 | (concatenate 'string pkgname ":")) 115 | (loop for package in (list-all-packages) 116 | nconcing (package-names package)))))) 117 | 118 | 119 | ;; PARSE-COMPLETION-ARGUMENTS return table: 120 | ;; 121 | ;; user behaviour | NAME | PACKAGE-NAME | PACKAGE 122 | ;; ----------------+--------+--------------+----------------------------------- 123 | ;; asdf [tab] | "asdf" | NIL | # 124 | ;; | | | or *BUFFER-PACKAGE* 125 | ;; asdf: [tab] | "" | "asdf" | # 126 | ;; | | | 127 | ;; asdf:foo [tab] | "foo" | "asdf" | # 128 | ;; | | | 129 | ;; as:fo [tab] | "fo" | "as" | NIL 130 | ;; | | | 131 | ;; : [tab] | "" | "" | # 132 | ;; | | | 133 | ;; :foo [tab] | "foo" | "" | # 134 | ;; 135 | (defun parse-completion-arguments (string default-package-name) 136 | "Parse STRING as a symbol designator. 137 | Return these values: 138 | SYMBOL-NAME 139 | PACKAGE-NAME, or nil if the designator does not include an explicit package. 140 | PACKAGE, generally the package to complete in. (However, if PACKAGE-NAME is 141 | NIL, return the respective package of DEFAULT-PACKAGE-NAME instead; 142 | if PACKAGE is non-NIL but a package cannot be found under that name, 143 | return NIL.) 144 | INTERNAL-P, if the symbol is qualified with `::'." 145 | (multiple-value-bind (name package-name internal-p) 146 | (tokenize-symbol string) 147 | (flet ((default-package () 148 | (or (guess-package default-package-name) *buffer-package*))) 149 | (let ((package (cond 150 | ((not package-name) 151 | (default-package)) 152 | ((equal package-name "") 153 | (guess-package (symbol-name :keyword))) 154 | ((find-locally-nicknamed-package 155 | package-name (default-package))) 156 | (t 157 | (guess-package package-name))))) 158 | (values name package-name package internal-p))))) 159 | 160 | (defun completion-output-case-converter (input &optional with-escaping-p) 161 | "Return a function to convert strings for the completion output. 162 | INPUT is used to guess the preferred case." 163 | (ecase (readtable-case *readtable*) 164 | (:upcase (cond ((or with-escaping-p 165 | (and (plusp (length input)) 166 | (not (some #'lower-case-p input)))) 167 | #'identity) 168 | (t #'string-downcase))) 169 | (:invert (lambda (output) 170 | (multiple-value-bind (lower upper) (determine-case output) 171 | (cond ((and lower upper) output) 172 | (lower (string-upcase output)) 173 | (upper (string-downcase output)) 174 | (t output))))) 175 | (:downcase (cond ((or with-escaping-p 176 | (and (zerop (length input)) 177 | (not (some #'upper-case-p input)))) 178 | #'identity) 179 | (t #'string-upcase))) 180 | (:preserve #'identity))) 181 | 182 | (defun completion-output-package-converter (input) 183 | "Return a function to convert strings for the completion output. 184 | INPUT is used to guess the preferred case." 185 | (completion-output-case-converter input)) 186 | 187 | (defun completion-output-symbol-converter (input) 188 | "Return a function to convert strings for the completion output. 189 | INPUT is used to guess the preferred case. Escape symbols when needed." 190 | (let ((case-converter (completion-output-case-converter input)) 191 | (case-converter-with-escaping (completion-output-case-converter input t))) 192 | (lambda (str) 193 | (if (or (multiple-value-bind (lowercase uppercase) 194 | (determine-case str) 195 | ;; In these readtable cases, symbols with letters from 196 | ;; the wrong case need escaping 197 | (case (readtable-case *readtable*) 198 | (:upcase lowercase) 199 | (:downcase uppercase) 200 | (t nil))) 201 | (some (lambda (el) 202 | (or (member el '(#\: #\Space #\Newline #\Tab)) 203 | (multiple-value-bind (macrofun nonterminating) 204 | (get-macro-character el) 205 | (and macrofun 206 | (not nonterminating))))) 207 | str)) 208 | (concatenate 'string "|" (funcall case-converter-with-escaping str) "|") 209 | (funcall case-converter str))))) 210 | 211 | 212 | (defun determine-case (string) 213 | "Return two booleans LOWER and UPPER indicating whether STRING 214 | contains lower or upper case characters." 215 | (values (some #'lower-case-p string) 216 | (some #'upper-case-p string))) 217 | 218 | 219 | ;;;;; Compound-prefix matching 220 | 221 | (defun make-compound-prefix-matcher (delimiter &key (test #'char=)) 222 | "Returns a matching function that takes a `prefix' and a 223 | `target' string and which returns T if `prefix' is a 224 | compound-prefix of `target', and otherwise NIL. 225 | 226 | Viewing each of `prefix' and `target' as a series of substrings 227 | delimited by DELIMITER, if each substring of `prefix' is a prefix 228 | of the corresponding substring in `target' then we call `prefix' 229 | a compound-prefix of `target'. 230 | 231 | DELIMITER may be a character, or a list of characters." 232 | (let ((delimiters (etypecase delimiter 233 | (character (list delimiter)) 234 | (cons (assert (every #'characterp delimiter)) 235 | delimiter)))) 236 | (lambda (prefix target) 237 | (declare (type simple-string prefix target)) 238 | (loop with tpos = 0 239 | for ch across prefix 240 | always (and (< tpos (length target)) 241 | (let ((delimiter (car (member ch delimiters :test test)))) 242 | (if delimiter 243 | (setf tpos (position delimiter target :start tpos)) 244 | (funcall test ch (aref target tpos))))) 245 | do (incf tpos))))) 246 | 247 | 248 | ;;;;; Extending the input string by completion 249 | 250 | (defun longest-compound-prefix (completions &optional (delimiter #\-)) 251 | "Return the longest compound _prefix_ for all COMPLETIONS." 252 | (flet ((tokenizer (string) (tokenize-completion string delimiter))) 253 | (untokenize-completion 254 | (loop for token-list in (transpose-lists (mapcar #'tokenizer completions)) 255 | if (notevery #'string= token-list (rest token-list)) 256 | ;; Note that we possibly collect the "" here as well, so that 257 | ;; UNTOKENIZE-COMPLETION will append a delimiter for us. 258 | collect (longest-common-prefix token-list) 259 | and do (loop-finish) 260 | else collect (first token-list)) 261 | delimiter))) 262 | 263 | (defun tokenize-completion (string delimiter) 264 | "Return all substrings of STRING delimited by DELIMITER." 265 | (loop with end 266 | for start = 0 then (1+ end) 267 | until (> start (length string)) 268 | do (setq end (or (position delimiter string :start start) (length string))) 269 | collect (subseq string start end))) 270 | 271 | (defun untokenize-completion (tokens &optional (delimiter #\-)) 272 | (format nil (format nil "~~{~~A~~^~a~~}" delimiter) tokens)) 273 | 274 | (defun transpose-lists (lists) 275 | "Turn a list-of-lists on its side. 276 | If the rows are of unequal length, truncate uniformly to the shortest. 277 | 278 | For example: 279 | \(transpose-lists '((ONE TWO THREE) (1 2))) 280 | => ((ONE 1) (TWO 2))" 281 | (cond ((null lists) '()) 282 | ((some #'null lists) '()) 283 | (t (cons (mapcar #'car lists) 284 | (transpose-lists (mapcar #'cdr lists)))))) 285 | 286 | 287 | ;;;; Completion for character names 288 | 289 | (defslimefun completions-for-character (prefix) 290 | (let* ((matcher (make-compound-prefix-matcher #\_ :test #'char-equal)) 291 | (completion-set (character-completion-set prefix matcher)) 292 | (completions (sort completion-set #'string<))) 293 | (list completions (longest-compound-prefix completions #\_)))) 294 | -------------------------------------------------------------------------------- /contrib/micros-clipboard.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-clipboard.lisp --- Object clipboard 2 | ;; 3 | ;; Written by Helmut Eller in 2008. 4 | ;; License: Public Domain 5 | 6 | (defpackage :micros/clipboard 7 | (:use :cl) 8 | (:import-from :micros :defslimefun :with-buffer-syntax :dcase) 9 | (:export :add :delete-entry :entries :entry-to-ref :ref)) 10 | 11 | (in-package :micros/clipboard) 12 | 13 | (defstruct clipboard entries (counter 0)) 14 | 15 | (defvar *clipboard* (make-clipboard)) 16 | 17 | (defslimefun add (datum) 18 | (let ((value (dcase datum 19 | ((:string string package) 20 | (with-buffer-syntax (package) 21 | (eval (read-from-string string)))) 22 | ((:inspector part) 23 | (micros:inspector-nth-part part)) 24 | ((:sldb frame var) 25 | (micros/backend:frame-var-value frame var))))) 26 | (clipboard-add value) 27 | (format nil "Added: ~a" 28 | (entry-to-string (1- (length (clipboard-entries *clipboard*))))))) 29 | 30 | (defslimefun entries () 31 | (loop for (ref . value) in (clipboard-entries *clipboard*) 32 | collect `(,ref . ,(to-line value)))) 33 | 34 | (defslimefun delete-entry (entry) 35 | (let ((msg (format nil "Deleted: ~a" (entry-to-string entry)))) 36 | (clipboard-delete-entry entry) 37 | msg)) 38 | 39 | (defslimefun entry-to-ref (entry) 40 | (destructuring-bind (ref . value) (clipboard-entry entry) 41 | (list ref (to-line value 5)))) 42 | 43 | (defun clipboard-add (value) 44 | (setf (clipboard-entries *clipboard*) 45 | (append (clipboard-entries *clipboard*) 46 | (list (cons (incf (clipboard-counter *clipboard*)) 47 | value))))) 48 | 49 | (defun clipboard-ref (ref) 50 | (let ((tail (member ref (clipboard-entries *clipboard*) :key #'car))) 51 | (cond (tail (cdr (car tail))) 52 | (t (error "Invalid clipboard ref: ~s" ref))))) 53 | 54 | (defun clipboard-entry (entry) 55 | (elt (clipboard-entries *clipboard*) entry)) 56 | 57 | (defun clipboard-delete-entry (index) 58 | (let* ((list (clipboard-entries *clipboard*)) 59 | (tail (nthcdr index list))) 60 | (setf (clipboard-entries *clipboard*) 61 | (append (ldiff list tail) (cdr tail))))) 62 | 63 | (defun entry-to-string (entry) 64 | (destructuring-bind (ref . value) (clipboard-entry entry) 65 | (format nil "#@~d(~a)" ref (to-line value)))) 66 | 67 | (defun to-line (object &optional (width 75)) 68 | (with-output-to-string (*standard-output*) 69 | (write object :right-margin width :lines 1))) 70 | -------------------------------------------------------------------------------- /contrib/micros-hyperdoc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros) 2 | 3 | (defslimefun hyperdoc (string) 4 | (let ((hyperdoc-package (find-package :hyperdoc))) 5 | (when hyperdoc-package 6 | (multiple-value-bind (symbol foundp symbol-name package) 7 | (parse-symbol string *buffer-package*) 8 | (declare (ignore symbol)) 9 | (when foundp 10 | (funcall (find-symbol (string :lookup) hyperdoc-package) 11 | (package-name (if (member package (cons *buffer-package* 12 | (package-use-list 13 | *buffer-package*))) 14 | *buffer-package* 15 | package)) 16 | symbol-name)))))) 17 | -------------------------------------------------------------------------------- /contrib/micros-indentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros) 2 | 3 | (defvar *application-hints-tables* '() 4 | "A list of hash tables mapping symbols to indentation hints (lists 5 | of symbols and numbers as per cl-indent.el). Applications can add hash 6 | tables to the list to change the auto indentation slime sends to 7 | emacs.") 8 | 9 | (defun has-application-indentation-hint-p (symbol) 10 | (let ((default (load-time-value (gensym)))) 11 | (dolist (table *application-hints-tables*) 12 | (let ((indentation (gethash symbol table default))) 13 | (unless (eq default indentation) 14 | (return-from has-application-indentation-hint-p 15 | (values indentation t)))))) 16 | (values nil nil)) 17 | 18 | (defun application-indentation-hint (symbol) 19 | (let ((indentation (has-application-indentation-hint-p symbol))) 20 | (labels ((walk (indentation-spec) 21 | (etypecase indentation-spec 22 | (null nil) 23 | (number indentation-spec) 24 | (symbol (string-downcase indentation-spec)) 25 | (cons (cons (walk (car indentation-spec)) 26 | (walk (cdr indentation-spec))))))) 27 | (walk indentation)))) 28 | 29 | ;;; override swank version of this function 30 | (defun symbol-indentation (symbol) 31 | "Return a form describing the indentation of SYMBOL. 32 | 33 | The form is to be used as the `common-lisp-indent-function' property 34 | in Emacs." 35 | (cond 36 | ((has-application-indentation-hint-p symbol) 37 | (application-indentation-hint symbol)) 38 | ((and (macro-function symbol) 39 | (not (known-to-emacs-p symbol))) 40 | (let ((arglist (arglist symbol))) 41 | (etypecase arglist 42 | ((member :not-available) 43 | nil) 44 | (list 45 | (macro-indentation arglist))))) 46 | (t nil))) 47 | 48 | ;;; More complex version. 49 | (defun macro-indentation (arglist) 50 | (labels ((frob (list &optional base) 51 | (if (every (lambda (x) 52 | (member x '(nil "&rest") :test #'equal)) 53 | list) 54 | ;; If there was nothing interesting, don't return anything. 55 | nil 56 | ;; Otherwise substitute leading NIL's with 4 or 1. 57 | (let ((ok t)) 58 | (substitute-if (if base 59 | 4 60 | 1) 61 | (lambda (x) 62 | (if (and ok (not x)) 63 | t 64 | (setf ok nil))) 65 | list)))) 66 | (walk (list level &optional firstp) 67 | (when (consp list) 68 | (let ((head (car list))) 69 | (if (consp head) 70 | (let ((indent (frob (walk head (+ level 1) t)))) 71 | (cons (list* "&whole" (if (zerop level) 72 | 4 73 | 1) 74 | indent) (walk (cdr list) level))) 75 | (case head 76 | ;; &BODY is &BODY, this is clear. 77 | (&body 78 | '("&body")) 79 | ;; &KEY is tricksy. If it's at the base level, we want 80 | ;; to indent them normally: 81 | ;; 82 | ;; (foo bar quux 83 | ;; :quux t 84 | ;; :zot nil) 85 | ;; 86 | ;; If it's at a destructuring level, we want indent of 1: 87 | ;; 88 | ;; (with-foo (var arg 89 | ;; :foo t 90 | ;; :quux nil) 91 | ;; ...) 92 | (&key 93 | (if (zerop level) 94 | '("&rest" nil) 95 | '("&rest" 1))) 96 | ;; &REST is tricksy. If it's at the front of 97 | ;; destructuring, we want to indent by 1, otherwise 98 | ;; normally: 99 | ;; 100 | ;; (foo (bar quux 101 | ;; zot) 102 | ;; ...) 103 | ;; 104 | ;; but 105 | ;; 106 | ;; (foo bar quux 107 | ;; zot) 108 | (&rest 109 | (if (and (plusp level) firstp) 110 | '("&rest" 1) 111 | '("&rest" nil))) 112 | ;; &WHOLE and &ENVIRONMENT are skipped as if they weren't there 113 | ;; at all. 114 | ((&whole &environment) 115 | (walk (cddr list) level firstp)) 116 | ;; &OPTIONAL is indented normally -- and the &OPTIONAL marker 117 | ;; itself is not counted. 118 | (&optional 119 | (walk (cdr list) level)) 120 | ;; Indent normally, walk the tail -- but 121 | ;; unknown lambda-list keywords terminate the walk. 122 | (otherwise 123 | (unless (member head lambda-list-keywords) 124 | (cons nil (walk (cdr list) level)))))))))) 125 | (frob (walk arglist 0 t) t))) 126 | 127 | #+nil 128 | (progn 129 | (assert (equal '(4 4 ("&whole" 4 "&rest" 1) "&body") 130 | (macro-indentation '(bar quux (&rest slots) &body body)))) 131 | (assert (equal nil 132 | (macro-indentation '(a b c &rest more)))) 133 | (assert (equal '(4 4 4 "&body") 134 | (macro-indentation '(a b c &body more)))) 135 | (assert (equal '(("&whole" 4 1 1 "&rest" 1) "&body") 136 | (macro-indentation '((name zot &key foo bar) &body body)))) 137 | (assert (equal nil 138 | (macro-indentation '(x y &key z))))) 139 | -------------------------------------------------------------------------------- /contrib/micros-listener-hooks.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-listener-hooks.lisp --- listener with special hooks 2 | ;; 3 | ;; Author: Alan Ruttenberg 4 | 5 | ;; Provides *slime-repl-eval-hooks* special variable which 6 | ;; can be used for easy interception of SLIME REPL form evaluation 7 | ;; for purposes such as integration with application event loop. 8 | 9 | (in-package :micros) 10 | 11 | (defvar *slime-repl-advance-history* nil 12 | "In the dynamic scope of a single form typed at the repl, is set to nil to 13 | prevent the repl from advancing the history - * ** *** etc.") 14 | 15 | (defvar *slime-repl-suppress-output* nil 16 | "In the dynamic scope of a single form typed at the repl, is set to nil to 17 | prevent the repl from printing the result of the evalation.") 18 | 19 | (defvar *slime-repl-eval-hook-pass* (gensym "PASS") 20 | "Token to indicate that a repl hook declines to evaluate the form") 21 | 22 | (defvar *slime-repl-eval-hooks* nil 23 | "A list of functions. When the repl is about to eval a form, first try running each of 24 | these hooks. The first hook which returns a value which is not *slime-repl-eval-hook-pass* 25 | is considered a replacement for calling eval. If there are no hooks, or all 26 | pass, then eval is used.") 27 | 28 | (export '*slime-repl-eval-hooks*) 29 | 30 | (defslimefun repl-eval-hook-pass () 31 | "call when repl hook declines to evaluate the form" 32 | (throw *slime-repl-eval-hook-pass* *slime-repl-eval-hook-pass*)) 33 | 34 | (defslimefun repl-suppress-output () 35 | "In the dynamic scope of a single form typed at the repl, call to 36 | prevent the repl from printing the result of the evalation." 37 | (setq *slime-repl-suppress-output* t)) 38 | 39 | (defslimefun repl-suppress-advance-history () 40 | "In the dynamic scope of a single form typed at the repl, call to 41 | prevent the repl from advancing the history - * ** *** etc." 42 | (setq *slime-repl-advance-history* nil)) 43 | 44 | (defun %eval-region (string) 45 | (with-input-from-string (stream string) 46 | (let (- values) 47 | (loop 48 | (let ((form (read stream nil stream))) 49 | (when (eq form stream) 50 | (fresh-line) 51 | (finish-output) 52 | (return (values values -))) 53 | (setq - form) 54 | (if *slime-repl-eval-hooks* 55 | (setq values (run-repl-eval-hooks form)) 56 | (setq values (multiple-value-list (eval form)))) 57 | (finish-output)))))) 58 | 59 | (defun run-repl-eval-hooks (form) 60 | (loop for hook in *slime-repl-eval-hooks* 61 | for res = (catch *slime-repl-eval-hook-pass* 62 | (multiple-value-list (funcall hook form))) 63 | until (not (eq res *slime-repl-eval-hook-pass*)) 64 | finally (return 65 | (if (eq res *slime-repl-eval-hook-pass*) 66 | (multiple-value-list (eval form)) 67 | res)))) 68 | 69 | (defun %listener-eval (string) 70 | (clear-user-input) 71 | (with-buffer-syntax () 72 | (micros/repl::track-package 73 | (lambda () 74 | (let ((*slime-repl-suppress-output* :unset) 75 | (*slime-repl-advance-history* :unset)) 76 | (multiple-value-bind (values last-form) (%eval-region string) 77 | (unless (or (and (eq values nil) (eq last-form nil)) 78 | (eq *slime-repl-advance-history* nil)) 79 | (setq *** ** ** * * (car values) 80 | /// // // / / values)) 81 | (setq +++ ++ ++ + + last-form) 82 | (unless (eq *slime-repl-suppress-output* t) 83 | (funcall micros/repl::*send-repl-results-function* values))))))) 84 | nil) 85 | 86 | (setq micros/repl::*listener-eval-function* '%listener-eval) 87 | -------------------------------------------------------------------------------- /contrib/micros-macrostep.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el 2 | ;; 3 | ;; Authors: Luis Oliveira 4 | ;; Jon Oddie 5 | ;; 6 | ;; License: Public Domain 7 | 8 | (defpackage :micros/macrostep 9 | (:use cl :micros) 10 | (:import-from :micros 11 | #:*macroexpand-printer-bindings* 12 | #:with-buffer-syntax 13 | #:with-bindings 14 | #:to-string 15 | #:macroexpand-all 16 | #:compiler-macroexpand-1 17 | #:defslimefun 18 | #:collect-macro-forms) 19 | (:export #:macrostep-expand-1 20 | #:macro-form-p)) 21 | 22 | (in-package :micros/macrostep) 23 | 24 | (defslimefun macrostep-expand-1 (string compiler-macros? context) 25 | (with-buffer-syntax () 26 | (let ((form (read-from-string string))) 27 | (multiple-value-bind (expansion error-message) 28 | (expand-form-once form compiler-macros? context) 29 | (if error-message 30 | `(:error ,error-message) 31 | (multiple-value-bind (macros compiler-macros) 32 | (collect-macro-forms-in-context expansion context) 33 | (let* ((all-macros (append macros compiler-macros)) 34 | (pretty-expansion (pprint-to-string expansion)) 35 | (positions (collect-form-positions expansion 36 | pretty-expansion 37 | all-macros)) 38 | (subform-info 39 | (loop 40 | for form in all-macros 41 | for (start end) in positions 42 | when (and start end) 43 | collect (let ((op-name (to-string (first form))) 44 | (op-type 45 | (if (member form macros) 46 | :macro 47 | :compiler-macro))) 48 | (list op-name 49 | op-type 50 | start))))) 51 | `(:ok ,pretty-expansion ,subform-info)))))))) 52 | 53 | (defun expand-form-once (form compiler-macros? context) 54 | (multiple-value-bind (expansion expanded?) 55 | (macroexpand-1-in-context form context) 56 | (if expanded? 57 | (values expansion nil) 58 | (if (not compiler-macros?) 59 | (values nil "Not a macro form") 60 | (multiple-value-bind (expansion expanded?) 61 | (compiler-macroexpand-1 form) 62 | (if expanded? 63 | (values expansion nil) 64 | (values nil "Not a macro or compiler-macro form"))))))) 65 | 66 | (defslimefun macro-form-p (string compiler-macros? context) 67 | (with-buffer-syntax () 68 | (let ((form 69 | (handler-case 70 | (read-from-string string) 71 | (error (condition) 72 | (unless (debug-on-swank-error) 73 | (return-from macro-form-p 74 | `(:error ,(format nil "Read error: ~A" condition)))))))) 75 | `(:ok ,(macro-form-type form compiler-macros? context))))) 76 | 77 | (defun macro-form-type (form compiler-macros? context) 78 | (cond 79 | ((or (not (consp form)) 80 | (not (symbolp (car form)))) 81 | nil) 82 | ((multiple-value-bind (expansion expanded?) 83 | (macroexpand-1-in-context form context) 84 | (declare (ignore expansion)) 85 | expanded?) 86 | :macro) 87 | ((and compiler-macros? 88 | (multiple-value-bind (expansion expanded?) 89 | (compiler-macroexpand-1 form) 90 | (declare (ignore expansion)) 91 | expanded?)) 92 | :compiler-macro) 93 | (t 94 | nil))) 95 | 96 | 97 | ;;;; Hacks to support macro-expansion within local context 98 | 99 | (defparameter *macrostep-tag* (gensym)) 100 | 101 | (defparameter *macrostep-placeholder* '*macrostep-placeholder*) 102 | 103 | (define-condition expansion-in-context-failed (simple-error) 104 | ()) 105 | 106 | (defmacro throw-expansion (form &environment env) 107 | (throw *macrostep-tag* (macroexpand-1 form env))) 108 | 109 | (defmacro throw-collected-macro-forms (form &environment env) 110 | (throw *macrostep-tag* (collect-macro-forms form env))) 111 | 112 | (defun macroexpand-1-in-context (form context) 113 | (handler-case 114 | (macroexpand-and-catch 115 | `(throw-expansion ,form) context) 116 | (error () 117 | (macroexpand-1 form)))) 118 | 119 | (defun collect-macro-forms-in-context (form context) 120 | (handler-case 121 | (macroexpand-and-catch 122 | `(throw-collected-macro-forms ,form) context) 123 | (error () 124 | (collect-macro-forms form)))) 125 | 126 | (defun macroexpand-and-catch (form context) 127 | (catch *macrostep-tag* 128 | (macroexpand-all (enclose-form-in-context form context)) 129 | (error 'expansion-in-context-failed))) 130 | 131 | (defun enclose-form-in-context (form context) 132 | (with-buffer-syntax () 133 | (destructuring-bind (prefix suffix) context 134 | (let* ((placeholder-form 135 | (read-from-string 136 | (concatenate 137 | 'string 138 | prefix (prin1-to-string *macrostep-placeholder*) suffix))) 139 | (substituted-form (subst form *macrostep-placeholder* 140 | placeholder-form))) 141 | (if (not (equal placeholder-form substituted-form)) 142 | substituted-form 143 | (error 'expansion-in-context-failed)))))) 144 | 145 | 146 | ;;;; Tracking Pretty Printer 147 | 148 | (defun marker-char-p (char) 149 | (<= #xe000 (char-code char) #xe8ff)) 150 | 151 | (defun make-marker-char (id) 152 | ;; using the private-use characters U+E000..U+F8FF as markers, so 153 | ;; that's our upper limit for how many we can use. 154 | (assert (<= 0 id #x8ff)) 155 | (code-char (+ #xe000 id))) 156 | 157 | (defun marker-char-id (char) 158 | (assert (marker-char-p char)) 159 | (- (char-code char) #xe000)) 160 | 161 | (defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32))) 162 | 163 | (defun whitespacep (char) 164 | (member char +whitespace+)) 165 | 166 | (defun pprint-to-string (object &optional pprint-dispatch) 167 | (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*))) 168 | (with-bindings *macroexpand-printer-bindings* 169 | (to-string object)))) 170 | 171 | #-clisp 172 | (defun collect-form-positions (expansion printed-expansion forms) 173 | (loop for (start end) 174 | in (collect-marker-positions 175 | (pprint-to-string expansion (make-tracking-pprint-dispatch forms)) 176 | (length forms)) 177 | collect (when (and start end) 178 | (list (find-non-whitespace-position printed-expansion start) 179 | (find-non-whitespace-position printed-expansion end))))) 180 | 181 | ;; The pprint-dispatch table constructed by 182 | ;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack 183 | ;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS 184 | ;; entry point a no-op in thi case, so that basic macro-expansion will 185 | ;; still work (without detection of inner macro forms) 186 | #+clisp 187 | (defun collect-form-positions (expansion printed-expansion forms) 188 | nil) 189 | 190 | (defun make-tracking-pprint-dispatch (forms) 191 | (let ((original-table *print-pprint-dispatch*) 192 | (table (copy-pprint-dispatch))) 193 | (flet ((maybe-write-marker (position stream) 194 | (when position 195 | (write-char (make-marker-char position) stream)))) 196 | (set-pprint-dispatch 'cons 197 | (lambda (stream cons) 198 | (let ((pos (position cons forms))) 199 | (maybe-write-marker pos stream) 200 | ;; delegate printing to the original table. 201 | (funcall (pprint-dispatch cons original-table) 202 | stream 203 | cons) 204 | (maybe-write-marker pos stream))) 205 | most-positive-fixnum 206 | table)) 207 | table)) 208 | 209 | (defun collect-marker-positions (string position-count) 210 | (let ((positions (make-array position-count :initial-element nil))) 211 | (loop with p = 0 212 | for char across string 213 | unless (whitespacep char) 214 | do (if (marker-char-p char) 215 | (push p (aref positions (marker-char-id char))) 216 | (incf p))) 217 | (map 'list #'reverse positions))) 218 | 219 | (defun find-non-whitespace-position (string position) 220 | (loop with non-whitespace-position = -1 221 | for i from 0 and char across string 222 | unless (whitespacep char) 223 | do (incf non-whitespace-position) 224 | until (eql non-whitespace-position position) 225 | finally (return i))) 226 | -------------------------------------------------------------------------------- /contrib/micros-mrepl.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-mrepl.lisp 2 | ;; 3 | ;; Licence: public domain 4 | 5 | (in-package :micros) 6 | (eval-when (:compile-toplevel :load-toplevel :execute) 7 | (let ((api '( 8 | *emacs-connection* 9 | channel 10 | channel-id 11 | define-channel-method 12 | defslimefun 13 | dcase 14 | log-event 15 | process-requests 16 | send-to-remote-channel 17 | use-threads-p 18 | wait-for-event 19 | with-bindings 20 | with-connection 21 | with-top-level-restart 22 | with-slime-interrupts 23 | ))) 24 | (eval `(defpackage :micros/swank-api 25 | (:use) 26 | (:import-from #:micros . ,api) 27 | (:export . ,api))))) 28 | 29 | (defpackage :micros/mrepl 30 | (:use :cl :micros/swank-api) 31 | (:export #:create-mrepl)) 32 | 33 | (in-package :micros/mrepl) 34 | 35 | (defclass listener-channel (channel) 36 | ((remote :initarg :remote) 37 | (env :initarg :env) 38 | (mode :initform :eval) 39 | (tag :initform nil))) 40 | 41 | (defun package-prompt (package) 42 | (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) 43 | (cons (package-name package) (package-nicknames package)))) 44 | 45 | (defslimefun create-mrepl (remote) 46 | (let* ((pkg *package*) 47 | (conn *emacs-connection*) 48 | (thread (if (use-threads-p) 49 | (spawn-listener-thread conn) 50 | nil)) 51 | (ch (make-instance 'listener-channel :remote remote :thread thread))) 52 | (setf (slot-value ch 'env) (initial-listener-env ch)) 53 | (when thread 54 | (micros/backend:send thread `(:serve-channel ,ch))) 55 | (list (channel-id ch) 56 | (micros/backend:thread-id (or thread (micros/backend:current-thread))) 57 | (package-name pkg) 58 | (package-prompt pkg)))) 59 | 60 | (defun initial-listener-env (listener) 61 | `((*package* . ,*package*) 62 | (*standard-output* . ,(make-listener-output-stream listener)) 63 | (*standard-input* . ,(make-listener-input-stream listener)))) 64 | 65 | (defun spawn-listener-thread (connection) 66 | (micros/backend:spawn 67 | (lambda () 68 | (with-connection (connection) 69 | (dcase (micros/backend:receive) 70 | ((:serve-channel c) 71 | (loop 72 | (with-top-level-restart (connection (drop-unprocessed-events c)) 73 | (process-requests nil))))))) 74 | :name "mrepl thread")) 75 | 76 | (defun drop-unprocessed-events (channel) 77 | (with-slots (mode) channel 78 | (let ((old-mode mode)) 79 | (setf mode :drop) 80 | (unwind-protect 81 | (process-requests t) 82 | (setf mode old-mode))) 83 | (send-prompt channel))) 84 | 85 | (define-channel-method :process ((c listener-channel) string) 86 | (log-event ":process ~s~%" string) 87 | (with-slots (mode remote) c 88 | (ecase mode 89 | (:eval (mrepl-eval c string)) 90 | (:read (mrepl-read c string)) 91 | (:drop)))) 92 | 93 | (defun mrepl-eval (channel string) 94 | (with-slots (remote env) channel 95 | (let ((aborted t)) 96 | (with-bindings env 97 | (unwind-protect 98 | (let ((result (with-slime-interrupts (read-eval-print string)))) 99 | (send-to-remote-channel remote `(:write-result ,result)) 100 | (setq aborted nil)) 101 | (setf env (loop for (sym) in env 102 | collect (cons sym (symbol-value sym)))) 103 | (cond (aborted 104 | (send-to-remote-channel remote `(:evaluation-aborted))) 105 | (t 106 | (send-prompt channel)))))))) 107 | 108 | (defun send-prompt (channel) 109 | (with-slots (env remote) channel 110 | (let ((pkg (or (cdr (assoc '*package* env)) *package*)) 111 | (out (cdr (assoc '*standard-output* env))) 112 | (in (cdr (assoc '*standard-input* env)))) 113 | (when out (force-output out)) 114 | (when in (clear-input in)) 115 | (send-to-remote-channel remote `(:prompt ,(package-name pkg) 116 | ,(package-prompt pkg)))))) 117 | 118 | (defun mrepl-read (channel string) 119 | (with-slots (tag) channel 120 | (assert tag) 121 | (throw tag string))) 122 | 123 | (defun read-eval-print (string) 124 | (with-input-from-string (in string) 125 | (setq / ()) 126 | (loop 127 | (let* ((form (read in nil in))) 128 | (cond ((eq form in) (return)) 129 | (t (setq / (multiple-value-list (eval (setq + form)))))))) 130 | (force-output) 131 | (if / 132 | (format nil "~{~s~%~}" /) 133 | "; No values"))) 134 | 135 | (defun make-listener-output-stream (channel) 136 | (let ((remote (slot-value channel 'remote))) 137 | (micros/backend:make-output-stream 138 | (lambda (string) 139 | (send-to-remote-channel remote `(:write-string ,string)))))) 140 | 141 | (defun make-listener-input-stream (channel) 142 | (micros/backend:make-input-stream (lambda () (read-input channel)))) 143 | 144 | (defun set-mode (channel new-mode) 145 | (with-slots (mode remote) channel 146 | (unless (eq mode new-mode) 147 | (send-to-remote-channel remote `(:set-read-mode ,new-mode))) 148 | (setf mode new-mode))) 149 | 150 | (defun read-input (channel) 151 | (with-slots (mode tag remote) channel 152 | (force-output) 153 | (let ((old-mode mode) 154 | (old-tag tag)) 155 | (setf tag (cons nil nil)) 156 | (set-mode channel :read) 157 | (unwind-protect 158 | (catch tag (process-requests nil)) 159 | (setf tag old-tag) 160 | (set-mode channel old-mode))))) 161 | -------------------------------------------------------------------------------- /contrib/micros-package-fu.lisp: -------------------------------------------------------------------------------- 1 | 2 | (in-package :micros) 3 | 4 | (defslimefun package= (string1 string2) 5 | (let* ((pkg1 (guess-package string1)) 6 | (pkg2 (guess-package string2))) 7 | (and pkg1 pkg2 (eq pkg1 pkg2)))) 8 | 9 | (defslimefun export-symbol-for-emacs (symbol-str package-str) 10 | (let ((package (guess-package package-str))) 11 | (when package 12 | (let ((*buffer-package* package)) 13 | (export `(,(from-string symbol-str)) package))))) 14 | 15 | (defslimefun unexport-symbol-for-emacs (symbol-str package-str) 16 | (let ((package (guess-package package-str))) 17 | (when package 18 | (let ((*buffer-package* package)) 19 | (unexport `(,(from-string symbol-str)) package))))) 20 | 21 | #+sbcl 22 | (defun list-structure-symbols (name) 23 | (let ((dd (sb-kernel:find-defstruct-description name ))) 24 | (list* name 25 | (sb-kernel:dd-default-constructor dd) 26 | (sb-kernel:dd-predicate-name dd) 27 | (sb-kernel::dd-copier-name dd) 28 | (mapcar #'sb-kernel:dsd-accessor-name 29 | (sb-kernel:dd-slots dd))))) 30 | 31 | #+ccl 32 | (defun list-structure-symbols (name) 33 | (let ((definition (gethash name ccl::%defstructs%))) 34 | (list* name 35 | (ccl::sd-constructor definition) 36 | (ccl::sd-refnames definition)))) 37 | 38 | (defun list-class-symbols (name) 39 | (let* ((class (find-class name)) 40 | (slots (micros/mop:class-direct-slots class))) 41 | (labels ((extract-symbol (name) 42 | (if (and (consp name) (eql (car name) 'setf)) 43 | (cadr name) 44 | name)) 45 | (slot-accessors (slot) 46 | (nintersection (copy-list (micros/mop:slot-definition-readers slot)) 47 | (copy-list (micros/mop:slot-definition-readers slot)) 48 | :key #'extract-symbol))) 49 | (list* (class-name class) 50 | (mapcan #'slot-accessors slots))))) 51 | 52 | (defslimefun export-structure (name package) 53 | (let ((*package* (guess-package package))) 54 | (when *package* 55 | (let* ((name (from-string name)) 56 | (symbols (cond #+(or sbcl ccl) 57 | ((or (not (find-class name nil)) 58 | (subtypep name 'structure-object)) 59 | (list-structure-symbols name)) 60 | (t 61 | (list-class-symbols name))))) 62 | (export symbols) 63 | symbols)))) 64 | -------------------------------------------------------------------------------- /contrib/micros-presentation-streams.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-presentation-streams.lisp --- Streams that allow attaching object identities 2 | ;;; to portions of output 3 | ;;; 4 | ;;; Authors: Alan Ruttenberg 5 | ;;; Matthias Koeppe 6 | ;;; Helmut Eller 7 | ;;; 8 | ;;; License: This code has been placed in the Public Domain. All warranties 9 | ;;; are disclaimed. 10 | 11 | (in-package :micros) 12 | 13 | ;; This file contains a mechanism for printing to the slime repl so 14 | ;; that the printed result remembers what object it is associated 15 | ;; with. This extends the recording of REPL results. 16 | ;; 17 | ;; There are two methods: 18 | ;; 19 | ;; 1. Depends on the ilisp bridge code being installed and ready to 20 | ;; intercept messages in the printed stream. We encode the 21 | ;; information with a message saying that we are starting to print 22 | ;; an object corresponding to a given id and another when we are 23 | ;; done. The process filter notices these and adds the necessary 24 | ;; text properties to the output. 25 | ;; 26 | ;; 2. Use separate protocol messages :presentation-start and 27 | ;; :presentation-end for sending presentations. 28 | ;; 29 | ;; We only do this if we know we are printing to a slime stream, 30 | ;; checked with the method slime-stream-p. Initially this checks for 31 | ;; the knows slime streams looking at *connections*. In cmucl, sbcl, and 32 | ;; openmcl it also checks if it is a pretty-printing stream which 33 | ;; ultimately prints to a slime stream. 34 | ;; 35 | ;; Method 1 seems to be faster, but the printed escape sequences can 36 | ;; disturb the column counting, and thus the layout in pretty-printing. 37 | ;; We use method 1 when a dedicated output stream is used. 38 | ;; 39 | ;; Method 2 is cleaner and works with pretty printing if the pretty 40 | ;; printers support "annotations". We use method 2 when no dedicated 41 | ;; output stream is used. 42 | 43 | ;; Control 44 | (defvar *enable-presenting-readable-objects* t 45 | "set this to enable automatically printing presentations for some 46 | subset of readable objects, such as pathnames." ) 47 | 48 | ;; doing it 49 | 50 | (defmacro presenting-object (object stream &body body) 51 | "What you use in your code. Wrap this around some printing and that text will 52 | be sensitive and remember what object it is in the repl" 53 | `(presenting-object-1 ,object ,stream #'(lambda () ,@body))) 54 | 55 | (defmacro presenting-object-if (predicate object stream &body body) 56 | "What you use in your code. Wrap this around some printing and that text will 57 | be sensitive and remember what object it is in the repl if predicate is true" 58 | (let ((continue (gensym))) 59 | `(let ((,continue #'(lambda () ,@body))) 60 | (if ,predicate 61 | (presenting-object-1 ,object ,stream ,continue) 62 | (funcall ,continue))))) 63 | 64 | (let ((last-stream nil) 65 | (last-answer nil)) 66 | (defun slime-stream-p (stream) 67 | "Check if stream is one of the slime streams, since if it isn't we 68 | don't want to present anything. 69 | Two special return values: 70 | :DEDICATED -- Output ends up on a dedicated output stream 71 | :REPL-RESULT -- Output ends up on the :repl-results target. 72 | " 73 | (if (eq last-stream stream) 74 | last-answer 75 | (progn 76 | (setq last-stream stream) 77 | (if (eq stream t) 78 | (setq stream *standard-output*)) 79 | (setq last-answer 80 | (or #+openmcl 81 | (and (typep stream 'ccl::xp-stream) 82 | ;(slime-stream-p (ccl::xp-base-stream (slot-value stream 'ccl::xp-structure))) 83 | (slime-stream-p (ccl::%svref (slot-value stream 'ccl::xp-structure) 1))) 84 | #+cmu 85 | (or (and (typep stream 'lisp::indenting-stream) 86 | (slime-stream-p (lisp::indenting-stream-stream stream))) 87 | (and (typep stream 'pretty-print::pretty-stream) 88 | (fboundp 'pretty-print::enqueue-annotation) 89 | (let ((slime-stream-p 90 | (slime-stream-p (pretty-print::pretty-stream-target stream)))) 91 | (and ;; Printing through CMUCL pretty 92 | ;; streams is only cleanly 93 | ;; possible if we are using the 94 | ;; bridge-less protocol with 95 | ;; annotations, because the bridge 96 | ;; escape sequences disturb the 97 | ;; pretty printer layout. 98 | (not (eql slime-stream-p :dedicated-output)) 99 | ;; If OK, return the return value 100 | ;; we got from slime-stream-p on 101 | ;; the target stream (could be 102 | ;; :repl-result): 103 | slime-stream-p)))) 104 | #+sbcl 105 | (let () 106 | (declare (notinline sb-pretty::pretty-stream-target)) 107 | (and (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty)) 108 | (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty) 109 | (not *use-dedicated-output-stream*) 110 | (slime-stream-p (sb-pretty::pretty-stream-target stream)))) 111 | #+allegro 112 | (and (typep stream 'excl:xp-simple-stream) 113 | (slime-stream-p (excl::stream-output-handle stream))) 114 | (loop for connection in *connections* 115 | thereis (or (and (eq stream (connection.dedicated-output connection)) 116 | :dedicated) 117 | (eq stream (connection.socket-io connection)) 118 | (eq stream (connection.user-output connection)) 119 | (eq stream (connection.user-io connection)) 120 | (and (eq stream (connection.repl-results connection)) 121 | :repl-result))))))))) 122 | 123 | (defun can-present-readable-objects (&optional stream) 124 | (declare (ignore stream)) 125 | *enable-presenting-readable-objects*) 126 | 127 | ;; If we are printing to an XP (pretty printing) stream, printing the 128 | ;; escape sequences directly would mess up the layout because column 129 | ;; counting is disturbed. Use "annotations" instead. 130 | #+allegro 131 | (defun write-annotation (stream function arg) 132 | (if (typep stream 'excl:xp-simple-stream) 133 | (excl::schedule-annotation stream function arg) 134 | (funcall function arg stream nil))) 135 | #+cmu 136 | (defun write-annotation (stream function arg) 137 | (if (and (typep stream 'pp:pretty-stream) 138 | (fboundp 'pp::enqueue-annotation)) 139 | (pp::enqueue-annotation stream function arg) 140 | (funcall function arg stream nil))) 141 | #+sbcl 142 | (defun write-annotation (stream function arg) 143 | (let ((enqueue-annotation 144 | (find-symbol "ENQUEUE-ANNOTATION" 'sb-pretty))) 145 | (if (and enqueue-annotation 146 | (typep stream (find-symbol "PRETTY-STREAM" 'sb-pretty))) 147 | (funcall enqueue-annotation stream function arg) 148 | (funcall function arg stream nil)))) 149 | #-(or allegro cmu sbcl) 150 | (defun write-annotation (stream function arg) 151 | (funcall function arg stream nil)) 152 | 153 | (defstruct presentation-record 154 | (id) 155 | (printed-p) 156 | (target)) 157 | 158 | (defun presentation-start (record stream truncatep) 159 | (unless truncatep 160 | ;; Don't start new presentations when nothing is going to be 161 | ;; printed due to *print-lines*. 162 | (let ((pid (presentation-record-id record)) 163 | (target (presentation-record-target record))) 164 | (case target 165 | (:dedicated 166 | ;; Use bridge protocol 167 | (write-string "<" stream) 168 | (prin1 pid stream) 169 | (write-string "" stream)) 170 | (t 171 | (finish-output stream) 172 | (send-to-emacs `(:presentation-start ,pid ,target))))) 173 | (setf (presentation-record-printed-p record) t))) 174 | 175 | (defun presentation-end (record stream truncatep) 176 | (declare (ignore truncatep)) 177 | ;; Always end old presentations that were started. 178 | (when (presentation-record-printed-p record) 179 | (let ((pid (presentation-record-id record)) 180 | (target (presentation-record-target record))) 181 | (case target 182 | (:dedicated 183 | ;; Use bridge protocol 184 | (write-string ">" stream) 185 | (prin1 pid stream) 186 | (write-string "" stream)) 187 | (t 188 | (finish-output stream) 189 | (send-to-emacs `(:presentation-end ,pid ,target))))))) 190 | 191 | (defun presenting-object-1 (object stream continue) 192 | "Uses the bridge mechanism with two messages >id and ) 247 | (pp-end-block stream ">")) 248 | nil)) 249 | (defmethod print-object :around ((pathname pathname) stream) 250 | (micros::presenting-object-if 251 | (micros::can-present-readable-objects stream) 252 | pathname stream (call-next-method)))) 253 | (ccl::def-load-pointers clear-presentations () 254 | (micros::clear-presentation-tables))) 255 | 256 | (in-package :micros) 257 | 258 | #+cmu 259 | (progn 260 | (fwrappers:define-fwrapper presenting-unreadable-wrapper (object stream type identity body) 261 | (presenting-object object stream 262 | (fwrappers:call-next-function))) 263 | 264 | (fwrappers:define-fwrapper presenting-pathname-wrapper (pathname stream depth) 265 | (presenting-object-if (can-present-readable-objects stream) pathname stream 266 | (fwrappers:call-next-function))) 267 | 268 | (defun monkey-patch-stream-printing () 269 | (fwrappers::fwrap 'lisp::%print-pathname #'presenting-pathname-wrapper) 270 | (fwrappers::fwrap 'lisp::%print-unreadable-object #'presenting-unreadable-wrapper))) 271 | 272 | #+sbcl 273 | (progn 274 | (defvar *saved-%print-unreadable-object* 275 | (fdefinition 'sb-impl::%print-unreadable-object)) 276 | 277 | (defun monkey-patch-stream-printing () 278 | (sb-ext:without-package-locks 279 | (when (eq (fdefinition 'sb-impl::%print-unreadable-object) 280 | *saved-%print-unreadable-object*) 281 | (setf (fdefinition 'sb-impl::%print-unreadable-object) 282 | (lambda (object stream &rest args) 283 | (presenting-object object stream 284 | (apply *saved-%print-unreadable-object* 285 | object stream args))))) 286 | (defmethod print-object :around ((object pathname) stream) 287 | (presenting-object object stream 288 | (call-next-method)))))) 289 | 290 | #+allegro 291 | (progn 292 | (excl:def-fwrapper presenting-unreadable-wrapper (object stream type identity continuation) 293 | (micros::presenting-object object stream (excl:call-next-fwrapper))) 294 | (excl:def-fwrapper presenting-pathname-wrapper (pathname stream depth) 295 | (presenting-object-if (can-present-readable-objects stream) pathname stream 296 | (excl:call-next-fwrapper))) 297 | (defun monkey-patch-stream-printing () 298 | (excl:fwrap 'excl::print-unreadable-object-1 299 | 'print-unreadable-present 'presenting-unreadable-wrapper) 300 | (excl:fwrap 'excl::pathname-printer 301 | 'print-pathname-present 'presenting-pathname-wrapper))) 302 | 303 | #-(or allegro sbcl cmu openmcl) 304 | (defun monkey-patch-stream-printing () 305 | (values)) 306 | 307 | ;; Hook into SWANK. 308 | 309 | (defslimefun init-presentation-streams () 310 | (monkey-patch-stream-printing) 311 | ;; FIXME: import/use swank-repl to avoid package qualifier. 312 | (setq micros/repl:*send-repl-results-function* 313 | 'present-repl-results-via-presentation-streams)) 314 | -------------------------------------------------------------------------------- /contrib/micros-presentations.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-presentations.lisp --- imitate LispM's presentations 2 | ;; 3 | ;; Authors: Alan Ruttenberg 4 | ;; Luke Gorrie 5 | ;; Helmut Eller 6 | ;; Matthias Koeppe 7 | ;; 8 | ;; License: This code has been placed in the Public Domain. All warranties 9 | ;; are disclaimed. 10 | ;; 11 | 12 | (in-package :micros) 13 | 14 | ;;;; Recording and accessing results of computations 15 | 16 | (defvar *record-repl-results* t 17 | "Non-nil means that REPL results are saved for later lookup.") 18 | 19 | (defvar *object-to-presentation-id* 20 | (make-weak-key-hash-table :test 'eq) 21 | "Store the mapping of objects to numeric identifiers") 22 | 23 | (defvar *presentation-id-to-object* 24 | (make-weak-value-hash-table :test 'eql) 25 | "Store the mapping of numeric identifiers to objects") 26 | 27 | (defun clear-presentation-tables () 28 | (clrhash *object-to-presentation-id*) 29 | (clrhash *presentation-id-to-object*)) 30 | 31 | (defvar *presentation-counter* 0 "identifier counter") 32 | 33 | (defvar *nil-surrogate* (make-symbol "nil-surrogate")) 34 | 35 | ;; XXX thread safety? [2006-09-13] mb: not in the slightest (fwiw the 36 | ;; rest of slime isn't thread safe either), do we really care? 37 | (defun save-presented-object (object) 38 | "Save OBJECT and return the assigned id. 39 | If OBJECT was saved previously return the old id." 40 | (let ((object (if (null object) *nil-surrogate* object))) 41 | ;; We store *nil-surrogate* instead of nil, to distinguish it from 42 | ;; an object that was garbage collected. 43 | (or (gethash object *object-to-presentation-id*) 44 | (let ((id (incf *presentation-counter*))) 45 | (setf (gethash id *presentation-id-to-object*) object) 46 | (setf (gethash object *object-to-presentation-id*) id) 47 | id)))) 48 | 49 | (defslimefun lookup-presented-object (id) 50 | "Retrieve the object corresponding to ID. 51 | The secondary value indicates the absence of an entry." 52 | (etypecase id 53 | (integer 54 | ;; 55 | (multiple-value-bind (object foundp) 56 | (gethash id *presentation-id-to-object*) 57 | (cond 58 | ((eql object *nil-surrogate*) 59 | ;; A stored nil object 60 | (values nil t)) 61 | ((null object) 62 | ;; Object that was replaced by nil in the weak hash table 63 | ;; when the object was garbage collected. 64 | (values nil nil)) 65 | (t 66 | (values object foundp))))) 67 | (cons 68 | (dcase id 69 | ((:frame-var thread-id frame index) 70 | (declare (ignore thread-id)) ; later 71 | (handler-case 72 | (frame-var-value frame index) 73 | (t (condition) 74 | (declare (ignore condition)) 75 | (values nil nil)) 76 | (:no-error (value) 77 | (values value t)))) 78 | ((:inspected-part part-index) 79 | (inspector-nth-part part-index)))))) 80 | 81 | (defslimefun lookup-presented-object-or-lose (id) 82 | "Get the result of the previous REPL evaluation with ID." 83 | (multiple-value-bind (object foundp) (lookup-presented-object id) 84 | (cond (foundp object) 85 | (t (error "Attempt to access unrecorded object (id ~D)." id))))) 86 | 87 | (defslimefun lookup-and-save-presented-object-or-lose (id) 88 | "Get the object associated with ID and save it in the presentation tables." 89 | (let ((obj (lookup-presented-object-or-lose id))) 90 | (save-presented-object obj))) 91 | 92 | (defslimefun clear-repl-results () 93 | "Forget the results of all previous REPL evaluations." 94 | (clear-presentation-tables) 95 | t) 96 | 97 | (defun present-repl-results (values) 98 | ;; Override a function in swank.lisp, so that 99 | ;; presentations are associated with every REPL result. 100 | (flet ((send (value) 101 | (let ((id (and *record-repl-results* 102 | (save-presented-object value)))) 103 | (send-to-emacs `(:presentation-start ,id :repl-result)) 104 | (send-to-emacs `(:write-string ,(prin1-to-string value) 105 | :repl-result)) 106 | (send-to-emacs `(:presentation-end ,id :repl-result)) 107 | (send-to-emacs `(:write-string ,(string #\Newline) 108 | :repl-result))))) 109 | (fresh-line) 110 | (finish-output) 111 | (if (null values) 112 | (send-to-emacs `(:write-string "; No value" :repl-result)) 113 | (mapc #'send values)))) 114 | 115 | 116 | ;;;; Presentation menu protocol 117 | ;; 118 | ;; To define a menu for a type of object, define a method 119 | ;; menu-choices-for-presentation on that object type. This function 120 | ;; should return a list of two element lists where the first element is 121 | ;; the name of the menu action and the second is a function that will be 122 | ;; called if the menu is chosen. The function will be called with 3 123 | ;; arguments: 124 | ;; 125 | ;; choice: The string naming the action from above 126 | ;; 127 | ;; object: The object 128 | ;; 129 | ;; id: The presentation id of the object 130 | ;; 131 | ;; You might want append (when (next-method-p) (call-next-method)) to 132 | ;; pick up the Menu actions of superclasses. 133 | ;; 134 | 135 | (defvar *presentation-active-menu* nil) 136 | 137 | (defun menu-choices-for-presentation-id (id) 138 | (multiple-value-bind (ob presentp) (lookup-presented-object id) 139 | (cond ((not presentp) 'not-present) 140 | (t 141 | (let ((menu-and-actions (menu-choices-for-presentation ob))) 142 | (setq *presentation-active-menu* (cons id menu-and-actions)) 143 | (mapcar 'car menu-and-actions)))))) 144 | 145 | (defun swank-ioify (thing) 146 | (cond ((keywordp thing) thing) 147 | ((and (symbolp thing)(not (find #\: (symbol-name thing)))) 148 | (intern (symbol-name thing) *swank-io-package*)) 149 | ((consp thing) (cons (swank-ioify (car thing)) 150 | (swank-ioify (cdr thing)))) 151 | (t thing))) 152 | 153 | (defun execute-menu-choice-for-presentation-id (id count item) 154 | (let ((ob (lookup-presented-object id))) 155 | (assert (equal id (car *presentation-active-menu*)) () 156 | "Bug: Execute menu call for id ~a but menu has id ~a" 157 | id (car *presentation-active-menu*)) 158 | (let ((action (second (nth (1- count) (cdr *presentation-active-menu*))))) 159 | (swank-ioify (funcall action item ob id))))) 160 | 161 | 162 | (defgeneric menu-choices-for-presentation (object) 163 | (:method (ob) (declare (ignore ob)) nil)) ; default method 164 | 165 | ;; Pathname 166 | (defmethod menu-choices-for-presentation ((ob pathname)) 167 | (let* ((file-exists (ignore-errors (probe-file ob))) 168 | (lisp-type (make-pathname :type "lisp")) 169 | (source-file (and (not (member (pathname-type ob) '("lisp" "cl") 170 | :test 'equal)) 171 | (let ((source (merge-pathnames lisp-type ob))) 172 | (and (ignore-errors (probe-file source)) 173 | source)))) 174 | (fasl-file (and file-exists 175 | (equal (ignore-errors 176 | (namestring 177 | (truename 178 | (compile-file-pathname 179 | (merge-pathnames lisp-type ob))))) 180 | (namestring (truename ob)))))) 181 | (remove nil 182 | (list* 183 | (and (and file-exists (not fasl-file)) 184 | (list "Edit this file" 185 | (lambda(choice object id) 186 | (declare (ignore choice id)) 187 | (ed-in-emacs (namestring (truename object))) 188 | nil))) 189 | (and file-exists 190 | (list "Dired containing directory" 191 | (lambda (choice object id) 192 | (declare (ignore choice id)) 193 | (ed-in-emacs (namestring 194 | (truename 195 | (merge-pathnames 196 | (make-pathname :name "" :type "") 197 | object)))) 198 | nil))) 199 | (and fasl-file 200 | (list "Load this fasl file" 201 | (lambda (choice object id) 202 | (declare (ignore choice id object)) 203 | (load ob) 204 | nil))) 205 | (and fasl-file 206 | (list "Delete this fasl file" 207 | (lambda (choice object id) 208 | (declare (ignore choice id object)) 209 | (let ((nt (namestring (truename ob)))) 210 | (when (y-or-n-p-in-emacs "Delete ~a? " nt) 211 | (delete-file nt))) 212 | nil))) 213 | (and source-file 214 | (list "Edit lisp source file" 215 | (lambda (choice object id) 216 | (declare (ignore choice id object)) 217 | (ed-in-emacs (namestring (truename source-file))) 218 | nil))) 219 | (and source-file 220 | (list "Load lisp source file" 221 | (lambda(choice object id) 222 | (declare (ignore choice id object)) 223 | (load source-file) 224 | nil))) 225 | (and (next-method-p) (call-next-method)))))) 226 | 227 | (defmethod menu-choices-for-presentation ((ob function)) 228 | (list (list "Disassemble" 229 | (lambda (choice object id) 230 | (declare (ignore choice id)) 231 | (disassemble object))))) 232 | 233 | (defslimefun inspect-presentation (id reset-p) 234 | (let ((what (lookup-presented-object-or-lose id))) 235 | (when reset-p 236 | (reset-inspector)) 237 | (inspect-object what))) 238 | 239 | (defslimefun init-presentations () 240 | ;; FIXME: import/use swank-repl to avoid package qualifier. 241 | (setq micros/repl:*send-repl-results-function* 'present-repl-results)) 242 | -------------------------------------------------------------------------------- /contrib/micros-pretty-eval.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/pretty-eval 2 | (:use :cl :micros)) 3 | (in-package :micros/pretty-eval) 4 | 5 | (defvar *null-value* (gensym)) 6 | (defvar *evaluated-values-table* (make-hash-table)) 7 | (defvar *evaluated-id-counter* 0) 8 | (defvar *mutex* (micros/backend:make-lock :name "pretty-eval")) 9 | 10 | (defun add (values) 11 | (micros/backend:call-with-lock-held 12 | *mutex* 13 | (lambda () 14 | (let ((id (incf *evaluated-id-counter*))) 15 | (setf (gethash id *evaluated-values-table*) 16 | values) 17 | id)))) 18 | 19 | (defun get-by-id (id) 20 | (micros/backend:call-with-lock-held 21 | *mutex* 22 | (lambda () 23 | (let ((values (gethash id *evaluated-values-table* *null-value*))) 24 | values)))) 25 | 26 | (defun remove-by-id (id) 27 | (micros/backend:call-with-lock-held 28 | *mutex* 29 | (lambda () 30 | (remhash id *evaluated-values-table*)))) 31 | 32 | (micros/swank-api:defslimefun pretty-eval (string) 33 | (micros::with-buffer-syntax () 34 | (let* ((values (multiple-value-list (eval (from-string string)))) 35 | (id (add values))) 36 | (finish-output) 37 | (list :value (micros::format-values-for-echo-area values) 38 | :id id)))) 39 | 40 | (micros/swank-api:defslimefun inspect-evaluation-value (id) 41 | (let ((values (get-by-id id))) 42 | (unless (eq values *null-value*) 43 | (micros::with-buffer-syntax () 44 | (micros::with-retry-restart (:msg "Retry SLIME inspection request.") 45 | (micros::reset-inspector) 46 | (micros::inspect-object (if (= 1 (length values)) 47 | (first values) 48 | values))))))) 49 | 50 | (micros/swank-api:defslimefun get-evaluation-value (id) 51 | (let ((values (get-by-id id))) 52 | (unless (eq values *null-value*) 53 | (first values)))) 54 | 55 | (micros::defslimefun remove-evaluated-values (id) 56 | (remove-by-id id) 57 | (values)) 58 | -------------------------------------------------------------------------------- /contrib/micros-repl.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-repl.lisp --- Server side part of the Lisp listener. 2 | ;; 3 | ;; License: public domain 4 | (in-package :micros) 5 | 6 | (defpackage :micros/repl 7 | (:use cl micros/backend) 8 | (:export *send-repl-results-function*) 9 | (:import-from 10 | :micros 11 | 12 | *default-worker-thread-bindings* 13 | 14 | *loopback-interface* 15 | 16 | add-hook 17 | *connection-closed-hook* 18 | 19 | eval-region 20 | with-buffer-syntax 21 | 22 | connection 23 | connection.socket-io 24 | connection.repl-results 25 | connection.user-input 26 | connection.user-output 27 | connection.user-io 28 | connection.trace-output 29 | connection.dedicated-output 30 | connection.env 31 | 32 | multithreaded-connection 33 | mconn.active-threads 34 | mconn.repl-thread 35 | mconn.auto-flush-thread 36 | use-threads-p 37 | 38 | *emacs-connection* 39 | default-connection 40 | with-connection 41 | 42 | send-to-emacs 43 | *communication-style* 44 | handle-requests 45 | wait-for-event 46 | make-tag 47 | thread-for-evaluation 48 | socket-quest 49 | 50 | authenticate-client 51 | encode-message 52 | 53 | auto-flush-loop 54 | clear-user-input 55 | 56 | current-thread-id 57 | cat 58 | with-struct* 59 | with-retry-restart 60 | with-bindings 61 | 62 | package-string-for-prompt 63 | find-external-format-or-lose 64 | 65 | defslimefun 66 | 67 | ;; FIXME: those should be exported from swank-repl only, but how to 68 | ;; do that whithout breaking init files? 69 | *use-dedicated-output-stream* 70 | *dedicated-output-stream-port* 71 | *globally-redirect-io*)) 72 | 73 | (in-package :micros/repl) 74 | 75 | (defvar *use-dedicated-output-stream* nil 76 | "When T swank will attempt to create a second connection to Emacs 77 | which is used just to send output.") 78 | 79 | (defvar *dedicated-output-stream-port* 0 80 | "Which port we should use for the dedicated output stream.") 81 | 82 | (defvar *dedicated-output-stream-buffering* 83 | (if (eq *communication-style* :spawn) t nil) 84 | "The buffering scheme that should be used for the output stream. 85 | Valid values are nil, t, :line") 86 | 87 | (defvar *globally-redirect-io* :started-from-emacs 88 | "When T globally redirect all standard streams to Emacs. 89 | When :STARTED-FROM-EMACS redirect when launched by M-x slime") 90 | 91 | (defun globally-redirect-io-p () 92 | (case *globally-redirect-io* 93 | ((t) t) 94 | (:started-from-emacs nil))) 95 | 96 | (defun open-streams (connection properties) 97 | "Return the 5 streams for IO redirection: 98 | DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" 99 | (let* ((input-fn 100 | (lambda () 101 | (with-connection (connection) 102 | (with-simple-restart (abort-read 103 | "Abort reading input from Emacs.") 104 | (read-user-input-from-emacs))))) 105 | (dedicated-output (if *use-dedicated-output-stream* 106 | (open-dedicated-output-stream 107 | connection 108 | (getf properties :coding-system)))) 109 | (in (make-input-stream input-fn)) 110 | (out (or dedicated-output 111 | (make-output-stream (make-output-function connection)))) 112 | (io (make-two-way-stream in out)) 113 | (repl-results (micros:make-output-stream-for-target connection 114 | :repl-result))) 115 | (typecase connection 116 | (multithreaded-connection 117 | (setf (mconn.auto-flush-thread connection) 118 | (make-auto-flush-thread out)))) 119 | (values dedicated-output in out io repl-results))) 120 | 121 | (defun make-output-function (connection) 122 | "Create function to send user output to Emacs." 123 | (lambda (string) 124 | (with-connection (connection) 125 | (send-to-emacs `(:write-string ,string))))) 126 | 127 | (defun open-dedicated-output-stream (connection coding-system) 128 | "Open a dedicated output connection to the Emacs on SOCKET-IO. 129 | Return an output stream suitable for writing program output. 130 | 131 | This is an optimized way for Lisp to deliver output to Emacs." 132 | (let ((socket (socket-quest *dedicated-output-stream-port* nil)) 133 | (ef (find-external-format-or-lose coding-system))) 134 | (unwind-protect 135 | (let ((port (local-port socket))) 136 | (encode-message `(:open-dedicated-output-stream ,port 137 | ,coding-system) 138 | (connection.socket-io connection)) 139 | (let ((dedicated (accept-connection 140 | socket 141 | :external-format ef 142 | :buffering *dedicated-output-stream-buffering* 143 | :timeout 30))) 144 | (authenticate-client dedicated) 145 | (close-socket socket) 146 | (setf socket nil) 147 | dedicated)) 148 | (when socket 149 | (close-socket socket))))) 150 | 151 | (defmethod thread-for-evaluation ((connection multithreaded-connection) 152 | (id (eql :find-existing))) 153 | (or (car (mconn.active-threads connection)) 154 | (find-repl-thread connection))) 155 | 156 | (defmethod thread-for-evaluation ((connection multithreaded-connection) 157 | (id (eql :repl-thread))) 158 | (find-repl-thread connection)) 159 | 160 | (defun find-repl-thread (connection) 161 | (cond ((not (use-threads-p)) 162 | (current-thread)) 163 | (t 164 | (let ((thread (mconn.repl-thread connection))) 165 | (cond ((not thread) nil) 166 | ((thread-alive-p thread) thread) 167 | (t 168 | (setf (mconn.repl-thread connection) 169 | (spawn-repl-thread connection "new-repl-thread")))))))) 170 | 171 | (defun spawn-repl-thread (connection name) 172 | (spawn (lambda () 173 | (with-bindings *default-worker-thread-bindings* 174 | (repl-loop connection))) 175 | :name name)) 176 | 177 | (defun repl-loop (connection) 178 | (handle-requests connection)) 179 | 180 | ;;;;; Redirection during requests 181 | ;;; 182 | ;;; We always redirect the standard streams to Emacs while evaluating 183 | ;;; an RPC. This is done with simple dynamic bindings. 184 | 185 | (defslimefun create-repl (target &key coding-system) 186 | (assert (eq target nil)) 187 | (let ((conn *emacs-connection*)) 188 | (initialize-streams-for-connection conn `(:coding-system ,coding-system)) 189 | (with-struct* (connection. @ conn) 190 | (setf (@ env) 191 | `((*standard-input* . ,(@ user-input)) 192 | ,@(unless (globally-redirect-io-p) 193 | `((*standard-output* . ,(@ user-output)) 194 | (*trace-output* . ,(or (@ trace-output) (@ user-output))) 195 | (*error-output* . ,(@ user-output)) 196 | (*debug-io* . ,(@ user-io)) 197 | (*query-io* . ,(@ user-io)) 198 | (*terminal-io* . ,(@ user-io)))))) 199 | (maybe-redirect-global-io conn) 200 | (add-hook *connection-closed-hook* 'update-redirection-after-close) 201 | (typecase conn 202 | (multithreaded-connection 203 | (setf (mconn.repl-thread conn) 204 | (spawn-repl-thread conn "repl-thread")))) 205 | (list (package-name *package*) 206 | (package-string-for-prompt *package*))))) 207 | 208 | (defun initialize-streams-for-connection (connection properties) 209 | (multiple-value-bind (dedicated in out io repl-results) 210 | (open-streams connection properties) 211 | (setf (connection.dedicated-output connection) dedicated 212 | (connection.user-io connection) io 213 | (connection.user-output connection) out 214 | (connection.user-input connection) in 215 | (connection.repl-results connection) repl-results) 216 | connection)) 217 | 218 | (defun read-user-input-from-emacs () 219 | (let ((tag (make-tag))) 220 | (force-output) 221 | (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) 222 | (let ((ok nil)) 223 | (unwind-protect 224 | (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) 225 | (setq ok t)) 226 | (unless ok 227 | (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) 228 | 229 | ;;;;; Listener eval 230 | 231 | (defvar *listener-eval-function* 'repl-eval) 232 | 233 | (defvar *listener-saved-value* nil) 234 | 235 | (defslimefun listener-save-value (slimefun &rest args) 236 | "Apply SLIMEFUN to ARGS and save the value. 237 | The saved value should be visible to all threads and retrieved via 238 | LISTENER-GET-VALUE." 239 | (setq *listener-saved-value* (apply slimefun args)) 240 | t) 241 | 242 | (defslimefun listener-get-value () 243 | "Get the last value saved by LISTENER-SAVE-VALUE. 244 | The value should be produced as if it were requested through 245 | LISTENER-EVAL directly, so that spacial variables *, etc are set." 246 | (listener-eval (let ((*package* (find-package :keyword))) 247 | (write-to-string '*listener-saved-value*)))) 248 | 249 | (defslimefun listener-eval (string &key (window-width nil window-width-p)) 250 | (if window-width-p 251 | (let ((*print-right-margin* window-width)) 252 | (funcall *listener-eval-function* string)) 253 | (funcall *listener-eval-function* string))) 254 | 255 | (defslimefun clear-repl-variables () 256 | (let ((variables '(*** ** * /// // / +++ ++ +))) 257 | (loop for variable in variables 258 | do (setf (symbol-value variable) nil)))) 259 | 260 | (defvar *send-repl-results-function* 'send-repl-results-to-emacs) 261 | 262 | (defun repl-eval (string) 263 | (clear-user-input) 264 | (with-buffer-syntax () 265 | (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") 266 | (track-package 267 | (lambda () 268 | (multiple-value-bind (values last-form) (eval-region string) 269 | (setq *** ** ** * * (car values) 270 | /// // // / / values 271 | +++ ++ ++ + + last-form) 272 | (funcall *send-repl-results-function* values)))))) 273 | nil) 274 | 275 | (defun track-package (fun) 276 | (let ((p *package*)) 277 | (unwind-protect (funcall fun) 278 | (unless (eq *package* p) 279 | (send-to-emacs (list :new-package (package-name *package*) 280 | (package-string-for-prompt *package*))))))) 281 | 282 | (defun send-repl-results-to-emacs (values) 283 | (finish-output) 284 | (if (null values) 285 | (send-to-emacs `(:write-string "; No value" :repl-result)) 286 | (dolist (v values) 287 | (micros::send-write-object-event v :repl-result) 288 | (send-to-emacs `(:write-string ,(string #\newline) :repl-result))))) 289 | 290 | (defslimefun redirect-trace-output (target) 291 | (setf (connection.trace-output *emacs-connection*) 292 | (micros:make-output-stream-for-target *emacs-connection* target)) 293 | nil) 294 | 295 | 296 | 297 | ;;;; IO to Emacs 298 | ;;; 299 | ;;; This code handles redirection of the standard I/O streams 300 | ;;; (`*standard-output*', etc) into Emacs. The `connection' structure 301 | ;;; contains the appropriate streams, so all we have to do is make the 302 | ;;; right bindings. 303 | 304 | ;;;;; Global I/O redirection framework 305 | ;;; 306 | ;;; Optionally, the top-level global bindings of the standard streams 307 | ;;; can be assigned to be redirected to Emacs. When Emacs connects we 308 | ;;; redirect the streams into the connection, and they keep going into 309 | ;;; that connection even if more are established. If the connection 310 | ;;; handling the streams closes then another is chosen, or if there 311 | ;;; are no connections then we revert to the original (real) streams. 312 | ;;; 313 | ;;; It is slightly tricky to assign the global values of standard 314 | ;;; streams because they are often shadowed by dynamic bindings. We 315 | ;;; solve this problem by introducing an extra indirection via synonym 316 | ;;; streams, so that *STANDARD-INPUT* is a synonym stream to 317 | ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" 318 | ;;; variables, so they can always be assigned to affect a global 319 | ;;; change. 320 | 321 | ;;;;; Global redirection setup 322 | 323 | (defvar *saved-global-streams* '() 324 | "A plist to save and restore redirected stream objects. 325 | E.g. the value for '*standard-output* holds the stream object 326 | for *standard-output* before we install our redirection.") 327 | 328 | (defun setup-stream-indirection (stream-var &optional stream) 329 | "Setup redirection scaffolding for a global stream variable. 330 | Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: 331 | 332 | 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. 333 | 334 | 2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as 335 | *STANDARD-INPUT*. 336 | 337 | 3. Assigns *STANDARD-INPUT* to a synonym stream pointing to 338 | *CURRENT-STANDARD-INPUT*. 339 | 340 | This has the effect of making *CURRENT-STANDARD-INPUT* contain the 341 | effective global value for *STANDARD-INPUT*. This way we can assign 342 | the effective global value even when *STANDARD-INPUT* is shadowed by a 343 | dynamic binding." 344 | (let ((current-stream-var (prefixed-var '#:current stream-var)) 345 | (stream (or stream (symbol-value stream-var)))) 346 | ;; Save the real stream value for the future. 347 | (setf (getf *saved-global-streams* stream-var) stream) 348 | ;; Define a new variable for the effective stream. 349 | ;; This can be reassigned. 350 | (proclaim `(special ,current-stream-var)) 351 | (set current-stream-var stream) 352 | ;; Assign the real binding as a synonym for the current one. 353 | (let ((stream (make-synonym-stream current-stream-var))) 354 | (set stream-var stream) 355 | (set-default-initial-binding stream-var `(quote ,stream))))) 356 | 357 | (defun prefixed-var (prefix variable-symbol) 358 | "(PREFIXED-VAR \"FOO\" '*BAR*) => micros::*FOO-BAR*" 359 | (let ((basename (subseq (symbol-name variable-symbol) 1))) 360 | (intern (format nil "*~A-~A" (string prefix) basename) :micros))) 361 | 362 | (defvar *standard-output-streams* 363 | '(*standard-output* *error-output* *trace-output*) 364 | "The symbols naming standard output streams.") 365 | 366 | (defvar *standard-input-streams* 367 | '(*standard-input*) 368 | "The symbols naming standard input streams.") 369 | 370 | (defvar *standard-io-streams* 371 | '(*debug-io* *query-io* *terminal-io*) 372 | "The symbols naming standard io streams.") 373 | 374 | (defun init-global-stream-redirection () 375 | (when (globally-redirect-io-p) 376 | (cond (*saved-global-streams* 377 | (warn "Streams already redirected.")) 378 | (t 379 | (mapc #'setup-stream-indirection 380 | (append *standard-output-streams* 381 | *standard-input-streams* 382 | *standard-io-streams*)))))) 383 | 384 | (defun globally-redirect-io-to-connection (connection) 385 | "Set the standard I/O streams to redirect to CONNECTION. 386 | Assigns *CURRENT-* for all standard streams." 387 | (dolist (o *standard-output-streams*) 388 | (set (prefixed-var '#:current o) 389 | (connection.user-output connection))) 390 | ;; FIXME: If we redirect standard input to Emacs then we get the 391 | ;; regular Lisp top-level trying to read from our REPL. 392 | ;; 393 | ;; Perhaps the ideal would be for the real top-level to run in a 394 | ;; thread with local bindings for all the standard streams. Failing 395 | ;; that we probably would like to inhibit it from reading while 396 | ;; Emacs is connected. 397 | ;; 398 | ;; Meanwhile we just leave *standard-input* alone. 399 | #+NIL 400 | (dolist (i *standard-input-streams*) 401 | (set (prefixed-var '#:current i) 402 | (connection.user-input connection))) 403 | (dolist (io *standard-io-streams*) 404 | (set (prefixed-var '#:current io) 405 | (connection.user-io connection)))) 406 | 407 | (defun revert-global-io-redirection () 408 | "Set *CURRENT-* to *REAL-* for all standard streams." 409 | (dolist (stream-var (append *standard-output-streams* 410 | *standard-input-streams* 411 | *standard-io-streams*)) 412 | (set (prefixed-var '#:current stream-var) 413 | (getf *saved-global-streams* stream-var)))) 414 | 415 | ;;;;; Global redirection hooks 416 | 417 | (defvar *global-stdio-connection* nil 418 | "The connection to which standard I/O streams are globally redirected. 419 | NIL if streams are not globally redirected.") 420 | 421 | (defun maybe-redirect-global-io (connection) 422 | "Consider globally redirecting to CONNECTION." 423 | (when (and (globally-redirect-io-p) (null *global-stdio-connection*) 424 | (connection.user-io connection)) 425 | (unless *saved-global-streams* 426 | (init-global-stream-redirection)) 427 | (setq *global-stdio-connection* connection) 428 | (globally-redirect-io-to-connection connection))) 429 | 430 | (defun update-redirection-after-close (closed-connection) 431 | "Update redirection after a connection closes." 432 | (check-type closed-connection connection) 433 | (when (eq *global-stdio-connection* closed-connection) 434 | (if (and (default-connection) (globally-redirect-io-p)) 435 | ;; Redirect to another connection. 436 | (globally-redirect-io-to-connection (default-connection)) 437 | ;; No more connections, revert to the real streams. 438 | (progn (revert-global-io-redirection) 439 | (setq *global-stdio-connection* nil))))) 440 | -------------------------------------------------------------------------------- /contrib/micros-sbcl-exts.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-sbcl-exts.lisp --- Misc extensions for SBCL 2 | ;; 3 | ;; Authors: Tobias C. Rittweiler 4 | ;; 5 | ;; License: Public Domain 6 | ;; 7 | 8 | (in-package :micros) 9 | 10 | ;; We need to do this so users can place `slime-sbcl-exts' into their 11 | ;; ~/.emacs, and still use any implementation they want. 12 | #+sbcl 13 | (progn 14 | 15 | ;;; Display arglist of instructions. 16 | ;;; 17 | (defmethod compute-enriched-decoded-arglist ((operator-form (eql 'sb-assem:inst)) 18 | argument-forms) 19 | (flet ((decode-instruction-arglist (instr-name instr-arglist) 20 | (let ((decoded-arglist (decode-arglist instr-arglist))) 21 | ;; The arglist of INST is (instruction ...INSTR-ARGLIST...). 22 | (push 'sb-assem::instruction (arglist.required-args decoded-arglist)) 23 | (values decoded-arglist 24 | (list (string-downcase instr-name)) 25 | t)))) 26 | (if (null argument-forms) 27 | (call-next-method) 28 | (destructuring-bind (instruction &rest args) argument-forms 29 | (declare (ignore args)) 30 | (let* ((instr-name 31 | (typecase instruction 32 | (arglist-dummy 33 | (string-upcase (arglist-dummy.string-representation instruction))) 34 | (symbol 35 | (string-upcase instruction)))) 36 | (instr-fn 37 | #+(and 38 | #.(micros/backend:with-symbol '*inst-encoder* 'sb-assem) 39 | #.(micros/backend:with-symbol '*backend-instruction-set-package* 'sb-assem)) 40 | (or (gethash (find-symbol instr-name sb-assem::*backend-instruction-set-package*) 41 | sb-assem::*inst-encoder*) 42 | (find-symbol (format nil "M:~A" instr-name) 43 | sb-assem::*backend-instruction-set-package*)))) 44 | (when (consp instr-fn) 45 | (setf instr-fn (car instr-fn))) 46 | (cond ((functionp instr-fn) 47 | (with-available-arglist (arglist) (arglist instr-fn) 48 | (decode-instruction-arglist instr-name (cdr arglist)))) 49 | ((fboundp instr-fn) 50 | (with-available-arglist (arglist) (arglist instr-fn) 51 | ;; SB-ASSEM:INST invokes a symbolic INSTR-FN with 52 | ;; current segment and current vop implicitly. 53 | (decode-instruction-arglist instr-name 54 | (if (or (get instr-fn :macro) 55 | (macro-function instr-fn)) 56 | arglist 57 | (cdr arglist))))) 58 | (t 59 | (call-next-method)))))))) 60 | 61 | 62 | ) ; PROGN 63 | -------------------------------------------------------------------------------- /contrib/micros-snapshot.lisp: -------------------------------------------------------------------------------- 1 | 2 | (defpackage :micros/snapshot 3 | (:use cl) 4 | (:export restore-snapshot save-snapshot background-save-snapshot) 5 | (:import-from swank defslimefun)) 6 | (in-package :micros/snapshot) 7 | 8 | (defslimefun save-snapshot (image-file) 9 | (micros/backend:save-image image-file 10 | (let ((c micros::*emacs-connection*)) 11 | (lambda () (resurrect c)))) 12 | (format nil "Dumped lisp to ~A" image-file)) 13 | 14 | (defslimefun restore-snapshot (image-file) 15 | (let* ((conn micros::*emacs-connection*) 16 | (stream (micros::connection.socket-io conn)) 17 | (clone (micros/backend:dup (micros/backend:socket-fd stream))) 18 | (style (micros::connection.communication-style conn)) 19 | (repl (if (micros::connection.user-io conn) t)) 20 | (args (list "--swank-fd" (format nil "~d" clone) 21 | "--swank-style" (format nil "~s" style) 22 | "--swank-repl" (format nil "~s" repl)))) 23 | (micros::close-connection conn nil nil) 24 | (micros/backend:exec-image image-file args))) 25 | 26 | (defslimefun background-save-snapshot (image-file) 27 | (let ((connection micros::*emacs-connection*)) 28 | (flet ((complete (success) 29 | (let ((micros::*emacs-connection* connection)) 30 | (micros::background-message 31 | "Dumping lisp image ~A ~:[failed!~;succeeded.~]" 32 | image-file success))) 33 | (awaken () 34 | (resurrect connection))) 35 | (micros/backend:background-save-image image-file 36 | :restart-function #'awaken 37 | :completion-function #'complete) 38 | (format nil "Started dumping lisp to ~A..." image-file)))) 39 | 40 | (in-package :micros) 41 | 42 | (defun swank-snapshot::resurrect (old-connection) 43 | (setq *log-output* nil) 44 | (init-log-output) 45 | (clear-event-history) 46 | (setq *connections* (delete old-connection *connections*)) 47 | (format *error-output* "args: ~s~%" (command-line-args)) 48 | (let* ((fd (read-command-line-arg "--swank-fd")) 49 | (style (read-command-line-arg "--swank-style")) 50 | (repl (read-command-line-arg "--swank-repl")) 51 | (* (format *error-output* "fd=~s style=~s~%" fd style)) 52 | (stream (make-fd-stream fd nil)) 53 | (connection (make-connection nil stream style))) 54 | (let ((*emacs-connection* connection)) 55 | (when repl (micros/repl:create-repl nil)) 56 | (background-message "~A" "Lisp image restored")) 57 | (serve-requests connection) 58 | (simple-repl))) 59 | 60 | (defun read-command-line-arg (name) 61 | (let* ((args (command-line-args)) 62 | (pos (position name args :test #'equal))) 63 | (read-from-string (elt args (1+ pos))))) 64 | 65 | (in-package :swank-snapshot) 66 | -------------------------------------------------------------------------------- /contrib/micros-sprof.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-sprof.lisp 2 | ;; 3 | ;; Authors: Juho Snellman 4 | ;; 5 | ;; License: MIT 6 | ;; 7 | 8 | (in-package :micros) 9 | 10 | #+sbcl 11 | (eval-when (:compile-toplevel :load-toplevel :execute) 12 | (require :sb-sprof)) 13 | 14 | #+sbcl(progn 15 | 16 | (defvar *call-graph* nil) 17 | (defvar *node-numbers* nil) 18 | (defvar *number-nodes* nil) 19 | 20 | (defun frame-name (name) 21 | (if (consp name) 22 | (case (first name) 23 | ((sb-c::xep sb-c::tl-xep 24 | sb-c::&more-processor 25 | sb-c::top-level-form 26 | sb-c::&optional-processor) 27 | (second name)) 28 | (sb-pcl::fast-method 29 | (cdr name)) 30 | ((flet labels lambda) 31 | (let* ((in (member :in name))) 32 | (if (stringp (cadr in)) 33 | (append (ldiff name in) (cddr in)) 34 | name))) 35 | (t 36 | name)) 37 | name)) 38 | 39 | (defun pretty-name (name) 40 | (let ((*package* (find-package :common-lisp-user)) 41 | (*print-right-margin* most-positive-fixnum)) 42 | (format nil "~S" (frame-name name)))) 43 | 44 | (defun samples-percent (count) 45 | (sb-sprof::samples-percent *call-graph* count)) 46 | 47 | (defun node-values (node) 48 | (values (pretty-name (sb-sprof::node-name node)) 49 | (samples-percent (sb-sprof::node-count node)) 50 | (samples-percent (sb-sprof::node-accrued-count node)))) 51 | 52 | (defun filter-swank-nodes (nodes) 53 | (let ((swank-packages (load-time-value 54 | (mapcar #'find-package 55 | '(swank micros/rpc swank/mop 56 | micros/match micros/backend))))) 57 | (remove-if (lambda (node) 58 | (let ((name (sb-sprof::node-name node))) 59 | (and (symbolp name) 60 | (member (symbol-package name) swank-packages 61 | :test #'eq)))) 62 | nodes))) 63 | 64 | (defun serialize-call-graph (&key exclude-swank) 65 | (let ((nodes (sb-sprof::call-graph-flat-nodes *call-graph*))) 66 | (when exclude-swank 67 | (setf nodes (filter-swank-nodes nodes))) 68 | (setf nodes (sort (copy-list nodes) #'> 69 | ;; :key #'sb-sprof::node-count))) 70 | :key #'sb-sprof::node-accrued-count)) 71 | (setf *number-nodes* (make-hash-table)) 72 | (setf *node-numbers* (make-hash-table)) 73 | (loop for node in nodes 74 | for i from 1 75 | with total = 0 76 | collect (multiple-value-bind (name self cumulative) 77 | (node-values node) 78 | (setf (gethash node *node-numbers*) i 79 | (gethash i *number-nodes*) node) 80 | (incf total self) 81 | (list i name self cumulative total)) into list 82 | finally (return 83 | (let ((rest (- 100 total))) 84 | (return (append list 85 | `((nil "Elsewhere" ,rest nil nil))))))))) 86 | 87 | (defslimefun swank-sprof-get-call-graph (&key exclude-swank) 88 | (when (setf *call-graph* (sb-sprof:report :type nil)) 89 | (serialize-call-graph :exclude-swank exclude-swank))) 90 | 91 | (defslimefun swank-sprof-expand-node (index) 92 | (let* ((node (gethash index *number-nodes*))) 93 | (labels ((caller-count (v) 94 | (loop for e in (sb-sprof::vertex-edges v) do 95 | (when (eq (sb-sprof::edge-vertex e) node) 96 | (return-from caller-count (sb-sprof::call-count e)))) 97 | 0) 98 | (serialize-node (node count) 99 | (etypecase node 100 | (sb-sprof::cycle 101 | (list (sb-sprof::cycle-index node) 102 | (sb-sprof::cycle-name node) 103 | (samples-percent count))) 104 | (sb-sprof::node 105 | (let ((name (node-values node))) 106 | (list (gethash node *node-numbers*) 107 | name 108 | (samples-percent count))))))) 109 | (list :callers (loop for node in 110 | (sort (copy-list (sb-sprof::node-callers node)) #'> 111 | :key #'caller-count) 112 | collect (serialize-node node 113 | (caller-count node))) 114 | :calls (let ((edges (sort (copy-list (sb-sprof::vertex-edges node)) 115 | #'> 116 | :key #'sb-sprof::call-count))) 117 | (loop for edge in edges 118 | collect 119 | (serialize-node (sb-sprof::edge-vertex edge) 120 | (sb-sprof::call-count edge)))))))) 121 | 122 | (defslimefun swank-sprof-disassemble (index) 123 | (let* ((node (gethash index *number-nodes*)) 124 | (debug-info (sb-sprof::node-debug-info node))) 125 | (with-output-to-string (s) 126 | (typecase debug-info 127 | (sb-impl::code-component 128 | (sb-disassem::disassemble-memory (sb-vm::code-instructions debug-info) 129 | (sb-vm::%code-code-size debug-info) 130 | :stream s)) 131 | (sb-di::compiled-debug-fun 132 | (let ((component (sb-di::compiled-debug-fun-component debug-info))) 133 | (sb-disassem::disassemble-code-component component :stream s))) 134 | (t `(:error "No disassembly available")))))) 135 | 136 | (defslimefun swank-sprof-source-location (index) 137 | (let* ((node (gethash index *number-nodes*)) 138 | (debug-info (sb-sprof::node-debug-info node))) 139 | (or (when (typep debug-info 'sb-di::compiled-debug-fun) 140 | (let* ((component (sb-di::compiled-debug-fun-component debug-info)) 141 | (function #-#.(micros/backend:with-symbol '%code-entry-point 'sb-kernel) 142 | (sb-kernel::%code-entry-points component) 143 | #+#.(micros/backend:with-symbol '%code-entry-point 'sb-kernel) 144 | (sb-kernel:%code-entry-point component 0))) 145 | (when function 146 | (find-source-location function)))) 147 | `(:error "No source location available")))) 148 | 149 | (defslimefun swank-sprof-start (&key (mode :cpu)) 150 | (sb-sprof:start-profiling :mode mode)) 151 | 152 | (defslimefun swank-sprof-stop () 153 | (sb-sprof:stop-profiling)) 154 | 155 | ) 156 | -------------------------------------------------------------------------------- /contrib/micros-systems.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros) 2 | 3 | (defun find-quicklisp-systems () 4 | "If Quicklisp is available, extract all system names." 5 | (when (find-package '#:QUICKLISP) 6 | (mapcar (lambda (dist) 7 | (uiop:symbol-call '#:ql-dist '#:name dist)) 8 | (uiop:symbol-call '#:quicklisp '#:system-list)))) 9 | 10 | (defun find-ocicl-systems () 11 | "If the Ocicl runtime is available, extra all system names." 12 | (when (find-package '#:OCICL-RUNTIME) 13 | (uiop:symbol-call '#:ocicl-runtime '#:system-list))) 14 | 15 | (defun find-asdf-systems () 16 | "If ASDF is available, extract system names by collecting all keys from the *source-registry* hash lists." 17 | (when (find-package '#:ASDF) 18 | (loop :for system-name :being :each :hash-key :of asdf/source-registry:*source-registry* 19 | :collect system-name))) 20 | 21 | (defslimefun list-systems () 22 | "Returns a list of all locally available Quicklisp, Ocicl and ASDF systems." 23 | (asdf:ensure-source-registry) 24 | (sort (delete-duplicates 25 | (append (find-quicklisp-systems) 26 | (find-ocicl-systems) 27 | (find-asdf-systems)) 28 | :test #'string=) 29 | #'string<)) 30 | -------------------------------------------------------------------------------- /contrib/micros-test-runner.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/test-runner 2 | (:use :cl)) 3 | (in-package :micros/test-runner) 4 | 5 | (micros/swank-api:defslimefun run-test (name package-name) 6 | (uiop:symbol-call '#:rove '#:run-tests 7 | (list (read-from-string (format nil "~A::~A" package-name name))))) 8 | -------------------------------------------------------------------------------- /contrib/micros-trace-dialog.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/trace-dialog 2 | (:use :cl) 3 | (:import-from :micros :defslimefun :from-string :to-string) 4 | (:export #:clear-trace-tree 5 | #:dialog-toggle-trace 6 | #:dialog-trace 7 | #:dialog-traced-p 8 | #:dialog-untrace 9 | #:dialog-untrace-all 10 | #:inspect-trace-part 11 | #:report-partial-tree 12 | #:report-specs 13 | #:report-total 14 | #:report-trace-detail 15 | #:report-specs 16 | #:trace-format 17 | #:still-inside 18 | #:exited-non-locally 19 | #:*record-backtrace* 20 | #:*traces-per-report* 21 | #:*dialog-trace-follows-trace* 22 | #:find-trace-part 23 | #:find-trace)) 24 | 25 | (in-package :micros/trace-dialog) 26 | 27 | (defparameter *record-backtrace* nil 28 | "Record a backtrace of the last 20 calls for each trace. 29 | 30 | Beware that this may have a drastic performance impact on your 31 | program.") 32 | 33 | (defparameter *traces-per-report* 150 34 | "Number of traces to report to emacs in each batch.") 35 | 36 | 37 | ;;;; `trace-entry' model 38 | ;;;; 39 | (defvar *traces* (make-array 1000 :fill-pointer 0 40 | :adjustable t)) 41 | 42 | (defvar *trace-lock* (micros/backend:make-lock :name "swank-trace-dialog lock")) 43 | 44 | (defvar *current-trace-by-thread* (make-hash-table)) 45 | 46 | (defclass trace-entry () 47 | ((id :reader id-of) 48 | (children :accessor children-of :initform nil) 49 | (backtrace :accessor backtrace-of :initform (when *record-backtrace* 50 | (useful-backtrace))) 51 | 52 | (spec :initarg :spec :accessor spec-of 53 | :initform (error "must provide a spec")) 54 | (args :initarg :args :accessor args-of 55 | :initform (error "must provide args")) 56 | (parent :initarg :parent :reader parent-of 57 | :initform (error "must provide a parent, even if nil")) 58 | (retlist :initarg :retlist :accessor retlist-of 59 | :initform 'still-inside))) 60 | 61 | (defmethod initialize-instance :after ((entry trace-entry) &rest initargs) 62 | (declare (ignore initargs)) 63 | (if (parent-of entry) 64 | (nconc (children-of (parent-of entry)) (list entry))) 65 | (micros/backend:call-with-lock-held 66 | *trace-lock* 67 | #'(lambda () 68 | (setf (slot-value entry 'id) (fill-pointer *traces*)) 69 | (vector-push-extend entry *traces*)))) 70 | 71 | (defmethod print-object ((entry trace-entry) stream) 72 | (print-unreadable-object (entry stream) 73 | (format stream "~a: ~a" (id-of entry) (spec-of entry)))) 74 | 75 | (defun completed-p (trace) (not (eq (retlist-of trace) 'still-inside))) 76 | 77 | (defun find-trace (id) 78 | (when (<= 0 id (1- (length *traces*))) 79 | (aref *traces* id))) 80 | 81 | (defun find-trace-part (id part-id type) 82 | (let* ((trace (find-trace id)) 83 | (l (and trace 84 | (ecase type 85 | (:arg (args-of trace)) 86 | (:retval (micros::ensure-list (retlist-of trace))))))) 87 | (values (nth part-id l) 88 | (< part-id (length l))))) 89 | 90 | (defun useful-backtrace () 91 | (micros/backend:call-with-debugging-environment 92 | #'(lambda () 93 | (loop for i from 0 94 | for frame in (micros/backend:compute-backtrace 0 20) 95 | collect (list i (micros::frame-to-string frame)))))) 96 | 97 | (defun current-trace () 98 | (gethash (micros/backend:current-thread) *current-trace-by-thread*)) 99 | 100 | (defun (setf current-trace) (trace) 101 | (setf (gethash (micros/backend:current-thread) *current-trace-by-thread*) 102 | trace)) 103 | 104 | 105 | ;;;; Control of traced specs 106 | ;;; 107 | (defvar *traced-specs* '()) 108 | 109 | (defslimefun dialog-trace (spec) 110 | (flet ((before-hook (args) 111 | (setf (current-trace) (make-instance 'trace-entry 112 | :spec spec 113 | :args args 114 | :parent (current-trace)))) 115 | (after-hook (retlist) 116 | (let ((trace (current-trace))) 117 | (when trace 118 | ;; the current trace might have been wiped away if the 119 | ;; user cleared the tree in the meantime. no biggie, 120 | ;; don't do anything. 121 | ;; 122 | (setf (retlist-of trace) retlist 123 | (current-trace) (parent-of trace)))))) 124 | (when (dialog-traced-p spec) 125 | (warn "~a is apparently already traced! Untracing and retracing." spec) 126 | (dialog-untrace spec)) 127 | (micros/backend:wrap spec 'trace-dialog 128 | :before #'before-hook 129 | :after #'after-hook) 130 | (pushnew spec *traced-specs*) 131 | (format nil "~a is now traced for trace dialog" spec))) 132 | 133 | (defslimefun dialog-untrace (spec) 134 | (micros/backend:unwrap spec 'trace-dialog) 135 | (setq *traced-specs* (remove spec *traced-specs* :test #'equal)) 136 | (format nil "~a is now untraced for trace dialog" spec)) 137 | 138 | (defslimefun dialog-toggle-trace (spec) 139 | (if (dialog-traced-p spec) 140 | (dialog-untrace spec) 141 | (dialog-trace spec))) 142 | 143 | (defslimefun dialog-traced-p (spec) 144 | (find spec *traced-specs* :test #'equal)) 145 | 146 | (defslimefun dialog-untrace-all () 147 | (untrace) 148 | (mapcar #'dialog-untrace *traced-specs*)) 149 | 150 | (defparameter *dialog-trace-follows-trace* nil) 151 | 152 | (setq micros:*after-toggle-trace-hook* 153 | #'(lambda (spec traced-p) 154 | (when *dialog-trace-follows-trace* 155 | (cond (traced-p 156 | (dialog-trace spec) 157 | "traced for trace dialog as well") 158 | (t 159 | (dialog-untrace spec) 160 | "untraced for the trace dialog as well"))))) 161 | 162 | 163 | ;;;; A special kind of trace call 164 | ;;; 165 | (defun trace-format (format-spec &rest format-args) 166 | "Make a string from FORMAT-SPEC and FORMAT-ARGS and as a trace." 167 | (let* ((line (apply #'format nil format-spec format-args))) 168 | (make-instance 'trace-entry :spec line 169 | :args format-args 170 | :parent (current-trace) 171 | :retlist nil))) 172 | 173 | 174 | ;;;; Reporting to emacs 175 | ;;; 176 | (defparameter *visitor-idx* 0) 177 | 178 | (defparameter *visitor-key* nil) 179 | 180 | (defvar *unfinished-traces* '()) 181 | 182 | (defun describe-trace-for-emacs (trace) 183 | `(,(id-of trace) 184 | ,(and (parent-of trace) (id-of (parent-of trace))) 185 | ,(spec-of trace) 186 | ,(loop for arg in (args-of trace) 187 | for i from 0 188 | collect (list i (micros::to-line arg))) 189 | ,(loop for retval in (micros::ensure-list (retlist-of trace)) 190 | for i from 0 191 | collect (list i (micros::to-line retval))))) 192 | 193 | (defslimefun report-partial-tree (key) 194 | (unless (equal key *visitor-key*) 195 | (setq *visitor-idx* 0 196 | *visitor-key* key)) 197 | (let* ((recently-finished 198 | (loop with i = 0 199 | for trace in *unfinished-traces* 200 | while (< i *traces-per-report*) 201 | when (completed-p trace) 202 | collect trace 203 | and do 204 | (incf i) 205 | (setq *unfinished-traces* 206 | (remove trace *unfinished-traces*)))) 207 | (new (loop for i 208 | from (length recently-finished) 209 | below *traces-per-report* 210 | while (< *visitor-idx* (length *traces*)) 211 | for trace = (aref *traces* *visitor-idx*) 212 | collect trace 213 | unless (completed-p trace) 214 | do (push trace *unfinished-traces*) 215 | do (incf *visitor-idx*)))) 216 | (list 217 | (mapcar #'describe-trace-for-emacs 218 | (append recently-finished new)) 219 | (- (length *traces*) *visitor-idx*) 220 | key))) 221 | 222 | (defslimefun report-trace-detail (trace-id) 223 | (micros::call-with-bindings 224 | micros::*inspector-printer-bindings* 225 | #'(lambda () 226 | (let ((trace (find-trace trace-id))) 227 | (when trace 228 | (append 229 | (describe-trace-for-emacs trace) 230 | (list (backtrace-of trace) 231 | (micros::to-line trace)))))))) 232 | 233 | (defslimefun report-specs () 234 | (sort (copy-list *traced-specs*) 235 | #'string< 236 | :key #'princ-to-string)) 237 | 238 | (defslimefun report-total () 239 | (length *traces*)) 240 | 241 | (defslimefun clear-trace-tree () 242 | (setf *current-trace-by-thread* (clrhash *current-trace-by-thread*) 243 | *visitor-key* nil 244 | *unfinished-traces* nil) 245 | (micros/backend:call-with-lock-held 246 | *trace-lock* 247 | #'(lambda () (setf (fill-pointer *traces*) 0))) 248 | nil) 249 | 250 | ;; HACK: `micros::*inspector-history*' is unbound by default and needs 251 | ;; a reset in that case so that it won't error `micros::inspect-object' 252 | ;; before any other object is inspected in the slime session. 253 | ;; 254 | (unless (boundp 'micros::*inspector-history*) 255 | (micros::reset-inspector)) 256 | 257 | (defslimefun inspect-trace-part (trace-id part-id type) 258 | (multiple-value-bind (obj found) 259 | (find-trace-part trace-id part-id type) 260 | (if found 261 | (micros::inspect-object obj) 262 | (error "No object found with ~a, ~a and ~a" trace-id part-id type)))) 263 | -------------------------------------------------------------------------------- /contrib/micros-trace.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/trace 2 | (:use :cl)) 3 | (in-package :micros/trace) 4 | 5 | (defvar *traces* '()) 6 | 7 | (defun already-traced-p (name) 8 | (find name *traces*)) 9 | 10 | (defun remove-trace (name) 11 | (setf *traces* (remove name *traces*))) 12 | 13 | (defun add-trace (name) 14 | (push name *traces*)) 15 | 16 | (defvar *depth* 0) 17 | 18 | (defun print-indentation () 19 | (loop :repeat (* *depth* 2) :do (write-char #\space)) 20 | (format t "~D: " *depth*)) 21 | 22 | (defun send-write-objects-event (objects) 23 | (loop :for first := t :then nil 24 | :for object :in objects 25 | :do (write-char #\space) 26 | (micros::send-write-object-event object))) 27 | 28 | (defun coerce-to-symbol (name) 29 | (etypecase name 30 | (symbol name) 31 | (string (micros:from-string name)))) 32 | 33 | (micros/swank-api:defslimefun micros-trace (name) 34 | (let ((name (coerce-to-symbol name))) 35 | (when (already-traced-p name) 36 | (warn "~a is apparently already traced! Untracing and retracing." name) 37 | (micros-untrace name)) 38 | (flet ((before-hook (args) 39 | (micros::with-editor-stream () 40 | (print-indentation) 41 | (format t "(~S" name) 42 | (send-write-objects-event args) 43 | (format t ")~%") 44 | (incf *depth*))) 45 | (after-hook (retlist) 46 | (micros::with-editor-stream () 47 | (decf *depth*) 48 | (print-indentation) 49 | (format t "~A returned" name) 50 | (send-write-objects-event (uiop:ensure-list retlist)) 51 | (terpri)))) 52 | (handler-case 53 | (micros/backend:wrap name 'micros-trace 54 | :before #'before-hook 55 | :after #'after-hook) 56 | (error () 57 | (return-from micros-trace (format nil "ERROR: ~A could not be traced." name)))) 58 | (add-trace name) 59 | (format nil "~A is now traced." name)))) 60 | 61 | (micros/swank-api:defslimefun micros-untrace (name) 62 | (let ((name (coerce-to-symbol name))) 63 | (micros/backend:unwrap name 'micros-trace) 64 | (remove-trace name) 65 | (format nil "~A is now untraced." name))) 66 | 67 | (micros/swank-api:defslimefun micros-trace-list () 68 | (mapcar (lambda (name) 69 | (let ((*package* micros::*swank-io-package*)) 70 | (prin1-to-string name))) 71 | *traces*)) 72 | 73 | (micros/swank-api:defslimefun toggle-trace (name) 74 | (let ((name (coerce-to-symbol name))) 75 | (if (already-traced-p name) 76 | (micros-untrace name) 77 | (micros-trace name)))) 78 | -------------------------------------------------------------------------------- /contrib/micros-util.lisp: -------------------------------------------------------------------------------- 1 | ;;; swank-util.lisp --- stuff of questionable utility 2 | ;; 3 | ;; License: public domain 4 | 5 | (in-package :micros) 6 | 7 | (defmacro do-symbols* ((var &optional (package '*package*) result-form) 8 | &body body) 9 | "Just like do-symbols, but makes sure a symbol is visited only once." 10 | (let ((seen-ht (gensym "SEEN-HT"))) 11 | `(let ((,seen-ht (make-hash-table :test #'eq))) 12 | (do-symbols (,var ,package ,result-form) 13 | (unless (gethash ,var ,seen-ht) 14 | (setf (gethash ,var ,seen-ht) t) 15 | (tagbody ,@body)))))) 16 | 17 | (defun classify-symbol (symbol) 18 | "Returns a list of classifiers that classify SYMBOL according to its 19 | underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special 20 | variable.) The list may contain the following classification 21 | keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION, 22 | :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE" 23 | (check-type symbol symbol) 24 | (flet ((type-specifier-p (s) 25 | (or (documentation s 'type) 26 | (not (eq (type-specifier-arglist s) :not-available))))) 27 | (let (result) 28 | (when (boundp symbol) (push (if (constantp symbol) 29 | :constant :boundp) result)) 30 | (when (fboundp symbol) (push :fboundp result)) 31 | (when (type-specifier-p symbol) (push :typespec result)) 32 | (when (find-class symbol nil) (push :class result)) 33 | (when (macro-function symbol) (push :macro result)) 34 | (when (special-operator-p symbol) (push :special-operator result)) 35 | (when (find-package symbol) (push :package result)) 36 | (when (and (fboundp symbol) 37 | (typep (ignore-errors (fdefinition symbol)) 38 | 'generic-function)) 39 | (push :generic-function result)) 40 | result))) 41 | 42 | (defun symbol-classification-string (symbol) 43 | "Return a string in the form -f-c---- where each letter stands for 44 | boundp fboundp generic-function class macro special-operator package" 45 | (let ((letters "bfgctmsp") 46 | (result (copy-seq "--------"))) 47 | (flet ((flip (letter) 48 | (setf (char result (position letter letters)) 49 | letter))) 50 | (when (boundp symbol) (flip #\b)) 51 | (when (fboundp symbol) 52 | (flip #\f) 53 | (when (typep (ignore-errors (fdefinition symbol)) 54 | 'generic-function) 55 | (flip #\g))) 56 | (when (type-specifier-p symbol) (flip #\t)) 57 | (when (find-class symbol nil) (flip #\c) ) 58 | (when (macro-function symbol) (flip #\m)) 59 | (when (special-operator-p symbol) (flip #\s)) 60 | (when (find-package symbol) (flip #\p)) 61 | result))) 62 | -------------------------------------------------------------------------------- /contrib/walker/TODO: -------------------------------------------------------------------------------- 1 | ;; -*- mode:lisp -*- 2 | 3 | - [X] DEFUN 3154 4 | - [X] SETF 1685 5 | - [X] WHEN 1397 6 | - [X] OR 921 7 | - [X] AND 895 8 | - [X] DEFMETHOD 719 9 | - [X] LAMBDA 683 10 | - [X] LOOP 637 11 | - [X] UNLESS 581 12 | - [ ] DEFVAR 524 13 | - [X] RETURN 522 14 | - [X] COND 446 15 | - [ ] DO 442 16 | - [X] IN-PACKAGE 379 17 | - [ ] DEFPACKAGE 272 18 | - [ ] DEFCLASS 235 19 | - [ ] PUSH 161 20 | - [ ] DOLIST 161 21 | - [ ] DEFGENERIC 158 22 | - [ ] ASSERT 158 23 | - [ ] MULTIPLE-VALUE-BIND 157 24 | - [ ] CHECK-TYPE 143 25 | - [ ] DEFMACRO 141 26 | - [ ] CASE 114 27 | - [X] INCF 113 28 | - [ ] HANDLER-CASE 100 29 | - [ ] DEFPARAMETER 97 30 | - [ ] DESTRUCTURING-BIND 91 31 | - [ ] DEFSTRUCT 90 32 | - [ ] WITH-OUTPUT-TO-STRING 68 33 | - [X] DECF 52 34 | - [ ] DOTIMES 48 35 | - [ ] ETYPECASE 42 36 | - [ ] PROG1 41 37 | - [ ] IGNORE-ERRORS 39 38 | - [ ] ECASE 38 39 | - [ ] DEFINE-CONDITION 37 40 | - [ ] WITH-SLOTS 35 41 | - [ ] DEFTYPE 30 42 | - [ ] POP 29 43 | - [ ] HANDLER-BIND 28 44 | - [ ] WITH-OPEN-FILE 24 45 | - [ ] MULTIPLE-VALUE-LIST 23 46 | - [ ] DEFCONSTANT 23 47 | - [ ] PUSHNEW 22 48 | - [ ] TIME 19 49 | - [ ] TYPECASE 18 50 | - [ ] WITH-INPUT-FROM-STRING 18 51 | - [ ] TRACE 17 52 | - [ ] ROTATEF 15 53 | - [X] NTH-VALUE 14 54 | - [ ] PRINT-UNREADABLE-OBJECT 12 55 | - [ ] DECLAIM 11 56 | - [ ] MULTIPLE-VALUE-SETQ 10 57 | - [ ] WITH-OPEN-STREAM 9 58 | - [ ] WITH-ACCESSORS 8 59 | - [ ] PROG 7 60 | - [ ] DEFINE-COMPILER-MACRO 5 61 | - [ ] RESTART-CASE 5 62 | - [ ] WITH-STANDARD-IO-SYNTAX 5 63 | - [ ] DEFINE-SYMBOL-MACRO 4 64 | - [ ] PROG2 4 65 | - [ ] STEP 3 66 | - [ ] DEFSETF 3 67 | - [ ] DEFINE-SETF-EXPANDER 3 68 | - [ ] DEFINE-MODIFY-MACRO 3 69 | - [ ] CCASE 3 70 | - [ ] CTYPECASE 3 71 | - [ ] RESTART-BIND 3 72 | - [ ] WITH-COMPILATION-UNIT 3 73 | - [ ] WITH-CONDITION-RESTARTS 3 74 | - [ ] DO-ALL-SYMBOLS 2 75 | - [ ] PPRINT-LOGICAL-BLOCK 2 76 | - [ ] PSETF 2 77 | - [ ] UNTRACE 2 78 | - [ ] DEFINE-METHOD-COMBINATION 2 79 | - [ ] WITH-HASH-TABLE-ITERATOR 2 80 | - [ ] WITH-PACKAGE-ITERATOR 2 81 | - [ ] WITH-SIMPLE-RESTART 2 82 | - [ ] DO-EXTERNAL-SYMBOLS 2 83 | - [ ] CALL-METHOD 1 84 | - [ ] DO-SYMBOLS 1 85 | - [ ] FORMATTER 1 86 | - [ ] LOOP-FINISH 1 87 | - [ ] PPRINT-EXIT-IF-LIST-EXHAUSTED 1 88 | - [ ] PPRINT-POP 1 89 | - [ ] PSETQ 1 90 | - [ ] REMF 1 91 | - [ ] SHIFTF 1 92 | 93 | * ローカル関数の(setf ...)を扱えない 94 | (let (storage) 95 | (flet (((setf storage) (value) 96 | (setf storage value))) 97 | (setf (storage) 100)) 98 | storage) 99 | -------------------------------------------------------------------------------- /contrib/walker/data-and-control-flow.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros/walker) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defstruct walker-lambda-list-spec 5 | required-arguments 6 | optional-arguments 7 | optional-position 8 | rest-variable 9 | rest-pos) 10 | 11 | (defun all-arguments (spec) 12 | (append (walker-lambda-list-spec-required-arguments spec) 13 | (when (walker-lambda-list-spec-rest-variable spec) 14 | (list (walker-lambda-list-spec-rest-variable spec))) 15 | (walker-lambda-list-spec-optional-arguments spec))) 16 | 17 | (defun parse-walker-lambda-list (lambda-list) 18 | (let ((rest-pos (or (position '&rest lambda-list) 19 | (position '&body lambda-list))) 20 | (optional-pos (position '&optional lambda-list))) 21 | (make-walker-lambda-list-spec 22 | :required-arguments (subseq lambda-list 0 (or optional-pos rest-pos)) 23 | :optional-arguments (when optional-pos (subseq lambda-list (1+ optional-pos))) 24 | :optional-position optional-pos 25 | :rest-variable (when rest-pos (elt lambda-list (1+ rest-pos))) 26 | :rest-pos rest-pos))) 27 | 28 | (defun reader-name (symbol) 29 | (intern (format nil "AST-~A" symbol))) 30 | 31 | (defun expand-simple-walker-defclass (walker-name spec) 32 | `(defclass ,walker-name (ast) 33 | ,(loop :for argument 34 | :in (all-arguments spec) 35 | :collect `(,argument :initarg ,(make-keyword argument) 36 | :reader ,(reader-name argument))))) 37 | 38 | (defun expand-simple-walker-defmethod-walk-form 39 | (walker-name operator-name spec) 40 | (with-gensyms (walker name form env path arg) 41 | `(defmethod walk-form ((,walker walker) 42 | (,name (eql ',operator-name)) 43 | ,form ,env ,path) 44 | (make-instance 45 | ',walker-name 46 | ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec) 47 | :for n :from 1 48 | :collect (make-keyword argument) 49 | :collect `(walk ,walker 50 | (elt ,form ,n) 51 | ,env 52 | (cons ,n ,path))) 53 | ,@(when (walker-lambda-list-spec-optional-position spec) 54 | (loop :for argument :in (walker-lambda-list-spec-optional-arguments spec) 55 | :for n :from (1+ (walker-lambda-list-spec-optional-position spec)) 56 | :collect (make-keyword argument) 57 | :collect `(let ((,arg (nth ,n ,form))) 58 | (when ,arg 59 | (walk ,walker 60 | ,arg 61 | ,env 62 | (cons ,n ,path)))))) 63 | ,@(when (walker-lambda-list-spec-rest-variable spec) 64 | (with-gensyms (var n) 65 | `(,(make-keyword (walker-lambda-list-spec-rest-variable spec)) 66 | (loop :for ,var :in (nthcdr ,(walker-lambda-list-spec-rest-pos spec) ,form) 67 | :for ,n :from ,(walker-lambda-list-spec-rest-pos spec) 68 | :collect (walk ,walker ,var ,env (cons ,n ,path)))))))))) 69 | 70 | (defun expand-simple-walker-defmethod-visit (walker-name spec) 71 | (with-gensyms (visitor ast) 72 | `(defmethod visit (,visitor (,ast ,walker-name)) 73 | ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec) 74 | :collect `(visit ,visitor (,(reader-name argument) ,ast))) 75 | ,@(loop :for argument :in (walker-lambda-list-spec-optional-arguments spec) 76 | :collect `(when (,(reader-name argument) ,ast) 77 | (visit ,visitor (,(reader-name argument) ,ast)))) 78 | ,(when (walker-lambda-list-spec-rest-variable spec) 79 | `(visit-foreach ,visitor 80 | (,(reader-name (walker-lambda-list-spec-rest-variable spec)) ,ast)))))) 81 | 82 | (defun expand-simple-walker (walker-name operator-name lambda-list) 83 | (let ((spec (parse-walker-lambda-list lambda-list))) 84 | `(progn 85 | ,(expand-simple-walker-defclass 86 | walker-name 87 | spec) 88 | ,(expand-simple-walker-defmethod-walk-form 89 | walker-name 90 | operator-name 91 | spec) 92 | ,(expand-simple-walker-defmethod-visit 93 | walker-name 94 | spec))))) 95 | 96 | (defmacro def-simple-walker (walker-name operator-name lambda-list) 97 | (expand-simple-walker walker-name operator-name lambda-list)) 98 | 99 | (def-simple-walker nth-value-form nth-value (n form)) 100 | (def-simple-walker incf-form incf (n form)) 101 | (def-simple-walker decf-form decf (n form)) 102 | (def-simple-walker or-form or (&rest forms)) 103 | (def-simple-walker and-form and (&rest forms)) 104 | (def-simple-walker when-form when (test &body forms)) 105 | (def-simple-walker unless-form unless (test &body forms)) 106 | (def-simple-walker return-form return (&optional value)) 107 | (def-simple-walker in-package-form in-package (string-designator)) 108 | 109 | ;; check-type 110 | (defclass check-type-form (ast) 111 | ((place :initarg :place :reader ast-place) 112 | (type :initarg :type :reader ast-type) 113 | (type-string :initarg :type-string :reader ast-type-string))) 114 | 115 | (defmethod walk-form ((walker walker) (name (eql 'check-type)) form env path) 116 | (with-walker-bindings (place type &optional type-string) (rest form) 117 | (let ((place (walk walker place env (cons 1 path))) 118 | (type-string (walk walker type-string env (cons 3 path)))) 119 | (make-instance 'check-type-form 120 | :place place 121 | :type type 122 | :type-string type-string)))) 123 | 124 | (defmethod visit (visitor (ast check-type-form)) 125 | (visit visitor (ast-place ast)) 126 | (visit visitor (ast-type-string ast))) 127 | 128 | ;; setf 129 | (defclass setf-form (ast) 130 | ((forms :initarg :forms 131 | :reader ast-forms))) 132 | 133 | (defclass setf-symbol-form (ast) 134 | ((var :initarg :var 135 | :type binding 136 | :reader ast-var) 137 | (value :initarg :value 138 | :reader ast-value))) 139 | 140 | (defclass setf-complex-form (ast) 141 | ((operator :initarg :operator 142 | :type variable-symbol 143 | :reader ast-operator) 144 | (arguments :initarg :arguments 145 | :reader ast-arguments) 146 | (value :initarg :value 147 | :reader ast-value))) 148 | 149 | (defmethod walk-form ((walker walker) (name (eql 'setf)) form env path) 150 | (make-instance 151 | 'setf-form 152 | :path path 153 | :forms (loop :for (place value) :on (rest form) :by #'cddr 154 | :for n :from 1 :by 2 155 | :for walked-value := (walk walker 156 | value 157 | env 158 | (cons (1+ n) path)) 159 | :collect (if (symbolp place) 160 | (make-instance 'setf-symbol-form 161 | :var (walk-variable walker place env (cons n path)) 162 | :value walked-value) 163 | (make-instance 'setf-complex-form 164 | :operator (first place) 165 | :arguments (loop :for m :from 1 166 | :for arg :in (rest place) 167 | :collect (walk walker 168 | arg 169 | env 170 | (list* m n path))) 171 | :value walked-value))))) 172 | 173 | (defmethod visit (visitor (ast setf-form)) 174 | (visit-foreach visitor (ast-forms ast))) 175 | 176 | (defmethod visit (visitor (ast setf-symbol-form)) 177 | (visit visitor (ast-var ast)) 178 | (visit visitor (ast-value ast))) 179 | 180 | (defmethod visit (visitor (ast setf-complex-form)) 181 | (visit-foreach visitor (ast-arguments ast)) 182 | (visit visitor (ast-value ast))) 183 | 184 | ;; cond 185 | (defclass cond-form (ast) 186 | ((clauses :initarg :clauses :reader ast-clauses))) 187 | 188 | (defclass cond-clause (ast) 189 | ((test :initarg :test :reader ast-test) 190 | (then :initarg :then :reader ast-then))) 191 | 192 | (defmethod walk-form ((walker walker) (name (eql 'cond)) form env path) 193 | (make-instance 194 | 'cond-form 195 | :clauses (loop :for clause :in (rest form) 196 | :for n :from 1 197 | :collect (with-walker-bindings (test &rest then) clause 198 | (make-instance 199 | 'cond-clause 200 | :test (walk walker test env (list* 0 n path)) 201 | :then (walk-forms walker then env (cons n path) 1)))))) 202 | 203 | (defmethod visit (visitor (ast cond-form)) 204 | (visit-foreach visitor (ast-clauses ast))) 205 | 206 | (defmethod visit (visitor (ast cond-clause)) 207 | (visit visitor (ast-test ast)) 208 | (visit-foreach visitor (ast-then ast))) 209 | -------------------------------------------------------------------------------- /contrib/walker/defmethod-form.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros/walker) 2 | 3 | (defclass defmethod-form (ast) 4 | ((block-form :initarg :block-form 5 | :reader ast-block-form 6 | :type block-name-form) 7 | (name :initarg :name 8 | :reader ast-name) 9 | (lambda-list :initarg :lambda-list 10 | :reader ast-lambda-list) 11 | (body :initarg :body 12 | :type implict-progn-form 13 | :reader ast-body))) 14 | 15 | (defun take-method-qualifiers (args) 16 | (let ((method-qualifiers 17 | (loop :while (typep (first args) 'non-list) 18 | :collect (pop args)))) 19 | (values method-qualifiers args))) 20 | 21 | (defmethod walk-specialized-lambda-list ((walker walker) specialized-lambda-list env path) 22 | (let ((walked-lambda-list '()) 23 | (initial-forms '())) 24 | (labels ((add (binding path) 25 | (setf env (extend-env env binding)) 26 | (push (make-instance 'lambda-list-variable-form 27 | :binding binding 28 | :path path) 29 | walked-lambda-list))) 30 | (loop :with state := nil 31 | :for n :from 0 32 | :for arg :in specialized-lambda-list 33 | :do (case arg 34 | ((&aux &key &rest &body &optional) 35 | (setf state arg)) 36 | (otherwise 37 | (ecase state 38 | ((&rest &body) 39 | (assert-type arg 'variable-symbol) 40 | ;; TODO: special variable 41 | (add (make-instance 'lexical-variable-binding :name arg) 42 | (cons n path))) 43 | ((&key &optional &aux) 44 | (let* ((var-value (uiop:ensure-list arg)) 45 | (var (first var-value)) 46 | (value (second var-value))) 47 | (assert-type var 'variable-symbol) 48 | (let ((initial-value 49 | (when value 50 | (walk walker value env (list* 1 n path))))) 51 | (when initial-value 52 | (push initial-value initial-forms)) 53 | (add (make-instance 'lexical-variable-binding ; TODO: special variable 54 | :name var 55 | :value initial-value) 56 | (if (consp arg) 57 | (list* 0 n path) 58 | (cons n path)))))) 59 | ((nil) 60 | (with-walker-bindings (var specializer) 61 | (if (consp arg) arg (list arg t)) 62 | (declare (ignore specializer)) 63 | (assert-type var 'variable-symbol) 64 | ;; TODO: special variable 65 | (add (make-instance 'lexical-variable-binding :name var) 66 | (if (consp arg) 67 | (list* 0 n path) 68 | (cons n path)))))))))) 69 | (values (make-instance 'lambda-list-form 70 | :variables walked-lambda-list 71 | :initial-forms initial-forms 72 | :path path) 73 | env))) 74 | 75 | (defmethod walk-form ((walker walker) (name (eql 'defmethod)) form env path) 76 | (with-walker-bindings (name &rest args) (rest form) 77 | (multiple-value-bind (method-qualifiers args) 78 | (take-method-qualifiers args) 79 | (with-walker-bindings (specialized-lambda-list &body body) args 80 | (multiple-value-bind (specialized-lambda-list env) 81 | (walk-specialized-lambda-list walker 82 | specialized-lambda-list 83 | env 84 | (cons (+ 2 (length method-qualifiers)) path)) 85 | (let* ((block-binding (make-instance 'block-binding :name name)) 86 | (env (extend-env env block-binding))) 87 | ;; TODO: declare 88 | (make-instance 'defmethod-form 89 | :block-form (make-instance 'block-name-form 90 | :binding block-binding 91 | :path (cons 1 path)) 92 | :name name 93 | :path (cons 0 path) 94 | :lambda-list specialized-lambda-list 95 | :body (make-instance 'implict-progn-form 96 | :forms (walk-forms walker 97 | body 98 | env 99 | path 100 | (+ 3 (length method-qualifiers))) 101 | :path path)))))))) 102 | 103 | (defmethod visit (visitor (ast defmethod-form)) 104 | (visit visitor (ast-block-form ast)) 105 | (visit visitor (ast-lambda-list ast)) 106 | (visit visitor (ast-body ast))) 107 | -------------------------------------------------------------------------------- /contrib/walker/defun-form.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros/walker) 2 | 3 | (defclass defun-form (ast) 4 | ((block-form :initarg :block-form 5 | :reader ast-block-form 6 | :type block-name-form) 7 | (name :initarg :name 8 | :type variable-symbol 9 | :reader ast-name) 10 | (lambda-list :initarg :lambda-list 11 | :reader ast-lambda-list) 12 | (body :initarg :body 13 | :type implict-progn-form 14 | :reader ast-body))) 15 | 16 | (defmethod walk-form ((walker walker) (name (eql 'defun)) form env path) 17 | (with-walker-bindings (name lambda-list &body body) (rest form) 18 | (multiple-value-bind (lambda-list env) 19 | (walk-lambda-list walker lambda-list env (cons 2 path)) 20 | (let* ((block-binding (make-instance 'block-binding :name name)) 21 | (env (extend-env env block-binding))) 22 | ;; TODO: declare 23 | (make-instance 'defun-form 24 | :block-form (make-instance 'block-name-form 25 | :binding block-binding 26 | :path (cons 1 path)) 27 | :name name 28 | :lambda-list lambda-list 29 | :body (make-instance 'implict-progn-form 30 | :forms (walk-forms walker body env path 3)) 31 | :path (cons 0 path)))))) 32 | 33 | (defmethod visit (visitor (ast defun-form)) 34 | (visit visitor (ast-block-form ast)) 35 | (visit visitor (ast-lambda-list ast)) 36 | (visit visitor (ast-body ast))) 37 | -------------------------------------------------------------------------------- /contrib/walker/example.lisp: -------------------------------------------------------------------------------- 1 | (block foo 2 | (return-from foo 10) 3 | (block foo 4 | (return-from foo 20) 5 | (return-from foo 30)) 6 | (return-from foo 40)) 7 | 8 | (let* ((a 0) 9 | (b a)) 10 | (let* ((a a) 11 | (b a)) 12 | a) 13 | a) 14 | 15 | (let ((a 1)) 16 | (let ((b a)) 17 | a 18 | b)) 19 | 20 | (let ((a 0) 21 | (b 1)) 22 | (load-time-value a b) 23 | (multiple-value-call 'f a b a) 24 | (setq a b 25 | b a) 26 | (progn a b) 27 | (multiple-value-prog1 a 28 | b 29 | a) 30 | (unwind-protect a (the integer b) c)) 31 | 32 | (lambda (x a b c &key (y x) z &aux (foo 10)) 33 | x 34 | y 35 | z 36 | foo) 37 | 38 | (function (lambda (x a b c &key (y x) z &aux (foo 10)) 39 | x 40 | y 41 | z 42 | foo)) 43 | 44 | (flet ((f ())) 45 | (flet ((f (&optional (x 1)) 46 | x 47 | #'f 48 | (f x))) 49 | (f x) 50 | #'f)) 51 | 52 | (labels ((f () (f))) 53 | (labels ((f (&optional (x 1)) 54 | x 55 | (f x))) 56 | #'f)) 57 | 58 | (labels ((f (x &key (y x)) 59 | (g x)) 60 | (g (y) 61 | (f y))) 62 | (g 10)) 63 | 64 | (defmacro with-hoge (() &body body) 65 | `(progn ,@body)) 66 | 67 | (let ((a 0)) 68 | (do ((x 1 (1+ x))) 69 | ((= 10 x)) 70 | a 71 | (let ((a 1)) 72 | a) 73 | b 74 | c)) 75 | 76 | (let ((a 0)) 77 | (WITH-HOGE NIL 78 | A 79 | B 80 | C)) 81 | 82 | (eval-when (:compile-toplevel :load-toplevel :execute) 83 | (let ((a 0)) 84 | a)) 85 | 86 | (macrolet ((with-foo (() &body body) 87 | )) 88 | (let ((a 0)) 89 | (with-foo ((aaa )) 90 | a))) 91 | 92 | (defmethod add (x y) 93 | (+ x y)) 94 | 95 | (defmethod add ((x integer) (y integer)) 96 | (+ x y)) 97 | 98 | (defmethod add :before ((x integer) (y integer)) 99 | (print (list x y))) 100 | 101 | 102 | ((lambda (a b) 103 | (+ a b)) 104 | 1 105 | 2) 106 | 107 | (let ((a 0)) 108 | a 109 | ((lambda (a) 110 | (declare (special a)) 111 | a)) 112 | ((lambda (a) 113 | (declare (special a)) 114 | a)) 115 | a) 116 | 117 | (with-open-file (in filename) 118 | (read-line in)) 119 | 120 | (let ((x 0)) 121 | (loop (f x))) 122 | 123 | (loop :with x := 0 124 | :with y := x 125 | :with z := (f x y)) 126 | 127 | (loop :with x := 0 128 | :return :it 129 | :return (f x)) 130 | 131 | (loop :with (x . y) := (f) 132 | :with a := x 133 | :with b := y) 134 | 135 | (loop :with ((x y) . z) := (f) 136 | :with a := (+ x y z)) 137 | 138 | (loop :for x :in '(1 2 3) :do (print x)) 139 | (loop :with foo 140 | :for x :in '(1 2 3) :do (print x)) 141 | (loop :with foo := nil 142 | :for x :in '(1 2 3) :do (print x)) 143 | (loop :with fn := #'cddr :and a 144 | :for x :in (list a) :by fn :do (print x)) 145 | 146 | (loop :for x :on '(1 2 3) :do (print x)) 147 | (loop :with foo 148 | :for x :on '(1 2 3) :do (print x)) 149 | (loop :with foo := nil 150 | :for x :on '(1 2 3) :do (print x)) 151 | (loop :with fn := #'cddr :and a 152 | :for x :on (list a) :by fn :do (print x)) 153 | (loop :for x := 1 154 | :do (f x)) 155 | (loop :for x := 1 :then (f x) 156 | :do (f x)) 157 | (loop :for (x . y) := (f) 158 | :do (f x y)) 159 | 160 | (loop for k being each hash-key in (plist-hash-table '((:a) 1 (:b) 2)) 161 | do (print k)) 162 | 163 | (let ((v 0)) 164 | (loop for k being each hash-key in (plist-hash-table '((:a) 1 (:b) 2)) 165 | using (hash-value v) 166 | do (print (cons k v))) 167 | v) 168 | 169 | (loop for v being the hash-value in *ht* 170 | do (print v)) 171 | (loop for v being each hash-values of *ht* using (hash-key k) 172 | do (format t "~a=>~a~%" k v)) 173 | 174 | (loop :for name :being :each :external-symbol 175 | :do (print name)) 176 | 177 | (let ((package-name (f))) 178 | (loop :for name :being :each :external-symbol :in package-name 179 | :do (print name))) 180 | 181 | (loop :for x := 1 :then (+ y 1) 182 | :and y := x :then (+ x 1)) 183 | 184 | (loop :for x := 1 :then (+ y 1) 185 | :and y := 2 :then (+ x 1) 186 | :do (cons x y)) 187 | 188 | (let ((start (f)) 189 | (end (g)) 190 | (step (h))) 191 | (loop :for x :from start :to end 192 | :do (print x)) 193 | 194 | (loop :for x :from start 195 | :do (print x)) 196 | 197 | (loop :for x :from start :to end 198 | :do (print x)) 199 | 200 | (loop :for x :from start :to end 201 | :do (print x)) 202 | 203 | (loop :for x :from start :to end :by step 204 | :do (print x)) 205 | 206 | (loop :for x :from start :downto end 207 | :do (print x)) 208 | 209 | (loop :for x :from start :above end 210 | :do (print x)) 211 | 212 | (loop :for x :downfrom start :to end 213 | :do (print x)) 214 | 215 | (loop :for x :from start :downto end 216 | :do (print x))) 217 | 218 | (loop :for x :from 0 :to 10 219 | :collect x) 220 | 221 | (loop :for x :from 0 :to 10 222 | :collect (f x)) 223 | 224 | (loop :for x :from 0 :to 10 225 | :when (f x) 226 | :count :it) 227 | 228 | (loop :for x :across "abc123" 229 | :when (digit-char-p x) 230 | :collect :it :and :collect :it) 231 | 232 | (let ((x 1)) 233 | (loop :for x :from x :to 10 234 | :collect x)) 235 | 236 | (loop :for x :from 1 :to 10 237 | :initially (print foo) 238 | :collect x :into foo 239 | :finally (print foo)) 240 | 241 | (loop :for x :from 1 :to 10 242 | :initially (print y) 243 | :collect (* x 2) :into y 244 | :finally (f x y)) 245 | 246 | (loop :for x :from 1 :to 10 247 | :if (f x) 248 | :do (g x)) 249 | 250 | (loop :for n :in list 251 | :do (f n) 252 | (g n)) 253 | 254 | (loop :for x :from 1 :to 10 255 | :initially (print foo) 256 | :collect x :into foo 257 | :finally (print foo)) 258 | 259 | (let ((a 0) 260 | b) 261 | a 262 | b) 263 | 264 | ;; TOOD 265 | (let (storage) 266 | (flet (((setf storage) (value) 267 | (setf storage value))) 268 | (setf (storage) 100)) 269 | storage) 270 | 271 | (let ((x 0)) 272 | (setf (car x) 100)) 273 | 274 | (let (a b c) 275 | (or a b c)) 276 | 277 | (let (x y z) 278 | (when x 279 | y 280 | z) 281 | ) 282 | 283 | (loop :for x :from 1 284 | :do (return x)) 285 | 286 | (defvar x 287 | (let ((foo 0)) 288 | foo)) 289 | 290 | (tagbody 291 | (uiop:println 1) 292 | (go foo) 293 | (uiop:println 2) 294 | foo 295 | (uiop:println 3)) 296 | 297 | (defun foo () 298 | (return-from foo 100)) 299 | 300 | (defmethod foo () 301 | (return-from foo 100)) 302 | -------------------------------------------------------------------------------- /contrib/walker/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/walker 2 | (:use :cl) 3 | (:export :walker 4 | :walk 5 | :collect-highlight-paths)) 6 | -------------------------------------------------------------------------------- /contrib/walker/tests/tests.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:micros/walker/tests 2 | (:use #:cl #:rove)) 3 | (in-package #:micros/walker/tests) 4 | 5 | (defun load-test-cases () 6 | (uiop:read-file-forms (asdf:system-relative-pathname :micros/tests "contrib/walker/tests/test-cases.lisp"))) 7 | 8 | ;; copy from alexandria 9 | (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) 10 | "Returns true if every element of LIST1 matches some element of LIST2 and 11 | every element of LIST2 matches some element of LIST1. Otherwise returns false." 12 | (let ((keylist1 (if keyp (mapcar key list1) list1)) 13 | (keylist2 (if keyp (mapcar key list2) list2))) 14 | (and (dolist (elt keylist1 t) 15 | (or (member elt keylist2 :test test) 16 | (return nil))) 17 | (dolist (elt keylist2 t) 18 | (or (member elt keylist1 :test test) 19 | (return nil)))))) 20 | 21 | (deftest random 22 | (loop :for (act-form expected) :in (load-test-cases) 23 | :for n :from 0 24 | :do (ok (set-equal expected 25 | (apply (first act-form) (rest act-form)) 26 | :test #'equal) 27 | (format nil "~D ~S" n act-form)))) 28 | -------------------------------------------------------------------------------- /contrib/walker/types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros/walker) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defun proper-list-p (x) 5 | (and (listp x) 6 | (null (cdr (last x)))))) 7 | 8 | (deftype proper-list (&optional (element-type '*)) 9 | (declare (ignore element-type)) 10 | '(and list (satisfies proper-list-p))) 11 | 12 | (deftype variable-symbol () 13 | '(and symbol (not keyword))) 14 | 15 | (deftype non-list () 16 | '(and (not null) (not list))) 17 | -------------------------------------------------------------------------------- /contrib/walker/utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :micros/walker) 2 | 3 | (defun string-prefix-p (prefix string) 4 | (and (<= (length prefix) (length string)) 5 | (string= prefix string :end2 (length prefix)))) 6 | 7 | (defun make-keyword (x) 8 | (intern (string x) :keyword)) 9 | 10 | ;;; copy from alexandria 11 | (deftype string-designator () 12 | "A string designator type. A string designator is either a string, a symbol, 13 | or a character." 14 | `(or symbol string character)) 15 | 16 | (defmacro with-gensyms (names &body forms) 17 | "Binds a set of variables to gensyms and evaluates the implicit progn FORMS. 18 | 19 | Each element within NAMES is either a symbol SYMBOL or a pair (SYMBOL 20 | STRING-DESIGNATOR). Bare symbols are equivalent to the pair (SYMBOL SYMBOL). 21 | 22 | Each pair (SYMBOL STRING-DESIGNATOR) specifies that the variable named by SYMBOL 23 | should be bound to a symbol constructed using GENSYM with the string designated 24 | by STRING-DESIGNATOR being its first argument." 25 | `(let ,(mapcar (lambda (name) 26 | (multiple-value-bind (symbol string) 27 | (etypecase name 28 | (symbol 29 | (values name (symbol-name name))) 30 | ((cons symbol (cons string-designator null)) 31 | (values (first name) (string (second name))))) 32 | `(,symbol (gensym ,string)))) 33 | names) 34 | ,@forms)) 35 | 36 | (defun parse-body (body &key documentation whole) 37 | (let ((doc nil) 38 | (decls nil) 39 | (current nil)) 40 | (tagbody 41 | :declarations 42 | (setf current (car body)) 43 | (when (and documentation (stringp current) (cdr body)) 44 | (if doc 45 | (error "Too many documentation strings in ~S." (or whole body)) 46 | (setf doc (pop body))) 47 | (go :declarations)) 48 | (when (and (listp current) (eql (first current) 'declare)) 49 | (push (pop body) decls) 50 | (go :declarations))) 51 | (values body (nreverse decls) doc))) 52 | -------------------------------------------------------------------------------- /lsp-api-load-systems.lisp: -------------------------------------------------------------------------------- 1 | ;;; trivial-system-loader.lisp 2 | ;;; 3 | ;;; SPDX-License-Identifier: MIT 4 | ;;; 5 | ;;; Copyright (C) 2024 Anthony Green and Michał 'phoe' Herda 6 | ;;; 7 | ;;; Permission is hereby granted, free of charge, to any person obtaining a copy 8 | ;;; of this software and associated documentation files (the "Software"), to deal 9 | ;;; in the Software without restriction, including without limitation the rights 10 | ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | ;;; copies of the Software, and to permit persons to whom the Software is 12 | ;;; furnished to do so, subject to the following conditions: 13 | ;;; 14 | ;;; The above copyright notice and this permission notice shall be included in all 15 | ;;; copies or substantial portions of the Software. 16 | ;;; 17 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | ;;; SOFTWARE. 24 | ;;; 25 | 26 | (in-package :micros/lsp-api) 27 | 28 | (defun load-systems (systems &key (verbose nil) (silent t)) 29 | "Load system SYSTEMS, potentially downloading them from an external 30 | repository. SYSTEMS may be a single system or a list of 31 | systems. Loader behavior is modified by VERBOSE and SILENT." 32 | (unless (listp systems) 33 | (setf systems (list systems))) 34 | (flet ((try-load-system (system) 35 | (or 36 | (when (find-package '#:OCICL-RUNTIME) 37 | (progv (list (find-symbol "*DOWNLOAD*" '#:OCICL-RUNTIME) 38 | (find-symbol "*VERBOSE*" '#:OCICL-RUNTIME)) 39 | (list t (or verbose (not silent))) 40 | (funcall (find-symbol "LOAD-SYSTEM" '#:asdf) system))) 41 | (when (find-package '#:QUICKLISP) 42 | (funcall (find-symbol "QUICKLOAD" '#:QUICKLISP) 43 | system :verbose verbose :silent silent)) 44 | (when (find-package '#:ASDF) 45 | (funcall (find-symbol "LOAD-SYSTEM" '#:ASDF) system)) 46 | (error "Unable to find any system-loading mechanism.")))) 47 | (mapcar #'try-load-system systems))) 48 | -------------------------------------------------------------------------------- /lsp-api.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :micros/lsp-api 2 | (:use :cl) 3 | (:export :hover-symbol 4 | :completions 5 | :make-symbol-spec 6 | :symbol-informations 7 | :load-systems 8 | :compile-and-load-file 9 | :eval-for-language-server 10 | :eval-result-value 11 | :eval-result-error)) 12 | (in-package :micros/lsp-api) 13 | 14 | ;;; hover-symbol 15 | #+sbcl 16 | (defun describe-variable (symbol) 17 | (list "Variable" 18 | (with-output-to-string (stream) 19 | (when (boundp symbol) 20 | (sb-impl::describe-variable symbol stream))))) 21 | 22 | #-sbcl 23 | (defun describe-variable (symbol) 24 | (list "Variable" 25 | (with-output-to-string (stream) 26 | (when (boundp symbol) "")))) 27 | 28 | (defun describe-function (symbol) 29 | (list "Function" 30 | (with-output-to-string (stream) 31 | (when (fboundp symbol) 32 | (let ((arglist (cons symbol (micros/backend:arglist symbol)))) 33 | (write-line "```lisp" stream) 34 | (let ((*print-case* :downcase)) 35 | (format stream "~(~A~)~%" arglist)) 36 | (write-line "```" stream) 37 | (let ((doc (documentation symbol 'function))) 38 | (when doc 39 | (write-line doc stream)))))))) 40 | 41 | #+sbcl 42 | (defun describe-class (symbol) 43 | (list "Class" 44 | (with-output-to-string (stream) 45 | (sb-impl::describe-class symbol nil stream)))) 46 | 47 | #-sbcl 48 | (defun describe-class (symbol) 49 | (list "Class" 50 | (with-output-to-string (stream) 51 | ""))) 52 | 53 | #+sbcl 54 | (defun describe-type (symbol) 55 | (list "Type" 56 | (with-output-to-string (stream) 57 | (sb-impl::describe-type symbol stream)))) 58 | 59 | #-sbcl 60 | (defun describe-type (symbol) 61 | (list "Type" 62 | (with-output-to-string (stream) 63 | ""))) 64 | 65 | #+sbcl 66 | (defun describe-declaration (symbol) 67 | (list "Declaration" 68 | (with-output-to-string (stream) 69 | (sb-impl::describe-declaration symbol stream)))) 70 | 71 | #-sbcl 72 | (defun describe-declaration (symbol) 73 | (list "Declaration" 74 | (with-output-to-string (stream) 75 | ""))) 76 | 77 | (defun describe-plist (symbol) 78 | (list "Symbol-plist:" 79 | (with-output-to-string (stream) 80 | (let ((plist (symbol-plist symbol))) 81 | (when plist 82 | (loop :for (k v) :on plist :by #'cddr 83 | :do (format stream 84 | " ~@:_~A -> ~A~%" 85 | (prin1-to-string k) 86 | (prin1-to-string v)))))))) 87 | 88 | (defun describe-symbol-in-markdown (symbol) 89 | (string-right-trim '(#\newline #\space) 90 | (with-output-to-string (stream) 91 | (let ((contents 92 | (remove "" 93 | (list (describe-variable symbol) 94 | (describe-function symbol) 95 | (describe-class symbol) 96 | (describe-type symbol) 97 | (describe-declaration symbol) 98 | (describe-plist symbol)) 99 | :key #'second 100 | :test #'string=))) 101 | (loop :for (header body) :in contents 102 | :for first := t :then nil 103 | :do (unless first 104 | (write-line "----------" stream)) 105 | (format stream "## ~A~%" header) 106 | (write-string body stream)))))) 107 | 108 | (defun hover-symbol (symbol-name) 109 | (micros::with-buffer-syntax () 110 | (multiple-value-bind (symbol status) 111 | (micros::parse-symbol symbol-name) 112 | (when status 113 | (describe-symbol-in-markdown symbol))))) 114 | 115 | ;;; completions 116 | (defstruct (completed-item (:type list)) 117 | label 118 | chunks 119 | classification 120 | signature 121 | documentation 122 | sort-text) 123 | 124 | (defun parse-classification-string (classification-string) 125 | (loop :for classification :in '(:variable 126 | :function 127 | :generic-function 128 | :type 129 | :class 130 | :macro 131 | :special-operator 132 | :package) 133 | :for i :from 0 134 | :unless (char= #\- (char classification-string i)) 135 | :collect classification)) 136 | 137 | (defun symbol-signature (symbol) 138 | (let ((*print-case* :downcase)) 139 | (handler-case 140 | (princ-to-string (cons symbol (micros::arglist symbol))) 141 | (error () 142 | nil)))) 143 | 144 | (defun completed-string-to-symbol (completed-string default-package-name) 145 | (multiple-value-bind (symbol-name package-name internalp) 146 | (micros::tokenize-symbol-thoroughly completed-string) 147 | (declare (ignore internalp)) 148 | (let ((package (if (null package-name) 149 | (find-package default-package-name) 150 | (find-package package-name)))) 151 | (when package 152 | (find-symbol symbol-name package))))) 153 | 154 | (defun completions (symbol-string package-name) 155 | (destructuring-bind (completions timeout-p) 156 | (micros:fuzzy-completions symbol-string package-name 157 | :limit 100) 158 | (declare (ignore timeout-p)) 159 | (loop :for (completed-string score chunks classification-string) :in completions 160 | :for classification-detail := (format nil "~(~{~A~^, ~}~)" 161 | (parse-classification-string classification-string)) 162 | :for symbol := (completed-string-to-symbol completed-string package-name) 163 | :for signature := (symbol-signature symbol) 164 | :for documentation := (describe-symbol-in-markdown symbol) 165 | :for index :from 0 166 | :collect (make-completed-item :label completed-string 167 | :chunks chunks 168 | :classification classification-detail 169 | :signature signature 170 | :documentation documentation 171 | :sort-text (format nil "~10,'0D" index))))) 172 | 173 | ;;; symbol-informations 174 | (defstruct (symbol-information (:type list)) 175 | name 176 | detail 177 | kind) 178 | 179 | (defstruct (symbol-spec (:type list)) 180 | name 181 | package) 182 | 183 | (defun find-symbol* (symbol-name package-name) 184 | (let ((package (find-package package-name))) 185 | (when package 186 | (find-symbol symbol-name package)))) 187 | 188 | (defun symbol-kind (symbol) 189 | (cond ((boundp symbol) 190 | :variable) 191 | ((fboundp symbol) 192 | :function) 193 | ((find-class symbol nil) 194 | :class) 195 | ((find-package symbol) 196 | :package))) 197 | 198 | (defun symbol-informations (symbol-specs) 199 | (loop :for (symbol-name package-name) :in symbol-specs 200 | :collect (let ((symbol (find-symbol* symbol-name package-name))) 201 | (make-symbol-information :name symbol-name 202 | :detail (when symbol (symbol-signature symbol)) 203 | :kind (when symbol (symbol-kind symbol)))))) 204 | 205 | ;;; 206 | (defun compile-and-load-file (filename) 207 | (uiop:with-temporary-file (:pathname output-file :type "fasl") 208 | (let* ((stream (make-broadcast-stream)) 209 | (*standard-output* stream) 210 | (*error-output* stream)) 211 | (when (uiop:compile-file* filename :output-file output-file) 212 | (load output-file) 213 | t)))) 214 | 215 | (defun safety-read-from-string (string) 216 | (handler-case (values (micros:from-string string)) 217 | (error (e) 218 | (values nil e)))) 219 | 220 | ;;; 221 | (defstruct (eval-result (:type list)) 222 | value 223 | error) 224 | 225 | (defun eval-for-language-server (string) 226 | (micros::with-buffer-syntax () 227 | (multiple-value-bind (form error) 228 | (safety-read-from-string string) 229 | (if error 230 | (make-eval-result :value nil 231 | :error (princ-to-string error)) 232 | (handler-case (eval form) 233 | (error (e) 234 | (make-eval-result :value nil 235 | :error (princ-to-string e))) 236 | (:no-error (&rest values) 237 | (make-eval-result :value (format nil "~{~S~^~%~}" values) 238 | :error nil))))))) 239 | -------------------------------------------------------------------------------- /micros.asd: -------------------------------------------------------------------------------- 1 | (defsystem "micros" 2 | :depends-on () 3 | :version "0.0.0" 4 | :serial t 5 | :perform (load-op :after (o c) 6 | (uiop:symbol-call :micros :before-init)) 7 | :components ((:file "packages") 8 | (:module "sbcl" 9 | :pathname "backend" 10 | :components ((:file "backend") 11 | (:file "source-path-parser") 12 | (:file "source-file-cache") 13 | #+sbcl 14 | (:file "sbcl") 15 | #+abcl 16 | (:file "abcl") 17 | #+clasp 18 | (:file "clasp") 19 | #+ccl 20 | (:file "ccl") 21 | #+ecl 22 | (:file "ecl") 23 | (:file "gray") 24 | (:file "match") 25 | (:file "rpc"))) 26 | (:file "micros") 27 | (:module "contrib" 28 | :components ((:file "micros-util") 29 | (:file "micros-repl") 30 | (:file "micros-c-p-c" :depends-on ("micros-util")) 31 | (:file "micros-arglists" :depends-on ("micros-c-p-c")) 32 | (:file "micros-fuzzy" :depends-on ("micros-util" "micros-c-p-c")) 33 | (:file "micros-fancy-inspector" :depends-on ("micros-util")) 34 | ;; (:file "micros-presentations" :depends-on ("micros-repl")) 35 | ;; (:file "micros-presentation-streams" :depends-on ("micros-presentations")) 36 | (:file "micros-package-fu") 37 | (:file "micros-hyperdoc") 38 | (:file "micros-sbcl-exts" :depends-on ("micros-arglists")) 39 | (:file "micros-mrepl") 40 | (:file "micros-trace-dialog") 41 | (:file "micros-macrostep") 42 | (:file "micros-systems") 43 | (:file "micros-pretty-eval") 44 | (:file "micros-trace") 45 | (:file "micros-test-runner") 46 | ;; (:file "micros-asdf") 47 | ;; (:file "micros-buffer-streams") 48 | ;; (:file "clipboard") 49 | ;; (:file "indentation") 50 | ;; (:file "listener-hooks" :depends-on ("micros-repl")) 51 | ;; (:file "snapshot") 52 | ;; (:file "sprof") 53 | (:module "walker" 54 | :components ((:file "package") 55 | (:file "utils") 56 | (:file "types") 57 | (:file "walker") 58 | (:file "defun-form") 59 | (:file "defmethod-form") 60 | (:file "loop-form") 61 | (:file "data-and-control-flow"))))) 62 | (:file "lsp-api") 63 | (:file "lsp-api-load-systems"))) 64 | 65 | (defsystem "micros/tests" 66 | :depends-on ("rove" "micros") 67 | :serial t 68 | :pathname "contrib/walker/tests/" 69 | :components ((:file "tests"))) 70 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage micros/backend 2 | (:use cl) 3 | (:export *debug-swank-backend* 4 | *log-output* 5 | sldb-condition 6 | compiler-condition 7 | original-condition 8 | message 9 | source-context 10 | condition 11 | severity 12 | with-compilation-hooks 13 | make-location 14 | location 15 | location-p 16 | location-buffer 17 | location-position 18 | location-hints 19 | position-p 20 | position-pos 21 | print-output-to-string 22 | quit-lisp 23 | references 24 | unbound-slot-filler 25 | declaration-arglist 26 | type-specifier-arglist 27 | with-struct 28 | when-let 29 | defimplementation 30 | converting-errors-to-error-location 31 | make-error-location 32 | deinit-log-output 33 | ;; interrupt macro for the backend 34 | *pending-slime-interrupts* 35 | check-slime-interrupts 36 | *interrupt-queued-handler* 37 | ;; inspector related symbols 38 | emacs-inspect 39 | label-value-line 40 | label-value-line* 41 | boolean-to-feature-expression 42 | with-symbol 43 | choose-symbol 44 | ;; package helper for backend 45 | import-to-swank-mop 46 | import-swank-mop-symbols 47 | ;; 48 | default-directory 49 | set-default-directory 50 | frame-source-location 51 | restart-frame 52 | gdb-initial-commands 53 | sldb-break-on-return 54 | buffer-first-change 55 | 56 | profiled-functions 57 | unprofile-all 58 | profile-report 59 | profile-reset 60 | profile-package 61 | 62 | with-collected-macro-forms 63 | auto-flush-loop 64 | *auto-flush-interval*)) 65 | 66 | (defpackage micros/rpc 67 | (:use :cl) 68 | (:export 69 | read-message 70 | read-packet 71 | swank-reader-error 72 | swank-reader-error.packet 73 | swank-reader-error.cause 74 | write-message)) 75 | 76 | (defpackage micros/match 77 | (:use cl) 78 | (:export match)) 79 | 80 | (defpackage micros/mop 81 | (:use) 82 | (:export 83 | ;; classes 84 | standard-generic-function 85 | standard-slot-definition 86 | standard-method 87 | standard-class 88 | eql-specializer 89 | eql-specializer-object 90 | ;; standard-class readers 91 | class-default-initargs 92 | class-direct-default-initargs 93 | class-direct-slots 94 | class-direct-subclasses 95 | class-direct-superclasses 96 | class-finalized-p 97 | class-name 98 | class-precedence-list 99 | class-prototype 100 | class-slots 101 | specializer-direct-methods 102 | ;; generic function readers 103 | generic-function-argument-precedence-order 104 | generic-function-declarations 105 | generic-function-lambda-list 106 | generic-function-methods 107 | generic-function-method-class 108 | generic-function-method-combination 109 | generic-function-name 110 | ;; method readers 111 | method-generic-function 112 | method-function 113 | method-lambda-list 114 | method-specializers 115 | method-qualifiers 116 | ;; slot readers 117 | slot-definition-allocation 118 | slot-definition-documentation 119 | slot-definition-initargs 120 | slot-definition-initform 121 | slot-definition-initfunction 122 | slot-definition-name 123 | slot-definition-type 124 | slot-definition-readers 125 | slot-definition-writers 126 | slot-boundp-using-class 127 | slot-value-using-class 128 | slot-makunbound-using-class 129 | ;; generic function protocol 130 | compute-applicable-methods-using-classes 131 | finalize-inheritance)) 132 | 133 | (defpackage micros 134 | (:use cl micros/backend micros/match micros/rpc) 135 | (:export #:startup-multiprocessing 136 | #:start-server 137 | #:create-server 138 | #:stop-server 139 | #:restart-server 140 | #:ed-in-emacs 141 | #:inspect-in-emacs 142 | #:print-indentation-lossage 143 | #:invoke-slime-debugger 144 | #:swank-debugger-hook 145 | #:emacs-inspect 146 | ;;#:inspect-slot-for-emacs 147 | ;; These are user-configurable variables: 148 | #:*communication-style* 149 | #:*dont-close* 150 | #:*fasl-pathname-function* 151 | #:*log-events* 152 | #:*use-dedicated-output-stream* 153 | #:*dedicated-output-stream-port* 154 | #:*configure-emacs-indentation* 155 | #:*readtable-alist* 156 | #:*globally-redirect-io* 157 | #:*global-debugger* 158 | #:*sldb-quit-restart* 159 | #:*backtrace-printer-bindings* 160 | #:*default-worker-thread-bindings* 161 | #:*macroexpand-printer-bindings* 162 | #:*swank-pprint-bindings* 163 | #:*record-repl-results* 164 | #:*inspector-verbose* 165 | ;; This is SETFable. 166 | #:debug-on-swank-error 167 | ;; These are re-exported directly from the backend: 168 | #:buffer-first-change 169 | #:frame-source-location 170 | #:gdb-initial-commands 171 | #:restart-frame 172 | #:sldb-step 173 | #:sldb-break 174 | #:sldb-break-on-return 175 | #:profiled-functions 176 | #:profile-report 177 | #:profile-reset 178 | #:unprofile-all 179 | #:profile-package 180 | #:default-directory 181 | #:set-default-directory 182 | #:quit-lisp 183 | #:eval-for-emacs 184 | #:eval-in-emacs 185 | #:ed-rpc 186 | #:ed-rpc-no-wait 187 | #:y-or-n-p-in-emacs 188 | #:*find-definitions-right-trim* 189 | #:*find-definitions-left-trim* 190 | #:*after-toggle-trace-hook* 191 | #:unreadable-result 192 | #:unreadable-result-p 193 | #:unreadable-result-string 194 | #:parse-string 195 | #:from-string 196 | #:to-string 197 | #:*swank-debugger-condition* 198 | #:run-hook-with-args-until-success 199 | #:make-output-function-for-target 200 | #:make-output-stream-for-target)) 201 | --------------------------------------------------------------------------------