elisp/geiser-gambit.el

   1 ;;; geiser-gambit.el -- gambit's implementation of the geiser protocols
   2
   3 ;; Copyright (C) 2014, 2015, 2019 Daniel Leslie
   4
   5 ;; Based on geiser-guile.el by Jose Antonio Ortega Ruiz
   6
   7 ;; This program is free software; you can redistribute it and/or
   8 ;; modify it under the terms of the Modified BSD License. You should
   9 ;; have received a copy of the license along with this program. If
  10 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
  11
  12 ;; Start date: Sun Mar 08, 2009 23:03
  13
  14 ;;; Commentary:
  15
  16 ;; Gambit in geiser, thank you to Chris Blom for the start he did few years ago
  17 ;; https://github.com/ChrisBlom
  18
  19 ;; TODO
  20 ;; [ ] the gambit guessing words lists
  21
  22 \f
  23 ;;; Code:
  24
  25 (require 'geiser-connection)
  26 (require 'geiser-syntax)
  27 (require 'geiser-custom)
  28 (require 'geiser-base)
  29 (require 'geiser-eval)
  30 (require 'geiser-edit)
  31 (require 'geiser-log)
  32 (require 'geiser)
  33
  34 (require 'compile)
  35 (require 'info-look)
  36
  37 (eval-when-compile (require 'cl-lib))
  38
  39 (defconst geiser-gambit--builtin-keywords
  40   '("##debug-repl" "##import" "define-macro" "##symbol-table" "##decompile"))
  41
  42 ;;; Customization
  43
  44 (defgroup geiser-gambit nil
  45   "Customization for Geiser's Gambit flavour."
  46   :group 'geiser)
  47
  48 ;; define the interpreter for geiser.
  49 ;; the geiser-costum--defcustom is a macro that will
  50 ;; call a declaration into the documentation of the
  51 ;; structure of the method and then define the method
  52 ;; with a defcustom: define a variable that represents an option users might want to set
  53 (geiser-custom--defcustom geiser-gambit-binary
  54   (cond ((eq system-type 'windows-nt) '("gsi.exe"))
  55         (t "gsi"))
  56   "Name to use to call the gambit executable when starting a REPL."
  57   :type '(choice string (repeat string))
  58   :group 'geiser-gambit)
  59
  60 (geiser-custom--defcustom geiser-gambit-load-path nil
  61   "A list of paths to be added to gambit's load path when it's
  62 started."
  63   :type '(repeat file)
  64   :group 'geiser-gambit)
  65
  66 (geiser-custom--defcustom geiser-gambit-compile-geiser-p t
  67   "Non-nil means that the Geiser runtime will be compiled on load."
  68   :type 'boolean
  69   :group 'geiser-gambit)
  70
  71 (geiser-custom--defcustom geiser-gambit-init-file "~/.gambit-geiser"
  72   "Initialization file with user code for the Gambit REPL.
  73 If all you want is to load ~/.gambit, set
  74 `geiser-gambit-load-init-file-p' instead."
  75   :type 'string
  76   :group 'geiser-gambit)
  77
  78 (geiser-custom--defcustom geiser-gambit-load-init-file-p nil
  79   "Whether to load ~/.gambit when starting Gambit.
  80 Note that, due to peculiarities in the way Gambit loads its init
  81 file, using `geiser-gambit-init-file' is not equivalent to setting
  82 this variable to t."
  83   :type 'boolean
  84   :group 'geiser-gambit)
  85
  86 (geiser-custom--defcustom geiser-gambit-extra-keywords nil
  87   "Extra keywords highlighted in gambit scheme buffers."
  88   :type '(repeat string)
  89   :group 'geiser-gambit)
  90
  91 (geiser-custom--defcustom geiser-gambit-case-sensitive-p t
  92   "Non-nil means keyword highlighting is case-sensitive."
  93   :type 'boolean
  94   :group 'geiser-gambit)
  95
  96 ;; TODO path for debugger and debugging functions
  97
  98 ;;; REPL support:
  99
 100 (defun geiser-gambit--binary ()
 101   (if (listp geiser-gambit-binary)
 102       (car geiser-gambit-binary)
 103     geiser-gambit-binary))
 104
 105 (defconst geiser-gambit--prompt-regexp "> ")
 106
 107 (defconst geiser-gambit--debugger-prompt-regexp "[0-9]+> ")
 108 ;; taken from gerbil scheme
 109 (geiser-custom--defcustom geiser-gambit-debug-show-bt-p t
 110   "Whether to automatically show a full backtrace when entering the debugger.
 111 If `nil', only the last frame is shown."
 112   :type 'boolean
 113   :group 'geiser-gambit)
 114
 115 (geiser-custom--defcustom geiser-gambit-show-debug-help-p t
 116   "Whether to show brief help in the echo area when entering the debugger."
 117   :type 'boolean
 118   :group 'geiser-gambit)
 119
 120 (geiser-custom--defcustom geiser-gambit-jump-on-debug-p nil
 121   "Whether to automatically jump to error when entering the debugger.
 122 If `t', Geiser will use `next-error' to jump to the error's location."
 123   :type 'boolean
 124   :group 'geiser-gambit)
 125
 126 ;;; evaluation support when module loaded at opening
 127 ;;; the gambit/geiser# is the namespace of geiser module for gambit
 128 (defun geiser-gambit--geiser-procedure (proc &rest args)
 129   (cl-case proc
 130     ((eval compile)
 131      (let* ((form (mapconcat 'identity (cdr args) " "))
 132             (module (cond ((string-equal "'()" (car args))
 133                            "'()")
 134                           ((and (car args) (not (string-prefix-p "'" (car args)))
 135                                 (not (string-prefix-p "#" (car args))))
 136                            (concat "'" (car args)))
 137                           (t
 138                            "#f")))
 139             (cmd (format "(gambit/geiser#geiser:eval %s '%s)" module form)))
 140        cmd))
 141     ((load-file compile-file)
 142      (format "(gambit/geiser#geiser:load-file %s)" (car args)))
 143     ((no-values)
 144      "(gambit/geiser#geiser:no-values)")
 145     (t
 146      (let ((form (mapconcat 'identity args " ")))
 147        (format "(gambit/geiser#geiser:%s %s)" proc form)))))
 148
 149 ;;(defconst geiser-gambit--module-re
 150 ;;  "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
 151
 152 ;;(defun geiser-gambit--module-cmd (module fmt &optional def)
 153 ;; (when module
 154 ;;    (let* ((module (geiser-gambit--get-module module))
 155 ;;           (module (cond ((or (null module) (eq module :f)) def)
 156 ;;                         (t (format "%s" module)))))
 157 ;;      (and module (format fmt module)))))
 158
 159 ;; not supported by gambit
 160 ;;
 161 ;;(defun geiser-gambit--get-module (&optional module)
 162 ;;  (cond ((null module)
 163 ;;         (save-excursion
 164 ;;           (geiser-syntax--pop-to-top)
 165 ;;           (if (or (re-search-backward geiser-gambit--module-re nil t)
 166 ;;                   (looking-at geiser-gambit--library-re)
 167 ;;                   (re-search-forward geiser-gambit--module-re nil t))
 168 ;;               (geiser-gambit--get-module (match-string-no-properties 1))
 169 ;;             :f)))
 170 ;;        ((listp module) module)
 171 ;;        ((stringp module)
 172 ;;         (condition-case nil
 173 ;;             (car (geiser-syntax--read-from-string module))
 174 ;;           (error :f)))
 175 ;;        (t :f)))
 176
 177 ;;(defun geiser-gambit--import-command (module)
 178 ;;  (geiser-gambit--module-cmd module ",use %s"))
 179
 180 ;; not implemented by gambit for the moment
 181 ;;(defun geiser-gambit--enter-command (module)
 182 ;;  (geiser-gambit--module-cmd module ",m %s" module))
 183
 184 (defun geiser-gambit--exit-command () ",q")
 185
 186 (defun geiser-gambit--symbol-begin (module)
 187   (save-excursion (skip-syntax-backward "^-()> ") (point)))
 188
 189 ;; error display
 190
 191 ;;; Error display
 192
 193 (defun geiser-gambit--display-error (module key msg)
 194   (newline)
 195   (when (stringp msg)
 196     (save-excursion (insert msg))
 197     (geiser-edit--buttonize-files))
 198   (and (not key) msg (not (zerop (length msg)))))
 199
 200 ;; TODO not sure
 201 (defun geiser-gambit--enter-debugger ()
 202   (let ((bt-cmd (if geiser-gambit-debug-show-bt-p "\n#||#,b\n" "")))
 203     (compilation-forget-errors)
 204     (goto-char (point-max))
 205     (geiser-repl--prepare-send)
 206     (comint-send-string nil bt-cmd)
 207     (when geiser-gambit-show-debug-help-p
 208       (message "Debug REPL. Enter ,t to return to top level, ,? for help."))
 209     (when geiser-gambit-jump-on-debug-p
 210       (accept-process-output (get-buffer-process (current-buffer))
 211                              0.2 nil t)
 212       (ignore-errors (next-error)))))
 213
 214 ;;; Trying to ascertain whether a buffer is Gambit Scheme:
 215
 216 (defconst geiser-gambit--guess-re
 217   (regexp-opt (append '("gsi" "gambit") geiser-gambit--builtin-keywords)))
 218
 219 (defun geiser-gambit--guess ()
 220   (save-excursion
 221     (goto-char (point-min))
 222     (re-search-forward geiser-gambit--guess-re nil t)))
 223
 224 ;; no help at the moment TODO
 225 ;; (defun geiser-gambit--external-help (id module)
 226 ;;  "Loads gambit doc into a buffer"
 227 ;;  (browse-url (format "http://api.call-cc.org/cdoc?q=%s&query-name=Look+up" id)))
 228
 229 ;;; Keywords and syntax
 230
 231 (defun geiser-gambit--keywords ()
 232   `(,geiser-gambit--builtin-keywords))
 233
 234 (geiser-syntax--scheme-indent
 235  (receive 2)
 236  (match 1)
 237  (match-lambda 0)
 238  (match-lambda* 0)
 239  (match-let scheme-let-indent)
 240  (match-let* 1)
 241  (match-letrec 1)
 242  (declare 0)
 243  (cond-expand 0)
 244  (let-values scheme-let-indent)
 245  (let*-values scheme-let-indent)
 246  (letrec-values 1)
 247  (letrec* 1)
 248  (parameterize scheme-let-indent)
 249  (let-location 1)
 250  (foreign-lambda 2)
 251  (foreign-lambda* 2)
 252  (foreign-primitive 2)
 253  (foreign-safe-lambda 2)
 254  (foreign-safe-lambda* 2)
 255  (set! 1)
 256  (let-optionals* 2)
 257  (let-optionals 2)
 258  (condition-case 1)
 259  (fluid-let 1)
 260  (and-let* 1)
 261  (assume 1)
 262  (cut 1)
 263  (cute 1)
 264  (when 1)
 265  (unless 1)
 266  (dotimes 1)
 267  (compiler-typecase 1)
 268  (ecase 1)
 269  (use 0)
 270  (require-extension 0)
 271  (import 0)
 272  (handle-exceptions 2)
 273  (regex-case 1)
 274  (define-inline 1)
 275  (define-constant 1)
 276  (define-syntax-rule 1)
 277  (define-record-type 1)
 278  (define-values 1)
 279  (define-record 1)
 280  (define-specialization 1)
 281  (define-type 1)
 282  (select 1)
 283  (functor 3)
 284  (define-interface 1)
 285  (module 2))
 286
 287 ;;; REPL startup
 288
 289 (defconst geiser-gambit-minimum-version "v4.9.3")
 290
 291 (defun geiser-gambit--version (binary)
 292   (shell-command-to-string (format "%s -e \"(display (##system-version-string))\""
 293                                    binary)))
 294
 295 (defun geiser-gambit--parameters ()
 296   "Return a list with all parameters needed to start Gambit Scheme."
 297   ;; if your version of gambit support modules we directly load geiser module
 298   ;; else we go load the file in geiser
 299   (let* ((v (geiser-gambit--version (geiser-gambit--binary)))
 300          (gambit-version (substring v 1 (string-width v))))
 301     (if (version< gambit-version "4.9.4")
 302         `( "-:d-" ,(expand-file-name "gambit/geiser/gambit.scm" geiser-scheme-dir) "-" )
 303       `("-:d-" "gambit/geiser" "-"))))
 304
 305
 306 (defun connect-to-gambit ()
 307   "Start a Gambit REPL connected to a remote process."
 308   (interactive)
 309   (geiser-connect 'gambit))
 310
 311 (defun geiser-gambit--startup (remote)
 312   (compilation-setup t))
 313 ;;; Implementation definition:
 314
 315 (define-geiser-implementation gambit
 316   (unsupported-procedures '(callers callees generic-methods
 317                                     module-location symbol-documentation))
 318   (binary geiser-gambit--binary)
 319   (arglist geiser-gambit--parameters)
 320   (version-command geiser-gambit--version)
 321   (minimum-version geiser-gambit-minimum-version)
 322   (repl-startup geiser-gambit--startup)
 323   (prompt-regexp geiser-gambit--prompt-regexp)
 324   (debugger-prompt-regexp geiser-gambit--debugger-prompt-regexp)
 325   (enter-debugger geiser-gambit--enter-debugger)
 326   (marshall-procedure geiser-gambit--geiser-procedure)
 327   ;;  (find-module geiser-gambit--get-module)
 328   ;;  (enter-command geiser-gambit--enter-command)
 329   (exit-command geiser-gambit--exit-command)
 330   ;;  (import-command geiser-gambit--import-command)
 331   (find-symbol-begin geiser-gambit--symbol-begin)
 332   (display-error geiser-gambit--display-error)
 333   ;;  (external-help geiser-gambit--external-help)
 334   (check-buffer geiser-gambit--guess)
 335   (keywords geiser-gambit--keywords)
 336   (case-sensitive geiser-gambit-case-sensitive-p))
 337
 338 (geiser-impl--add-to-alist 'regexp "\\.scm$" 'gambit t)
 339
 340 (provide 'geiser-gambit)