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 started."
  62   :type '(repeat file)
  63   :group 'geiser-gambit)
  64
  65 (geiser-custom--defcustom geiser-gambit-compile-geiser-p t
  66   "Non-nil means that the Geiser runtime will be compiled on load."
  67   :type 'boolean
  68   :group 'geiser-gambit)
  69
  70 (geiser-custom--defcustom geiser-gambit-init-file "~/.gambit-geiser"
  71   "Initialization file with user code for the Gambit REPL.
  72 If all you want is to load ~/.gambit, set
  73 `geiser-gambit-load-init-file-p' instead."
  74   :type 'string
  75   :group 'geiser-gambit)
  76
  77 (geiser-custom--defcustom geiser-gambit-load-init-file-p nil
  78   "Whether to load ~/.gambit when starting Gambit.
  79 Note that, due to peculiarities in the way Gambit loads its init
  80 file, using `geiser-gambit-init-file' is not equivalent to setting
  81 this variable to t."
  82   :type 'boolean
  83   :group 'geiser-gambit)
  84
  85 (geiser-custom--defcustom geiser-gambit-extra-keywords nil
  86   "Extra keywords highlighted in gambit scheme buffers."
  87   :type '(repeat string)
  88   :group 'geiser-gambit)
  89
  90 (geiser-custom--defcustom geiser-gambit-case-sensitive-p t
  91   "Non-nil means keyword highlighting is case-sensitive."
  92   :type 'boolean
  93   :group 'geiser-gambit)
  94
  95 ;; TODO path for debugger and debugging functions
  96
  97 ;;; REPL support:
  98
  99 (defun geiser-gambit--binary ()
 100   (if (listp geiser-gambit-binary)
 101       (car geiser-gambit-binary)
 102     geiser-gambit-binary))
 103
 104 (defconst geiser-gambit--prompt-regexp "> ")
 105
 106 (defconst geiser-gambit--debugger-prompt-regexp "[0-9]+> ")
 107 ;; taken from gerbil scheme
 108 (geiser-custom--defcustom geiser-gambit-debug-show-bt-p t
 109   "Whether to automatically show a full backtrace when entering the debugger.
 110 If `nil', only the last frame is shown."
 111   :type 'boolean
 112   :group 'geiser-gambit)
 113
 114 (geiser-custom--defcustom geiser-gambit-show-debug-help-p t
 115   "Whether to show brief help in the echo area when entering the debugger."
 116   :type 'boolean
 117   :group 'geiser-gambit)
 118
 119 (geiser-custom--defcustom geiser-gambit-jump-on-debug-p nil
 120   "Whether to automatically jump to error when entering the debugger.
 121 If `t', Geiser will use `next-error' to jump to the error's location."
 122   :type 'boolean
 123   :group 'geiser-gambit)
 124
 125 ;;; Evaluation support:
 126
 127 ;; evaluation support when module loaded at opening
 128 ;; the gambit/geiser# is the namespace of geiser module for gambit
 129
 130 (defun geiser-gambit--geiser-procedure (proc &rest args)
 131   (cl-case proc
 132     ((eval compile)
 133      (let* ((form (mapconcat 'identity (cdr args) " "))
 134             (module (cond ((string-equal "'()" (car args))
 135                            "'()")
 136                           ((and (car args) (not (string-prefix-p "'" (car args)))
 137                                 (not (string-prefix-p "#" (car args))))
 138                            (concat "'" (car args)))
 139                           (t
 140                            "#f")))
 141             (cmd (format "(gambit/geiser#geiser:eval %s '%s)" module form)))
 142        cmd))
 143     ((load-file compile-file)
 144      (format "(gambit/geiser#geiser:load-file %s)" (car args)))
 145     ((no-values)
 146      "(gambit/geiser#geiser:no-values)")
 147     (t
 148      (let ((form (mapconcat 'identity args " ")))
 149        (format "(gambit/geiser#geiser:%s %s)" proc form)))))
 150
 151 ;;(defconst geiser-gambit--module-re
 152 ;;  "( *module +\\(([^)]+)\\|[^ ]+\\)\\|( *define-library +\\(([^)]+)\\|[^ ]+\\)")
 153
 154 ;;(defun geiser-gambit--module-cmd (module fmt &optional def)
 155 ;; (when module
 156 ;;    (let* ((module (geiser-gambit--get-module module))
 157 ;;           (module (cond ((or (null module) (eq module :f)) def)
 158 ;;                         (t (format "%s" module)))))
 159 ;;      (and module (format fmt module)))))
 160
 161 ;; not supported by gambit
 162 ;;
 163 ;;(defun geiser-gambit--get-module (&optional module)
 164 ;;  (cond ((null module)
 165 ;;         (save-excursion
 166 ;;           (geiser-syntax--pop-to-top)
 167 ;;           (if (or (re-search-backward geiser-gambit--module-re nil t)
 168 ;;                   (looking-at geiser-gambit--library-re)
 169 ;;                   (re-search-forward geiser-gambit--module-re nil t))
 170 ;;               (geiser-gambit--get-module (match-string-no-properties 1))
 171 ;;             :f)))
 172 ;;        ((listp module) module)
 173 ;;        ((stringp module)
 174 ;;         (condition-case nil
 175 ;;             (car (geiser-syntax--read-from-string module))
 176 ;;           (error :f)))
 177 ;;        (t :f)))
 178
 179 ;;(defun geiser-gambit--import-command (module)
 180 ;;  (geiser-gambit--module-cmd module ",use %s"))
 181
 182 ;; not implemented by gambit for the moment
 183 ;;(defun geiser-gambit--enter-command (module)
 184 ;;  (geiser-gambit--module-cmd module ",m %s" module))
 185
 186 (defun geiser-gambit--exit-command () ",q")
 187
 188 (defun geiser-gambit--symbol-begin (module)
 189   (save-excursion (skip-syntax-backward "^-()> ") (point)))
 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 (geiser--cut-version 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
 314 ;;; Implementation definition:
 315
 316 (define-geiser-implementation gambit
 317   (unsupported-procedures '(callers callees generic-methods
 318                                     module-location symbol-documentation))
 319   (binary geiser-gambit--binary)
 320   (arglist geiser-gambit--parameters)
 321   (version-command geiser-gambit--version)
 322   (minimum-version geiser-gambit-minimum-version)
 323   (repl-startup geiser-gambit--startup)
 324   (prompt-regexp geiser-gambit--prompt-regexp)
 325   (debugger-prompt-regexp geiser-gambit--debugger-prompt-regexp)
 326   (enter-debugger geiser-gambit--enter-debugger)
 327   (marshall-procedure geiser-gambit--geiser-procedure)
 328   ;;  (find-module geiser-gambit--get-module)
 329   ;;  (enter-command geiser-gambit--enter-command)
 330   (exit-command geiser-gambit--exit-command)
 331   ;;  (import-command geiser-gambit--import-command)
 332   (find-symbol-begin geiser-gambit--symbol-begin)
 333   (display-error geiser-gambit--display-error)
 334   ;;  (external-help geiser-gambit--external-help)
 335   (check-buffer geiser-gambit--guess)
 336   (keywords geiser-gambit--keywords)
 337   (case-sensitive geiser-gambit-case-sensitive-p))
 338
 339 (geiser-impl--add-to-alist 'regexp "\\.scm$" 'gambit t)
 340
 341 (provide 'geiser-gambit)