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