emacs/scheme48.el

   1 ;;; scheme48.el --- A major mode for Scheme48 development
   2
   3 ;; Copyright (C) 1992  Jonathan Rees
   4 ;; Copyright (C) 2005, 2006  Jorgen Schaefer
   5
   6 ;; Version: 9
   7 ;; Author: Jonathan Rees (cmuscheme48.el)
   8 ;;         Jorgen Schaefer <forcer@forcix.cx> (scheme48-mode)
   9 ;; URL: http://www.emacswiki.org/cgi-bin/emacs/Scheme48Mode
  10
  11 ;; Redistribution and use in source and binary forms, with or without
  12 ;; modification, are permitted provided that the following conditions
  13 ;; are met:
  14 ;; 1. Redistributions of source code must retain the above copyright
  15 ;;    notice, this list of conditions and the following disclaimer.
  16 ;; 2. Redistributions in binary form must reproduce the above copyright
  17 ;;    notice, this list of conditions and the following disclaimer in the
  18 ;;    documentation and/or other materials provided with the distribution.
  19 ;; 3. The name of the authors may not be used to endorse or promote products
  20 ;;    derived from this software without specific prior written permission.
  21
  22 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
  23 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  24 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  25 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  26 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  27 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  28 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  29 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  30 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  31 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32
  33 ;;; Commentary:
  34
  35 ;; This file provides `scheme48-mode', a major mode for improved
  36 ;; interaction with Scheme48. It's the same as the canonical
  37 ;; `scheme-mode', but provides some commands which tell Scheme48 from
  38 ;; which a specific definition came from. This allows Scheme48 to put
  39 ;; the definition in the correct package by itself.
  40
  41 ;; This is based om the cmuscheme48.el which comes with Scheme48.
  42
  43 ;; You can set a buffer-local variable named `scheme48-package' to
  44 ;; send definitions to that package. This can be done by file
  45 ;; variables, so the following works:
  46
  47 ;;   -*- mode: scheme48; scheme48-package: mypackage -*-
  48
  49 ;; To use the special packages CONFIG, USER and EXEC, use the package
  50 ;; name in parens, like this:
  51
  52 ;;   -*- mode: scheme48; scheme48-package: (exec) -*-
  53
  54 ;;; Thanks:
  55
  56 ;; Thanks to Taylor Campbell (Riastradh on irc.freenode.net) for his
  57 ;; extensive list of indentation settings and the idea with the
  58 ;; scheme48-package local variable.
  59
  60 ;; Thanks to Emilio Lopes for the idea to highlight the new keywords
  61 ;; as well.
  62
  63 ;;; Code:
  64
  65 (require 'cmuscheme)
  66 (require 'scheme)
  67
  68 (defcustom scheme48-compatibility-bindings-p nil
  69   "Use the compatbility bindings?
  70 The old cmuscheme48.el provided a few non-standard bindings,
  71 which can be re-enabled by setting this variable to a non-nil
  72 value before loading this file."
  73   :group 'scheme
  74   :type 'boolean)
  75
  76 (defcustom scheme48-keywords
  77   '(;; R5RS
  78     (dynamic-wind 0)
  79
  80     ;; Scheme48
  81     (destructure 1)
  82     (enum-case 2)
  83     (environment-define! 2 no-font-lock)
  84     (environment-set! 2 no-font-lock)
  85     (guard 1)
  86     (iterate 3)
  87     (make-usual-resumer 2 no-font-lock)
  88     (mvlet 1)
  89     (mvlet* 1)
  90     (search-tree-modify! 2 no-font-lock)
  91     (usual-resumer 0 no-font-lock)
  92     (with-exception-handler 1)
  93     (with-handler 1)
  94     (with-interaction-environment 1)
  95     (with-nondeterminism 0)
  96
  97     ;; I/O-related
  98     (call-with-current-input-port 1)
  99     (call-with-current-noise-port 1)
 100     (call-with-current-output-port 1)
 101     (call-with-string-output-port 0)
 102     (limit-output 2 no-font-lock)
 103     (recurring-write 2 no-font-lock)
 104     (silently 0)
 105     (with-current-ports 3)
 106
 107     ;; Configuration language
 108     (define-interface 1)
 109     (define-structure 2)
 110     (structure 1)
 111     (structures 1)
 112     ;; These don't improve (for some, even degrade) the readability.
 113     ;; (modify 1 no-font-lock)
 114     ;; (subset 1 no-font-lock)
 115
 116     ;; Concurrency-related
 117     (atomically 0)
 118     (atomically! 0)
 119     (call-ensuring-atomicity 0)
 120     (call-ensuring-atomicity! 0)
 121     (ensure-atomicity 0)
 122     (ensure-atomicity! 0)
 123     (interrupt-thread 1 no-font-lock)
 124     (let-fluid 2)
 125     (let-fluids defun)
 126     (spawn-on-scheduler 1 no-font-lock)
 127     (with-new-proposal 1)
 128
 129     ;; SCSH
 130     (with-current-input-port 2)
 131     (with-current-output-port 2)
 132     (awk 3)
 133     (close-after 2 no-font-lock)
 134     (if-match 2)
 135     (with-cwd 1)
 136     (with-cwd* 1)
 137
 138     ;; Others
 139     (let-optionals scheme-let-indent)
 140     (let-optionals* scheme-let-indent)
 141
 142     ;; SRFI-2
 143     (and-let* 1)
 144
 145     ;; SRFI-8
 146     (receive 2)
 147
 148     ;; SRFI-11
 149     (let-values 1)
 150     (let*-values 1)
 151     )
 152   "A list of Scheme48-related keywords.
 153 The list consists of lists of the form (KEYWORD INDENT [NO-FONT-LOCK].
 154 The keywords named KEYWORD will be indented according to INDENT,
 155 and will also be highlighted as keywords unless NO-FONT-LOCK is
 156 non-nil."
 157   :group 'scheme
 158   :type '(repeat (list symbol sexp boolean)))
 159
 160 (defvar scheme48-package nil
 161   "The name of the package definitions from this file should go to.")
 162 (make-variable-buffer-local 'scheme48-package)
 163
 164 (put 'scheme48-package 'safe-local-variable 'scheme48-safe-variable)
 165
 166 (defun scheme48-safe-variable (var)
 167   "Return non-nil when VAR is a valid value of `scheme48-package'."
 168   (or (symbolp var)
 169       (stringp var)
 170       (and (consp var)
 171            (or (and (null (cdr var))
 172                     (memq (car var)
 173                           '(config user exec)))
 174                (and (null (cddr var))
 175                     (eq 'for-syntax (car var))
 176                     (or (symbolp (cadr var))
 177                         (stringp (cadr var))))))))
 178
 179 (defvar scheme48-mode-map
 180   (let ((map (make-sparse-keymap)))
 181     (define-key map "\M-\C-x" 'scheme48-send-definition) ;gnu convention
 182     (define-key map "\C-x\C-e" 'scheme48-send-last-sexp) ;gnu convention
 183     (define-key map "\C-c\C-e" 'scheme48-send-definition)
 184     (define-key map "\C-c\M-e" 'scheme48-send-definition-and-go)
 185     (define-key map "\C-c\C-r" 'scheme48-send-region)
 186     (define-key map "\C-c\M-r" 'scheme48-send-region-and-go)
 187     (define-key map "\C-c\C-l" 'scheme48-load-file)
 188     (when scheme48-compatibility-bindings-p
 189       (define-key map "\C-ce"    'scheme48-send-definition)
 190       (define-key map "\C-c\C-e" 'scheme48-send-definition-and-go)
 191       (define-key map "\C-cr"    'scheme48-send-region)
 192       (define-key map "\C-c\C-r" 'scheme48-send-region-and-go)
 193       (define-key map "\C-cl"    'scheme48-load-file))
 194     map)
 195   "The keymap used in `scheme48-mode'.")
 196
 197 (define-derived-mode scheme48-mode scheme-mode "Scheme48"
 198   "Major mode for improved Scheme48 interaction.
 199 This mode is derived from `scheme-mode', so see there for
 200 information.
 201
 202 The commands that send code to the Scheme48 process attach
 203 information as to from which file the code comes from. This
 204 allows Scheme48 to put the corresponding definitions in the
 205 package associated with that file name.
 206
 207 \\{scheme48-mode-map}"
 208   (scheme48-initialize)
 209   (set (make-local-variable 'scheme-trace-command)
 210        ",trace %s")
 211   (set (make-local-variable 'scheme-untrace-command)
 212        ",untrace %s")
 213   (set (make-local-variable 'scheme-macro-expand-command)
 214        ",expand %s")
 215   (when (boundp 'package)
 216     (message "The `package' local variable is deprecated. Use `scheme48-package' instead.")
 217     (when (not scheme48-package)
 218       (setq scheme48-package package))))
 219
 220 (defvar scheme48-mode-initialized-p nil
 221   "This is non-nil when `scheme48-mode' has been initialized.
 222 Set it to nil if you want the next invocation of `scheme48-mode'
 223 to re-read `scheme48-keywords'.")
 224
 225 (defun scheme48-initialize ()
 226   "Initialize `scheme48-mode' from `scheme48-keywords'.
 227 Only run when `scheme48-mode-initialized-p' is nil.
 228 This is done so that the user can modify `scheme48-keywords'
 229 before the first time the mode is run, but after this package has
 230 been loaded."
 231   (when (not scheme48-mode-initialized-p)
 232     (mapc (lambda (entry)
 233             (put (car entry)
 234                  'scheme-indent-function
 235                  (cadr entry))
 236             (put (intern (upcase (symbol-name (car entry))))
 237                  'scheme-indent-function
 238                  (cadr entry)))
 239           scheme48-keywords)
 240     (let ((regexp (concat "("
 241                           (regexp-opt
 242                            (delete nil
 243                                    (mapcar (lambda (elt)
 244                                              (if (nth 2 elt)
 245                                                  nil
 246                                                (symbol-name (car elt))))
 247                                            scheme48-keywords))
 248                            t)
 249                           "\\>")))
 250       (font-lock-add-keywords 'scheme48-mode
 251                               (list (list regexp 1 'font-lock-keyword-face))))
 252     (setq scheme48-mode-initialized-p t)))
 253
 254 (defun scheme48-send-region (start end)
 255   "Send the current region to the inferior Scheme process."
 256   (interactive "r")
 257   (cond
 258    (scheme48-package
 259     (scheme48-send-with-prefix (scheme48-package-sender scheme48-package)
 260                                start
 261                                end))
 262    ((buffer-file-name (current-buffer))
 263     (comint-send-string (scheme-proc)
 264                         (concat ",from-file "
 265                                 (scheme48-enough-scheme-file-name
 266                                  (buffer-file-name (current-buffer)))
 267                                 "\n"))
 268     (comint-send-region (scheme-proc) start end)
 269     (comint-send-string (scheme-proc) " ,end\n"))
 270    (t
 271     (comint-send-region (scheme-proc) start end)
 272     (comint-send-string (scheme-proc) "\n"))))
 273
 274 (defun scheme48-send-with-prefix (prefix start end)
 275   "Send all Scheme definitions in the region to the Scheme process."
 276   (let ((region (buffer-substring-no-properties start end))
 277         (p prefix)) ; Emacs lossage - prefix is suddenly nil below
 278     (with-temp-buffer
 279       (insert region "\n")
 280       ;; `backward-sexp' relies on this. Thanks to Riastradh for
 281       ;; finding it out :-)
 282       (set-syntax-table scheme-mode-syntax-table)
 283       (set (make-local-variable 'parse-sexp-ignore-comments) t)
 284       ;; Add prefix
 285       (while (> (point)
 286                 (progn (backward-sexp)
 287                        (point)))
 288         (save-excursion
 289           (insert "\n" p " ")))
 290       (comint-send-region (scheme-proc)
 291                           (point-min)
 292                           (point-max)))))
 293
 294 (defun scheme48-send-definition ()
 295   "Send the current definition to the inferior Scheme48 process."
 296   (interactive)
 297   (save-excursion
 298     (end-of-defun)
 299     (let ((end (point)))
 300       (beginning-of-defun)
 301       (scheme48-send-region (point) end))))
 302
 303 (defun scheme48-send-last-sexp ()
 304   "Send the previous sexp to the inferior Scheme process."
 305   (interactive)
 306   (scheme48-send-region (save-excursion (backward-sexp) (point)) (point)))
 307
 308 (defun scheme48-send-region-and-go (start end)
 309   "Send the current region to the inferior Scheme48 process,
 310 and switch to the process buffer."
 311   (interactive "r")
 312   (scheme48-send-region start end)
 313   (switch-to-scheme t))
 314
 315 (defun scheme48-send-definition-and-go ()
 316   "Send the current definition to the inferior Scheme48,
 317 and switch to the process buffer."
 318   (interactive)
 319   (scheme48-send-definition)
 320   (switch-to-scheme t))
 321
 322 (defun scheme48-load-file (file-name)
 323   "Load a Scheme file into the inferior Scheme48 process."
 324   (interactive (comint-get-source "Load Scheme48 file: "
 325                                   scheme-prev-l/c-dir/file
 326                                   scheme-source-modes t)) ; T because LOAD
 327                                                           ; needs an exact name
 328   (comint-check-source file-name) ; Check to see if buffer needs saved.
 329   (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
 330                                        (file-name-nondirectory file-name)))
 331   (comint-send-string
 332    (scheme-proc)
 333    (concat (if scheme48-package
 334                (concat (scheme48-package-sender scheme48-package)
 335                        " ")
 336              "")
 337            ",load "
 338            (scheme48-enough-scheme-file-name file-name)
 339            "\n")))
 340
 341 (defun scheme48-package-sender (package)
 342   "Return the prefix to send a definition to PACKAGE."
 343   (cond
 344    ((equal package '(config))
 345     ",config")
 346    ((equal package '(user))
 347     ",user")
 348    ((equal package '(exec))
 349     ",exec")
 350    ((and (consp package)
 351          (eq 'for-syntax (car package)))
 352     (format ",in %s ,for-syntax" (cadr package)))
 353    (t
 354     (format ",in %s" package))))
 355
 356 ;;; This assumes that when you load things into Scheme 48, you type
 357 ;;; names of files in your home directory using the syntax "~/".
 358 ;;; Similarly for current directory. Maybe we ought to send multiple
 359 ;;; file names to Scheme and let it look at all of them.
 360
 361 (defcustom scheme48-home-directory-kludge t
 362   "*Whether the home directory should be simplified.
 363
 364 When telling Scheme48 about the file name, it's a difference
 365 whether we send a file name beginning with \"~/\" or the actual
 366 expanded path name. If this is non-nil and the file name for
 367 `scheme48-enough-scheme-file-name' starts with the user's home
 368 directory, that is replaced with \"~/\"."
 369   :group 'scheme
 370   :type 'boolean)
 371
 372 (defun scheme48-enough-scheme-file-name (file)
 373   "Return a canonical name for FILE.
 374 This will trim off the directory used in the *scheme* buffer,
 375 or replace a home directory at the beginning with ~/ if
 376 `scheme48-home-directory-kludge' is non-nil."
 377   (let ((file (expand-file-name file))
 378         (scheme-dir (with-current-buffer scheme-buffer
 379                       (expand-file-name default-directory))))
 380     (or (scheme48-replace-prefix file scheme-dir)
 381         (and scheme48-home-directory-kludge
 382              (scheme48-replace-prefix file (expand-file-name "~/") "~/"))
 383         file)))
 384
 385 (defun scheme48-replace-prefix (file prefix &optional replace)
 386   "Replace PREFIX at the beginning of FILE with REPLACE, or \"\"."
 387   (let ((replace (or replace ""))
 388         (len (length prefix)))
 389     (if (and (> (length file)
 390                 len)
 391              (string-equal (substring file 0 len)
 392                            prefix))
 393         (concat replace (substring file len))
 394       nil)))
 395
 396 (provide 'scheme48)
 397 ;;; scheme48.el ends here