geiser-guile.el (25601B)
1 ;;; geiser-guile.el --- Guile and Geiser talk to each other -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2022 Jose Antonio Ortega Ruiz 4 ;; Start date: Sun Mar 08, 2009 23:03 5 6 ;; Author: Jose Antonio Ortega Ruiz (jao@gnu.org) 7 ;; Maintainer: Jose Antonio Ortega Ruiz (jao@gnu.org) 8 ;; Keywords: languages, guile, scheme, geiser 9 ;; Homepage: https://gitlab.com/emacs-geiser/guile 10 ;; Package-Requires: ((emacs "25.1") (transient "0.3") (geiser "0.28.1")) 11 ;; SPDX-License-Identifier: BSD-3-Clause 12 ;; Version: 0.28.1 13 14 ;; This file is NOT part of GNU Emacs. 15 16 ;;; Commentary: 17 18 ;; This package extends the `geiser' core package to support GNU 19 ;; Guile. 20 21 22 ;;; Code: 23 24 (require 'geiser-connection) 25 (require 'geiser-syntax) 26 (require 'geiser-custom) 27 (require 'geiser-repl) 28 (require 'geiser-debug) 29 (require 'geiser-impl) 30 (require 'geiser-base) 31 (require 'geiser-eval) 32 (require 'geiser-edit) 33 (require 'geiser-log) 34 (require 'geiser) 35 36 (require 'transient) 37 (require 'compile) 38 (require 'info-look) 39 40 (eval-when-compile 41 (require 'cl-lib) 42 (require 'tramp) 43 (require 'subr-x)) 44 45 46 ;;; Customization 47 48 (defgroup geiser-guile nil 49 "Customization for Geiser's Guile flavour." 50 :group 'geiser) 51 52 (geiser-custom--defcustom geiser-guile-binary 53 (cond ((eq system-type 'windows-nt) "guile.exe") 54 ((eq system-type 'darwin) "guile") 55 (t "guile")) 56 "Name to use to call the Guile executable when starting a REPL." 57 :type '(choice string (repeat string))) 58 59 (geiser-custom--defcustom geiser-guile-load-path nil 60 "A list of paths to be added to Guile's load path when it's started. 61 The paths are added to both %`load-path' and %load-compiled path, 62 and only if they are not already present. This variable is a 63 good candidate for an entry in your project's .dir-locals.el." 64 :type '(repeat file)) 65 66 (geiser-custom--defcustom geiser-guile-init-file "~/.guile-geiser" 67 "Initialization file with user code for the Guile REPL. 68 If all you want is to load ~/.guile, set 69 `geiser-guile-load-init-file' instead." 70 :type 'string) 71 72 (geiser-custom--defcustom geiser-guile-load-init-file nil 73 "Whether to load ~/.guile when starting Guile. 74 Note that, due to peculiarities in the way Guile loads its init 75 file, using `geiser-guile-init-file' is not equivalent to setting 76 this variable to t." 77 :type 'boolean) 78 79 (define-obsolete-variable-alias 80 'geiser-guile-load-init-file-p 'geiser-guile-load-init-file "0.26.2") 81 82 (geiser-custom--defcustom geiser-guile-use-declarative-modules nil 83 "Whether Guile should use \"declarative\" modules limiting mutability. 84 When set to `t', Guile will enforce immutable bindings in 85 exported modules." 86 :type 'boolean 87 :link '(info-link "(guile) Declarative Modules")) 88 89 (define-obsolete-variable-alias 90 'geiser-guile-use-declarative-modules-p 'geiser-guile-use-declarative-modules 91 "0.26.2") 92 93 (geiser-custom--defcustom geiser-guile-debug-backwards-backtrace t 94 "Whether to configure backtraces using the \\='backwards ordering." 95 :type 'boolean) 96 97 (geiser-custom--defcustom geiser-guile-debug-terminal-width 999 98 "Maximum number of columns shown in backtraces. 99 Normally, you'd want a big value here so that messages are not 100 truncated. Set to a negative value if you prefer that geiser 101 does not set it on startup." 102 :type 'integer) 103 104 (geiser-custom--defcustom geiser-guile-debug-show-bt t 105 "Whether to automatically show a full backtrace when entering the debugger. 106 If nil, only the last frame is shown." 107 :type 'boolean) 108 109 (define-obsolete-variable-alias 110 'geiser-guile-debug-show-bt-p 'geiser-guile-debug-show-bt "0.26.2") 111 112 113 (geiser-custom--defcustom geiser-guile-debug-show-full-bt t 114 "Whether to show full backtraces in the debugger, including local variables." 115 :type 'boolean) 116 117 (define-obsolete-variable-alias 118 'geiser-guile-debug-show-full-bt-p 'geiser-guile-debug-show-full-bt "0.26.2") 119 120 121 (geiser-custom--defcustom geiser-guile-show-debug-help t 122 "Whether to show brief help in the echo area when entering the debugger." 123 :type 'boolean) 124 125 (define-obsolete-variable-alias 126 'geiser-guile-show-debug-help-p 'geiser-guile-show-debug-help "0.26.2") 127 128 (geiser-custom--defcustom geiser-guile-warning-level 'medium 129 "Verbosity of the warnings reported by Guile. 130 131 You can either choose one of the predefined warning sets, or 132 provide a list of symbols identifying the ones you want. Possible 133 choices are arity-mismatch, unbound-variable, unused-variable and 134 unused-toplevel. Unrecognised symbols are ignored. 135 136 The predefined levels are: 137 138 - Medium: arity-mismatch, unbound-variable, format 139 - High: arity-mismatch, unbound-variable, unused-variable, format 140 - None: no warnings 141 142 Changes to the value of this variable will automatically take 143 effect on new REPLs. For existing ones, use the command 144 \\[geiser-guile-update-warning-level]." 145 :type '(choice (const :tag "Medium (arity and unbound vars)" medium) 146 (const :tag "High (also unused vars)" high) 147 (const :tag "No warnings" none) 148 (repeat :tag "Custom" symbol))) 149 150 (geiser-custom--defcustom geiser-guile-extra-keywords nil 151 "Extra keywords highlighted in Guile scheme buffers." 152 :type '(repeat string)) 153 154 (geiser-custom--defcustom geiser-guile-case-sensitive t 155 "Non-nil means keyword highlighting is case-sensitive." 156 :type 'boolean) 157 158 (define-obsolete-variable-alias 159 'geiser-guile-case-sensitive-p 'geiser-guile-case-sensitive "0.26.2") 160 161 (geiser-custom--defcustom geiser-guile-manual-lookup-other-window nil 162 "Non-nil means pop up the Info buffer in another window." 163 :type 'boolean) 164 165 (define-obsolete-variable-alias 166 'geiser-guile-manual-lookup-other-window-p 167 'geiser-guile-manual-lookup-other-window "0.26.2") 168 169 (geiser-custom--defcustom geiser-guile-manual-lookup-nodes 170 '("Guile" "guile-2.0") 171 "List of info nodes that, when present, are used for manual lookups." 172 :type '(repeat string)) 173 174 175 ;;; REPL support 176 177 (defun geiser-guile--binary () 178 "Return the name of the Guile binary to execute." 179 (if (listp geiser-guile-binary) 180 (car geiser-guile-binary) 181 geiser-guile-binary)) 182 183 (defvar geiser-guile-scheme-dir 184 (expand-file-name "src" (file-name-directory load-file-name)) 185 "Directory where the Guile scheme geiser modules are installed.") 186 187 (defvar-local geiser-guile-scheme-local-dir 188 nil 189 "Location for scm files to communicate using REPL that are local to process. 190 191 When using Tramp buffers, the guile modules are not local. They'll be stored in 192 this location for further cleanup.") 193 194 (defun geiser-guile--remote-copy (source-path target-path) 195 "Copy source-path to target-path ensuring symlinks are resolved." 196 ;; when using `straight', guile scripts that need to be evaluated will be 197 ;; symlinks 198 ;; `copy-directory' will copy broken symlinks 199 ;; so we manually copy them to avoid broken symlinks in remote host 200 (cond ((file-symlink-p source-path) 201 (geiser-guile--remote-copy (file-truename source-path) target-path)) 202 ((file-directory-p source-path) 203 (unless (file-directory-p target-path) (make-directory target-path t)) 204 (let ((dest (file-name-as-directory target-path))) 205 (dolist (f (seq-difference (directory-files source-path) '("." ".."))) 206 (geiser-guile--remote-copy (expand-file-name f source-path) 207 (expand-file-name f dest))))) 208 (t (cl-assert (file-regular-p source-path)) 209 (copy-file source-path target-path)))) 210 211 (defun geiser-guile-ensure-scheme-dir () 212 "Maybe setup and return dir for Guile scheme geiser modules. 213 214 If using a remote Tramp buffer, this function will copy the modules to a 215 temporary location in the remote server and the return it. 216 Else, will just return `geiser-guile-scheme-dir'." 217 (cond ((not (and (fboundp 'tramp-tramp-file-p) 218 (tramp-tramp-file-p default-directory))) 219 geiser-guile-scheme-dir) 220 (geiser-guile-scheme-local-dir) ;; remote files are already there 221 (t 222 (let* ((temporary-file-directory (temporary-file-directory)) 223 (remote-temp-dir (make-temp-file "emacs-geiser-guile" t))) 224 (message "Setting up Tramp Guile REPL...") 225 (let ((inhibit-message t)) ;; prevent "Copying … to … " from dired 226 (geiser-guile--remote-copy 227 geiser-guile-scheme-dir 228 (concat (file-name-as-directory remote-temp-dir) 229 (file-name-nondirectory 230 (directory-file-name geiser-guile-scheme-dir))))) 231 ;; return the directory name as local to (remote) process 232 (setq geiser-guile-scheme-local-dir 233 (concat (file-name-as-directory 234 (file-local-name remote-temp-dir)) 235 (file-name-nondirectory geiser-guile-scheme-dir))))))) 236 237 (defvar geiser-guile--conn-address nil) 238 239 (defun geiser-guile--get-connection-address (&optional new) 240 "The path to the UNIX socket to talk to Guile in a connection. 241 Unused for now." 242 (when new 243 (setq geiser-guile--conn-address (make-temp-name "/tmp/geiser-guile-"))) 244 geiser-guile--conn-address) 245 246 (defun geiser-guile--parameters () 247 "Return a list with all parameters needed to start Guile. 248 This function uses `geiser-guile-init-file' if it exists." 249 (let ((init-file (and (stringp geiser-guile-init-file) 250 (expand-file-name 251 (concat 252 (file-remote-p default-directory) 253 geiser-guile-init-file)))) 254 (c-flags (when geiser-guile--conn-address 255 `(,(format "--listen=%s" 256 (geiser-guile--get-connection-address t))))) 257 (q-flags (and (not geiser-guile-load-init-file) '("-q")))) 258 `(,@(and (listp geiser-guile-binary) (cdr geiser-guile-binary)) 259 ,@q-flags "-L" ,(geiser-guile-ensure-scheme-dir) ,@c-flags 260 ,@(apply 'append (mapcar (lambda (p) (list "-L" p)) 261 geiser-guile-load-path)) 262 ,@(and init-file (file-readable-p init-file) 263 (list "-l" (file-local-name init-file)))))) 264 265 (defconst geiser-guile--prompt-regexp "^[^@(\n]+@([^)]*)> ") 266 (defconst geiser-guile--debugger-prompt-regexp 267 "^[^@(\n]+@([^)]*?) \\[\\([0-9]+\\)\\]> ") 268 269 (defconst geiser-guile--clean-rx 270 (format "\\(%s\\)\\|\\(^\\$[0-9]+ = [^\n]+$\\)\\|%s" 271 (geiser-con--combined-prompt geiser-guile--prompt-regexp 272 geiser-guile--debugger-prompt-regexp) 273 "\\(\nEntering a new prompt. Type `,bt' for [^\n]+\\.$\\)")) 274 275 276 ;;; Evaluation support 277 (defsubst geiser-guile--linearize-args (args) 278 "Concatenate the list ARGS." 279 (mapconcat 'identity args " ")) 280 281 (defun geiser-guile--debug-cmd (args) 282 (let ((args (if (and geiser-guile-debug-show-full-bt 283 (string= (car args) "backtrace")) 284 '("backtrace" "#:full?" "#t") 285 args))) 286 (concat "," (geiser-guile--linearize-args args) "\n\"\""))) 287 288 (defun geiser-guile--geiser-procedure (proc &rest args) 289 "Transform PROC in string for a scheme procedure using ARGS." 290 (cl-case proc 291 ((eval compile) (format ",geiser-eval %s %s%s" 292 (or (car args) "#f") 293 (geiser-guile--linearize-args (cdr args)) 294 (if (cddr args) "" " ()"))) 295 ((load-file compile-file) (format ",geiser-load-file %s" (car args))) 296 ((no-values) ",geiser-no-values") 297 ((debug) (geiser-guile--debug-cmd args)) 298 (t (format "ge:%s (%s)" proc (geiser-guile--linearize-args args))))) 299 300 (defun geiser-guile--clean-up-output (str) 301 (let ((msg (when (string-match geiser-guile--debugger-prompt-regexp str) 302 (format "\n[Debugging level: %s]" (match-string 1 str))))) 303 (concat (replace-regexp-in-string geiser-guile--clean-rx "" str) msg))) 304 305 (defconst geiser-guile--module-re 306 "(define-module +\\(([^)]+)\\)") 307 308 (defconst geiser-guile--library-re 309 "(\\(?:define-\\)?library[[:blank:]\n]+\\(([^)]+)\\)") 310 311 (defun geiser-guile--get-module (&optional module) 312 "Find current buffer's module using MODULE as a hint." 313 (cond ((null module) 314 (save-excursion 315 (geiser-syntax--pop-to-top) 316 (if (or (re-search-backward geiser-guile--module-re nil t) 317 (re-search-backward geiser-guile--library-re nil t) 318 (re-search-forward geiser-guile--module-re nil t) 319 (re-search-forward geiser-guile--library-re nil t)) 320 (geiser-guile--get-module (match-string-no-properties 1)) 321 :f))) 322 ((listp module) module) 323 ((stringp module) 324 (condition-case nil 325 (car (geiser-syntax--read-from-string module)) 326 (error :f))) 327 (t :f))) 328 329 (defun geiser-guile--module-cmd (module fmt &optional def) 330 "Use FMT to format a change to MODULE, with default DEF." 331 (when module 332 (let* ((module (geiser-guile--get-module module)) 333 (module (cond ((or (null module) (eq module :f)) def) 334 (t (format "%s" module))))) 335 (and module (format fmt module))))) 336 337 (defun geiser-guile--import-command (module) 338 "Format a REPL command to use MODULE." 339 (geiser-guile--module-cmd module ",use %s")) 340 341 (defun geiser-guile--enter-command (module) 342 "Format a REPL command to enter MODULE." 343 (geiser-guile--module-cmd module ",m %s" "(guile-user)")) 344 345 346 (defun geiser-guile--exit-command () 347 "Format a REPL command to quit." 348 ",q") 349 350 (defun geiser-guile--symbol-begin (module) 351 "Find beginning of symbol in the context of MODULE." 352 (if module 353 (max (save-excursion (beginning-of-line) (point)) 354 (save-excursion (skip-syntax-backward "^(>") (1- (point)))) 355 (save-excursion (skip-syntax-backward "^'-()>") (point)))) 356 357 358 ;;; Compilation shell regexps 359 360 (defconst geiser-guile--path-rx "^In \\([^:\n ]+\\):\n") 361 362 (defconst geiser-guile--rel-path-rx "^In +\\([^/\n: ]+\\):\n") 363 364 (defvar geiser-guile--file-cache (make-hash-table :test 'equal) 365 "Internal cache.") 366 367 (defun geiser-guile--find-file (file) 368 (or (gethash file geiser-guile--file-cache) 369 (with-current-buffer (or geiser-debug--sender-buffer (current-buffer)) 370 (when-let (r geiser-repl--repl) 371 (with-current-buffer r 372 (geiser-eval--send/result `(:eval (:ge find-file ,file)))))))) 373 374 (defun geiser-guile--resolve-file (file) 375 "Find the given FILE, if it's indeed a file." 376 (when (and (stringp file) 377 (not (member file 378 '("socket" "stdin" "unknown file" "current input")))) 379 (message "Resolving %s" file) 380 (cond ((file-name-absolute-p file) file) 381 (t (when-let (f (geiser-guile--find-file file)) 382 (puthash file f geiser-guile--file-cache)))))) 383 384 (defun geiser-guile--resolve-file-x () 385 "Check if last match contain a resolvable file." 386 (let ((f (geiser-guile--resolve-file (match-string-no-properties 1)))) 387 (and (stringp f) (list f)))) 388 389 390 ;;; Error display and debugger 391 392 (defun geiser-guile--set-up-error-links () 393 (setq-local compilation-error-regexp-alist 394 `((,geiser-guile--path-rx geiser-guile--resolve-file-x) 395 ("^ +\\([0-9]+\\):\\([0-9]+\\)" nil 1 2) 396 ("^\\(/.*\\):\\([0-9]+\\):\\([0-9]+\\)" 1 2 3))) 397 (font-lock-add-keywords nil 398 `((,geiser-guile--path-rx 1 compilation-error-face)))) 399 400 (defun geiser-guile-debug--send-dbg (thing) 401 (geiser-eval--send/wait (cons :debug (if (listp thing) thing (list thing))))) 402 403 (defun geiser-guile-debug--debugger-display (thing ret) 404 (geiser-debug--display-retort (format ",%s" thing) 405 ret 406 (geiser-eval--retort-result-str ret nil))) 407 408 (defun geiser-guile-debug--send-to-repl (thing) 409 (unless (geiser-debug-active-p) (error "Debugger not active")) 410 (save-window-excursion 411 (with-current-buffer geiser-debug--sender-buffer 412 (when-let (ret (geiser-guile-debug--send-dbg thing)) 413 (geiser-guile-debug--debugger-display thing ret))))) 414 415 (defun geiser-guile-debug-quit () 416 "Quit the current debugging session level." 417 (interactive) 418 (geiser-guile-debug--send-to-repl 'quit)) 419 420 (defun geiser-guile-debug-show-backtrace () 421 "Quit the current debugging session level." 422 (interactive) 423 (geiser-guile-debug--send-to-repl 'backtrace)) 424 425 (defun geiser-guile-debug-show-locals () 426 "Show local variables." 427 (interactive) 428 (geiser-guile-debug--send-to-repl 'locals)) 429 430 (defun geiser-guile-debug-show-registers () 431 "Show register values." 432 (interactive) 433 (geiser-guile-debug--send-to-repl 'registers)) 434 435 (defun geiser-guile-debug-show-error () 436 "Show error message." 437 (interactive) 438 (geiser-guile-debug--send-to-repl 'error)) 439 440 (transient-define-prefix geiser-guile--debug-transient () 441 "Debugging meta-commands." 442 ["Guile debugger" 443 [("n" "Next error" compilation-next-error) 444 ("p" "Previous error" compilation-next-error) 445 ("z" "Scheme buffer" geiser-debug-switch-to-buffer) 446 ("x" "Exit debug level" geiser-guile-debug-quit)] 447 [("b" "Show backtrace" geiser-guile-debug-show-backtrace) 448 ("e" "Show error" geiser-guile-debug-show-error) 449 ("l" "Show locals" geiser-guile-debug-show-locals) 450 ("r" "Show registers" geiser-guile-debug-show-registers)]]) 451 452 (defun geiser-guile-debug-menu () 453 "Show available debugging commands, if any." 454 (interactive) 455 (when (and (eq 'guile geiser-impl--implementation) (geiser-debug-active-p)) 456 (call-interactively #'geiser-guile--debug-transient))) 457 458 (define-key geiser-debug-mode-map "," #'geiser-guile-debug-menu) 459 460 (defun geiser-guile--enter-debugger () 461 "Tell Geiser to interact with the debugger." 462 (when geiser-guile-show-debug-help 463 (message "Debugger active. Press , for commands.")) 464 nil) 465 466 (defun geiser-guile--display-error (_module _key msg) 467 "Display error with given message MSG." 468 (when (stringp msg) 469 (geiser-guile--set-up-error-links) 470 (save-excursion (insert msg))) 471 (not (zerop (length msg)))) 472 473 474 ;;; Trying to ascertain whether a buffer is Guile Scheme 475 476 (defconst geiser-guile--guess-re 477 (format "\\(%s\\|#! *.+\\(/\\| \\)guile\\( *\\\\\\)?\\)" 478 geiser-guile--module-re)) 479 480 (defun geiser-guile--guess () 481 "Ascertain whether we are in a Guile file." 482 (save-excursion 483 (goto-char (point-min)) 484 (re-search-forward geiser-guile--guess-re nil t))) 485 486 487 ;;; Keywords and syntax 488 489 (defconst geiser-guile--builtin-keywords 490 '("call-with-input-file" 491 "call-with-input-string" 492 "call-with-output-file" 493 "call-with-output-string" 494 "call-with-prompt" 495 "call-with-trace" 496 "define-accessor" 497 "define-class" 498 "define-enumeration" 499 "define-inlinable" 500 "define-syntax-parameter" 501 "eval-when" 502 "lambda*" 503 "syntax-parameterize" 504 "use-modules" 505 "with-error-to-file" 506 "with-error-to-port" 507 "with-error-to-string" 508 "with-fluid*" 509 "with-fluids" 510 "with-fluids*" 511 "with-input-from-port" 512 "with-input-from-string" 513 "with-output-to-port" 514 "with-output-to-string")) 515 516 (defun geiser-guile--keywords () 517 "Return Guile-specific scheme keywords." 518 (append 519 (geiser-syntax--simple-keywords geiser-guile-extra-keywords) 520 (geiser-syntax--simple-keywords geiser-guile--builtin-keywords) 521 `((,(rx "(" (group "define-once") eow (* space) (? (group (+ word)))) 522 (1 font-lock-keyword-face) 523 (2 font-lock-variable-name-face nil t)) 524 ("(\\(define-module\\) +(\\([^)]+\\))" 525 (1 font-lock-keyword-face) 526 (2 font-lock-type-face nil t))))) 527 528 (geiser-syntax--scheme-indent 529 (c-declare 0) 530 (c-lambda 2) 531 (call-with-input-string 1) 532 (call-with-output-string 0) 533 (call-with-prompt 1) 534 (call-with-trace 0) 535 (eval-when 1) 536 (lambda* 1) 537 (pmatch defun) 538 (sigaction 1) 539 (syntax-parameterize 1) 540 (with-error-to-file 1) 541 (with-error-to-port 1) 542 (with-error-to-string 0) 543 (with-fluid* 1) 544 (with-fluids 1) 545 (with-fluids* 1) 546 (with-input-from-string 1) 547 (with-method 1) 548 (with-mutex 1) 549 (with-output-to-string 0) 550 (with-throw-handler 1)) 551 552 553 ;;; REPL startup 554 555 (defconst geiser-guile-minimum-version "2.2") 556 557 (defun geiser-guile--version (_binary) 558 "Find Guile's version running the configured Guile binary." 559 ;; maybe one day we'll have `process-lines' with tramp support 560 (let ((shell-command-switch "-c") 561 (shell-file-name "sh")) 562 (shell-command-to-string 563 (format "%s -c %s" 564 (geiser-guile--binary) 565 (shell-quote-argument "(display (version))"))))) 566 567 (defun geiser-guile-update-warning-level () 568 "Update the warning level used by the REPL. 569 The new level is set using the value of `geiser-guile-warning-level'." 570 (interactive) 571 (let ((code `(:eval (:ge set-warnings ',geiser-guile-warning-level) 572 (geiser evaluation)))) 573 (geiser-eval--send/result code))) 574 575 ;;;###autoload 576 (defun connect-to-guile () 577 "Start a Guile REPL connected to a remote process. 578 579 Start the external Guile process with the flag --listen to make 580 it spawn a server thread." 581 (interactive) 582 (geiser-connect 'guile)) 583 584 (defun geiser-guile--set-geiser-load-path () 585 "Set up scheme load path for REPL." 586 (let* ((path (geiser-guile-ensure-scheme-dir)) 587 (witness "geiser/emacs.scm") 588 (code `(begin (if (not (%search-load-path ,witness)) 589 (set! %load-path (cons ,path %load-path))) 590 'done))) 591 (geiser-eval--send/wait code))) 592 593 (defun geiser-guile--set-up-declarative-modules () 594 "Set up Guile to (not) use declarative modules. 595 See `geiser-guile-use-declarative-modules'." 596 (unless geiser-guile-use-declarative-modules 597 (let ((code '(begin (eval-when (expand) (user-modules-declarative? :f)) 'ok))) 598 (geiser-eval--send/wait code)))) 599 600 (defun geiser-guile--set-up-backtrace () 601 "Set up Guile's backtrace properties." 602 (when geiser-guile-debug-backwards-backtrace 603 (geiser-eval--send/wait '(debug-enable 'backwards))) 604 (when (> geiser-guile-debug-terminal-width 0) 605 (geiser-eval--send/wait `(begin ((@ (system repl debug) terminal-width) 606 ,geiser-guile-debug-terminal-width) 607 'ok)))) 608 609 (defun geiser-guile--startup (remote) 610 "Startup function, for a remote connection if REMOTE is t." 611 (geiser-guile--set-up-error-links) 612 (let ((geiser-log-verbose t) 613 (g-load-path (buffer-local-value 'geiser-guile-load-path 614 (or geiser-repl--last-scm-buffer 615 (current-buffer))))) 616 (when (or geiser-guile--conn-address remote) 617 (geiser-guile--set-geiser-load-path)) 618 (geiser-guile--set-up-declarative-modules) 619 (geiser-guile--set-up-backtrace) 620 (geiser-eval--send/wait ",use (geiser emacs)\n'done") 621 (dolist (dir g-load-path) 622 (let ((dir (expand-file-name dir))) 623 (geiser-eval--send/wait `(:eval (:ge add-to-load-path ,dir))))) 624 (geiser-guile-update-warning-level))) 625 626 627 ;;; Manual lookup 628 629 (defun geiser-guile--info-spec () 630 "Return info specification for given NODES." 631 (let* ((nrx "^[ ]+-+ [^:]+:[ ]*") 632 (drx "\\b") 633 (res (when (Info-find-file "r5rs" t) 634 `(("(r5rs)Index" nil ,nrx ,drx))))) 635 (dolist (node geiser-guile-manual-lookup-nodes res) 636 (when (Info-find-file node t) 637 (mapc (lambda (idx) 638 (add-to-list 'res 639 (list (format "(%s)%s" node idx) nil nrx drx))) 640 '("R5RS Index" "Concept Index" "Procedure Index" "Variable Index")))))) 641 642 (info-lookup-add-help :topic 'symbol 643 :mode 'geiser-guile-mode 644 :ignore-case nil 645 :regexp "[^()`',\" \n]+" 646 :doc-spec (geiser-guile--info-spec)) 647 648 (defun geiser-guile--info-lookup (id) 649 (cond ((null id) (info "guile")) 650 ((ignore-errors (info-lookup-symbol (format "%s" id) 'geiser-guile-mode) t)) 651 ((and (listp id) (geiser-guile--info-lookup (car (last id))))) 652 (t (geiser-guile--info-lookup (when (listp id) (butlast id)))))) 653 654 (defun geiser-guile--manual-look-up (id _mod) 655 "Look for ID in the Guile manuals." 656 (let ((info-lookup-other-window-flag geiser-guile-manual-lookup-other-window)) 657 (geiser-guile--info-lookup id) 658 (when geiser-guile-manual-lookup-other-window 659 (switch-to-buffer-other-window "*info*")))) 660 661 662 ;;; Implementation definition: 663 664 (define-geiser-implementation guile 665 (binary geiser-guile--binary) 666 (arglist geiser-guile--parameters) 667 (version-command geiser-guile--version) 668 (minimum-version geiser-guile-minimum-version) 669 (repl-startup geiser-guile--startup) 670 (prompt-regexp geiser-guile--prompt-regexp) 671 (clean-up-output geiser-guile--clean-up-output) 672 (debugger-prompt-regexp geiser-guile--debugger-prompt-regexp) 673 (enter-debugger geiser-guile--enter-debugger) 674 (marshall-procedure geiser-guile--geiser-procedure) 675 (find-module geiser-guile--get-module) 676 (enter-command geiser-guile--enter-command) 677 (exit-command geiser-guile--exit-command) 678 (import-command geiser-guile--import-command) 679 (find-symbol-begin geiser-guile--symbol-begin) 680 (display-error geiser-guile--display-error) 681 (external-help geiser-guile--manual-look-up) 682 (check-buffer geiser-guile--guess) 683 (keywords geiser-guile--keywords) 684 (case-sensitive geiser-guile-case-sensitive)) 685 686 ;;;###autoload 687 (geiser-activate-implementation 'guile) 688 689 ;;;###autoload 690 (autoload 'run-guile "geiser-guile" "Start a Geiser Guile REPL." t) 691 692 ;;;###autoload 693 (autoload 'switch-to-guile "geiser-guile" 694 "Start a Geiser Guile REPL, or switch to a running one." t) 695 696 (provide 'geiser-guile) 697 ;;; geiser-guile.el ends here