elisp/geiser-mit.el

   1 ;;; geiser-mit.el -- MIT/GNU Scheme's implementation of the geiser protocols
   2
   3 ;; This program is free software; you can redistribute it and/or
   4 ;; modify it under the terms of the Modified BSD License. You should
   5 ;; have received a copy of the license along with this program. If
   6 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   7
   8 \f
   9 ;;; Code:
  10
  11 (require 'geiser-connection)
  12 (require 'geiser-syntax)
  13 (require 'geiser-custom)
  14 (require 'geiser-base)
  15 (require 'geiser-eval)
  16 (require 'geiser-edit)
  17 (require 'geiser-log)
  18 (require 'geiser)
  19
  20 (require 'compile)
  21 (require 'info-look)
  22
  23
  24 (eval-when-compile (require 'cl-lib))
  25
  26 \f
  27 ;;; Customization:
  28
  29 (defgroup geiser-mit nil
  30   "Customization for Geiser's MIT/GNU Scheme flavour."
  31   :group 'geiser)
  32
  33 (geiser-custom--defcustom geiser-mit-binary
  34     "mit-scheme"
  35   "Name to use to call the MIT/GNU Scheme executable when starting a REPL."
  36   :type '(choice string (repeat string))
  37   :group 'geiser-mit)
  38
  39 (geiser-custom--defcustom geiser-mit-source-directory
  40     ""
  41   "The path to the MIT/GNU Scheme sources' src/ directory."
  42   :type 'directory
  43   :group 'geiser-mit)
  44
  45 \f
  46 ;;; REPL support:
  47
  48 (defun geiser-mit--binary ()
  49   (if (listp geiser-mit-binary)
  50       (car geiser-mit-binary)
  51     geiser-mit-binary))
  52
  53 (defun geiser-mit--parameters ()
  54   "Return a list with all parameters needed to start MIT/GNU Scheme.
  55 This function uses `geiser-mit-init-file' if it exists."
  56   `("--load" ,(expand-file-name "mit/geiser/load.scm" geiser-scheme-dir))
  57   )
  58
  59 (defconst geiser-mit--prompt-regexp "[0-9]+ ([^)]+) => ") ;; *not* ]=>, that confuses syntax-ppss
  60 (defconst geiser-mit--debugger-prompt-regexp "[0-9]+ error> ")
  61
  62 \f
  63 ;;; Evaluation support:
  64
  65 (defun geiser-mit--geiser-procedure (proc &rest args)
  66   (cl-case proc
  67     ((eval compile)
  68      (let ((form (mapconcat 'identity (cdr args) " "))
  69            (module (cond ((string-equal "'()" (car args))
  70                           "'()")
  71                          ((and (car args))
  72                           (concat "'" (car args)))
  73                          (t
  74                           "#f"))))
  75        (format "(geiser:eval %s '%s)" module form)))
  76     ((load-file compile-file)
  77      (format "(geiser:load-file %s)" (car args)))
  78     ((no-values)
  79      "(geiser:no-values)")
  80     (t
  81      (let ((form (mapconcat 'identity args " ")))
  82        (format "(geiser:%s %s)" proc form)))))
  83
  84 (defconst geiser-mit--module-re
  85   ".*;; package: +\\(([^)]*)\\)")
  86
  87 (defun geiser-mit--get-module (&optional module)
  88   (cond ((null module)
  89          (save-excursion
  90            (geiser-syntax--pop-to-top)
  91            (if (or (re-search-backward geiser-mit--module-re nil t)
  92                    (re-search-forward geiser-mit--module-re nil t))
  93                (geiser-mit--get-module (match-string-no-properties 1))
  94              :f)))
  95         ((listp module) module)
  96         ((stringp module)
  97          (condition-case nil
  98              (car (geiser-syntax--read-from-string module))
  99            (error :f)))
 100         (t :f)))
 101
 102 (defun geiser-mit--module-cmd (module fmt &optional def)
 103   (when module
 104     (let* ((module (geiser-mit--get-module module))
 105            (module (cond ((or (null module) (eq module :f)) def)
 106                          (t (format "%s" module)))))
 107       (and module (format fmt module)))))
 108
 109 (defun geiser-mit--enter-command (module)
 110   (geiser-mit--module-cmd module "(geiser:ge '%s)" "()"))
 111
 112 (defun geiser-mit--exit-command () "(%exit 0)")
 113
 114 (defun geiser-mit--symbol-begin (module)
 115   (if module
 116       (max (save-excursion (beginning-of-line) (point))
 117            (save-excursion (skip-syntax-backward "^(>") (1- (point))))
 118     (save-excursion (skip-syntax-backward "^'-()>") (point))))
 119
 120 ;; \f
 121 ;; ;;; REPL startup
 122
 123 (defconst geiser-mit-minimum-version "9.1.1")
 124
 125 (defun geiser-mit--version (binary)
 126   (car (process-lines binary
 127                       "--quiet"
 128                       "--no-init-file"
 129                       "--eval"
 130                       "(begin (display (get-subsystem-version-string \"Release\"))
 131                               (%exit 0))")))
 132
 133 (defconst geiser-mit--path-rx "^In \\([^:\n ]+\\):\n")
 134 (defun geiser-mit--startup (remote)
 135   (let ((geiser-log-verbose-p t))
 136     (compilation-setup t)
 137     (when (and (stringp geiser-mit-source-directory)
 138                (not (string= geiser-mit-source-directory "")))
 139       (geiser-eval--send/wait (format "(geiser:set-mit-scheme-source-directory %S)" geiser-mit-source-directory)))))
 140 \f
 141 ;;; Implementation definition:
 142
 143 (define-geiser-implementation mit
 144   (binary geiser-mit--binary)
 145   (arglist geiser-mit--parameters)
 146   (version-command geiser-mit--version)
 147   (minimum-version geiser-mit-minimum-version)
 148   (repl-startup geiser-mit--startup)
 149   (prompt-regexp geiser-mit--prompt-regexp)
 150   (debugger-prompt-regexp geiser-mit--debugger-prompt-regexp)
 151   ;; (enter-debugger geiser-mit--enter-debugger)
 152   (marshall-procedure geiser-mit--geiser-procedure)
 153   (find-module geiser-mit--get-module)
 154   (enter-command geiser-mit--enter-command)
 155   (exit-command geiser-mit--exit-command)
 156   ;; (import-command geiser-mit--import-command)
 157   (find-symbol-begin geiser-mit--symbol-begin)
 158   ;; (display-error geiser-mit--display-error)
 159   ;; (external-help geiser-mit--manual-look-up)
 160   ;; (check-buffer geiser-mit--guess)
 161   ;; (keywords geiser-mit--keywords)
 162   ;; (case-sensitive geiser-mit-case-sensitive-p)
 163   )
 164
 165 (geiser-impl--add-to-alist 'regexp "\\.scm$" 'mit t)
 166 (geiser-impl--add-to-alist 'regexp "\\.pkg$" 'mit t)
 167 \f
 168 (provide 'geiser-mit)