1#| -*-Scheme-*- 2 3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts 6 Institute of Technology 7 8This file is part of MIT/GNU Scheme. 9 10MIT/GNU Scheme is free software; you can redistribute it and/or modify 11it under the terms of the GNU General Public License as published by 12the Free Software Foundation; either version 2 of the License, or (at 13your option) any later version. 14 15MIT/GNU Scheme is distributed in the hope that it will be useful, but 16WITHOUT ANY WARRANTY; without even the implied warranty of 17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18General Public License for more details. 19 20You should have received a copy of the GNU General Public License 21along with MIT/GNU Scheme; if not, write to the Free Software 22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 23USA. 24 25|# 26 27;;;; Scheme Mode 28 29(declare (usual-integrations)) 30 31(define-command scheme-mode 32 "Enter Scheme mode." 33 () 34 (lambda () (set-current-major-mode! (ref-mode-object scheme)))) 35 36(define-major-mode scheme fundamental "Scheme" 37 "Major mode specialized for editing Scheme code. 38\\[lisp-indent-line] indents the current line for Scheme. 39\\[indent-sexp] indents the next s-expression. 40\\[scheme-complete-variable] completes the variable preceding point. 41\\[show-parameter-list] shows the parameters of the call surrounding point. 42 43The following commands evaluate Scheme expressions: 44 45\\[eval-expression] reads and evaluates an expression in minibuffer. 46\\[eval-last-sexp] evaluates the expression preceding point. 47\\[eval-defun] evaluates the current definition. 48\\[eval-current-buffer] evaluates the buffer. 49\\[eval-region] evaluates the current region. 50 51\\{scheme}" 52 (lambda (buffer) 53 (local-set-variable! syntax-table scheme-mode:syntax-table buffer) 54 (local-set-variable! syntax-ignore-comments-backwards #f buffer) 55 (local-set-variable! lisp-indent-hook standard-lisp-indent-hook buffer) 56 (local-set-variable! lisp-indent-methods scheme-mode:indent-methods buffer) 57 (local-set-variable! lisp-indent-regexps scheme-mode:indent-regexps buffer) 58 (local-set-variable! comment-column 40 buffer) 59 (local-set-variable! comment-locator-hook lisp-comment-locate buffer) 60 (local-set-variable! comment-indent-hook lisp-comment-indentation buffer) 61 (local-set-variable! comment-start ";" buffer) 62 (local-set-variable! comment-end "" buffer) 63 (standard-alternate-paragraph-style! buffer) 64 (local-set-variable! paragraph-ignore-fill-prefix #t buffer) 65 (local-set-variable! indent-line-procedure 66 (ref-command lisp-indent-line) 67 buffer) 68 (local-set-variable! mode-line-process 69 '(RUN-LIGHT (": " RUN-LIGHT) "") 70 buffer) 71 (local-set-variable! local-abbrev-table 72 (ref-variable scheme-mode-abbrev-table buffer) 73 buffer) 74 (event-distributor/invoke! (ref-variable scheme-mode-hook buffer) buffer))) 75 76(define-variable scheme-mode-abbrev-table 77 "Mode-specific abbrev table for Scheme code.") 78(define-abbrev-table 'scheme-mode-abbrev-table '()) 79 80(define-variable scheme-mode-hook 81 "An event distributor that is invoked when entering Scheme mode." 82 (make-event-distributor)) 83 84(define-key 'scheme #\rubout 'backward-delete-char-untabify) 85(define-key 'scheme #\tab 'lisp-indent-line) 86(define-key 'scheme #\) 'lisp-insert-paren) 87(define-key 'scheme #\m-A 'show-parameter-list) 88(define-key 'scheme #\m-g 'undefined) 89(define-key 'scheme #\m-o 'eval-current-buffer) 90(define-key 'scheme #\m-q 'undefined) 91(define-key 'scheme #\m-s 'step-defun) 92(define-key 'scheme #\m-z 'eval-defun) 93(define-key 'scheme #\c-m-q 'indent-sexp) 94(define-key 'scheme #\c-m-z 'eval-region) 95(define-key 'scheme #\m-tab 'scheme-complete-variable) 96(define-key 'scheme '(#\c-c #\c-c) 'eval-abort-top-level) 97 98;;;; Read Syntax 99 100(define scheme-mode:syntax-table (make-char-syntax-table)) 101 102(set-char-syntax! scheme-mode:syntax-table #\tab " ") 103(set-char-syntax! scheme-mode:syntax-table #\newline "> ") 104(set-char-syntax! scheme-mode:syntax-table #\page " ") 105(set-char-syntax! scheme-mode:syntax-table #\space " ") 106 107(set-char-syntax! scheme-mode:syntax-table #\! "_") 108(set-char-syntax! scheme-mode:syntax-table #\" "\" ") 109(set-char-syntax! scheme-mode:syntax-table #\# "_ p14") 110(set-char-syntax! scheme-mode:syntax-table #\$ "_") 111(set-char-syntax! scheme-mode:syntax-table #\% "_") 112(set-char-syntax! scheme-mode:syntax-table #\& "_") 113(set-char-syntax! scheme-mode:syntax-table #\' " p") 114(set-char-syntax! scheme-mode:syntax-table #\( "()") 115(set-char-syntax! scheme-mode:syntax-table #\) ")(") 116(set-char-syntax! scheme-mode:syntax-table #\* "_") 117(set-char-syntax! scheme-mode:syntax-table #\+ "_") 118(set-char-syntax! scheme-mode:syntax-table #\, " p") 119(set-char-syntax! scheme-mode:syntax-table #\- "_") 120(set-char-syntax! scheme-mode:syntax-table #\. "_") 121(set-char-syntax! scheme-mode:syntax-table #\/ "_") 122(set-char-syntax! scheme-mode:syntax-table #\@ "_ p") 123 124(set-char-syntax! scheme-mode:syntax-table #\: "_") 125(set-char-syntax! scheme-mode:syntax-table #\; "< ") 126(set-char-syntax! scheme-mode:syntax-table #\< "_") 127(set-char-syntax! scheme-mode:syntax-table #\= "_") 128(set-char-syntax! scheme-mode:syntax-table #\> "_") 129(set-char-syntax! scheme-mode:syntax-table #\? "_") 130 131(set-char-syntax! scheme-mode:syntax-table #\[ "(]") 132(set-char-syntax! scheme-mode:syntax-table #\\ "\\ ") 133(set-char-syntax! scheme-mode:syntax-table #\] ")[") 134(set-char-syntax! scheme-mode:syntax-table #\^ "_") 135(set-char-syntax! scheme-mode:syntax-table #\_ "_") 136(set-char-syntax! scheme-mode:syntax-table #\` " p") 137(set-char-syntax! scheme-mode:syntax-table #\{ "(}") 138(set-char-syntax! scheme-mode:syntax-table #\| "\" 23") 139(set-char-syntax! scheme-mode:syntax-table #\} "){") 140(set-char-syntax! scheme-mode:syntax-table #\? "_") 141 142;;;; Indentation 143 144(define (scheme-mode:indent-let-method state indent-point normal-indent) 145 (lisp-indent-special-form 146 (if (let ((start 147 (forward-to-sexp-start 148 (forward-one-sexp (mark1+ (parse-state-containing-sexp state)) 149 indent-point) 150 indent-point))) 151 (and start 152 (not (re-match-forward "\\s(" start)))) 153 2 154 1) 155 state indent-point normal-indent)) 156 157(define scheme-mode:indent-methods 158 (make-string-table)) 159 160(define (scheme-indent-method name method) 161 (define-variable-local-value! (selected-buffer) 162 (name->variable (symbol 'LISP-INDENT/ name) 'INTERN) 163 method)) 164 165(for-each (lambda (entry) 166 (for-each (lambda (name) 167 (string-table-put! scheme-mode:indent-methods 168 (symbol->string name) 169 (car entry))) 170 (cdr entry))) 171 `(;; R4RS keywords: 172 (0 BEGIN DELAY) 173 (1 CASE LAMBDA LET* LETREC LET-SYNTAX LETREC-SYNTAX SYNTAX-RULES) 174 (2 DO) 175 (,scheme-mode:indent-let-method LET) 176 177 ;; R4RS procedures: 178 (1 CALL-WITH-INPUT-FILE WITH-INPUT-FROM-FILE 179 CALL-WITH-OUTPUT-FILE WITH-OUTPUT-TO-FILE) 180 181 ;; SRFI keywords: 182 (1 AND-LET*) 183 (2 RECEIVE) 184 (3 DEFINE-RECORD-TYPE) 185 186 ;; MIT/GNU Scheme keywords: 187 (1 DEFINE-STRUCTURE FLUID-LET LET*-SYNTAX LOCAL-DECLARE 188 NAMED-LAMBDA) 189 190 ;; MIT/GNU Scheme procedures: 191 (0 CALL-WITH-OUTPUT-STRING WITH-OUTPUT-TO-STRING) 192 (1 CALL-WITH-APPEND-FILE CALL-WITH-BINARY-APPEND-FILE 193 CALL-WITH-BINARY-INPUT-FILE CALL-WITH-BINARY-OUTPUT-FILE 194 WITH-INPUT-FROM-PORT WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-PORT 195 CALL-WITH-VALUES WITH-VALUES WITHIN-CONTINUATION 196 KEEP-MATCHING-ITEMS KEEP-MATCHING-ITEMS! DELETE-MATCHING-ITEMS 197 DELETE-MATCHING-ITEMS! FIND-MATCHING-ITEM FIND-NON-MATCHING-ITEM 198 COUNT-MATCHING-ITEMS COUNT-NON-MATCHING-ITEMS 199 LIST-TRANSFORM-POSITIVE LIST-TRANSFORM-NEGATIVE 200 LIST-SEARCH-POSITIVE LIST-SEARCH-NEGATIVE 201 FOR-ALL? THERE-EXISTS? LIST-OF-TYPE? VECTOR-OF-TYPE? 202 CALL-WITH-INPUT-STRING) 203 (2 WITH-SIMPLE-RESTART BIND-CONDITION-HANDLER) 204 (3 MAKE-CONDITION-TYPE) 205 (4 WITH-RESTART))) 206 207(define scheme-mode:indent-regexps 208 `(SCHEME-MODE:INDENT-REGEXPS 209 ("DEFAULT" . #F) 210 ("DEF" . DEFINITION) 211 ("WITH-" . 1))) 212 213;;;; Completion 214 215(define (scheme-complete-symbol bound-only?) 216 (let ((end 217 (let ((point (current-point))) 218 (or (re-match-forward "\\(\\sw\\|\\s_\\)+" 219 point (group-end point) #f) 220 (let ((start (group-start point))) 221 (if (not (and (mark< start point) 222 (re-match-forward "\\sw\\|\\s_" 223 (mark-1+ point) 224 point 225 #f))) 226 (editor-error "No symbol preceding point")) 227 point))))) 228 (let ((start (forward-prefix-chars (backward-sexp end 1 'LIMIT) end))) 229 (standard-completion (extract-string start end) 230 (lambda (prefix if-unique if-not-unique if-not-found) 231 (let ((completions 232 (let ((environment (evaluation-environment #f))) 233 (obarray-completions 234 (if (and bound-only? 235 (environment-lookup 236 environment 237 '*PARSER-CANONICALIZE-SYMBOLS?*)) 238 (string-downcase prefix) 239 prefix) 240 (if bound-only? 241 (lambda (symbol) 242 (environment-bound? environment symbol)) 243 (lambda (symbol) 244 symbol ;ignore 245 #t)))))) 246 (cond ((not (pair? completions)) 247 (if-not-found)) 248 ((null? (cdr completions)) 249 (if-unique (symbol-name (car completions)))) 250 (else 251 (let ((completions (map symbol-name completions))) 252 (if-not-unique 253 (string-greatest-common-prefix completions) 254 (lambda () (sort completions string<=?)))))))) 255 (lambda (completion) 256 (delete-string start end) 257 (insert-string completion start)))))) 258 259(define (obarray-completions prefix filter) 260 (let ((completions '())) 261 (for-each-interned-symbol 262 (lambda (symbol) 263 (if (and (string-prefix? prefix (symbol-name symbol)) 264 (filter symbol)) 265 (set! completions (cons symbol completions))) 266 unspecific)) 267 completions)) 268 269(define-command scheme-complete-symbol 270 "Perform completion on Scheme symbol preceding point. 271That symbol is compared against the symbols that exist 272and any additional characters determined by what is there 273are inserted. 274With prefix arg, only symbols that are bound in the buffer's 275environment are considered." 276 "P" 277 scheme-complete-symbol) 278 279(define-command scheme-complete-variable 280 "Perform completion on Scheme variable name preceding point. 281That name is compared against the bound variables in the evaluation environment 282and any additional characters determined by what is there are inserted. 283With prefix arg, the evaluation environment is ignored and all symbols 284are considered for completion." 285 "P" 286 (lambda (all-symbols?) (scheme-complete-symbol (not all-symbols?)))) 287 288(define-command show-parameter-list 289 "Show the parameter list of the procedure in the call surrounding point. 290With prefix argument, the parameter list is inserted at point. 291Otherwise, it is shown in the echo area." 292 "d\nP" 293 (lambda (point insert?) 294 (let ((start 295 (forward-down-list (backward-up-list point 1 'ERROR) 1 'ERROR)) 296 (buffer (mark-buffer point))) 297 (let* ((end (forward-sexp start 1 'ERROR)) 298 (procedure-region (make-region start end)) 299 (procedure-name (region->string procedure-region))) 300 (let ((procedure 301 (let ((environment (evaluation-environment buffer))) 302 (extended-scode-eval 303 (syntax (with-input-from-region procedure-region read) 304 environment) 305 environment)))) 306 (if (procedure? procedure) 307 (let ((argl (procedure-argl procedure))) 308 (if (and insert? 309 (let loop ((argl argl)) 310 (or (symbol? argl) 311 (null? argl) 312 (and (pair? argl) 313 (or (symbol? (car argl)) 314 (eq? (car argl) #!optional) 315 (eq? (car argl) #!rest) 316 (eq? (car argl) #!aux)) 317 (loop (cdr argl)))))) 318 (let ((point (mark-left-inserting-copy point))) 319 (let loop ((argl argl)) 320 (cond ((pair? argl) 321 (insert-char #\space point) 322 (insert-string (if (symbol? (car argl)) 323 (symbol-name (car argl)) 324 (write-to-string (car argl))) 325 point) 326 (loop (cdr argl))) 327 ((symbol? argl) 328 (insert-string " . " point) 329 (insert-string (symbol-name argl) point))))) 330 (fluid-let ((*unparse-uninterned-symbols-by-name?* #t)) 331 (message procedure-name ": " argl)))) 332 (editor-error "Expression does not evaluate to a procedure: " 333 (extract-string start end)))))))) 334 335(define (procedure-argl proc) 336 "Returns the arg list of PROC. 337Grumbles if PROC is an undocumented primitive." 338 (if (primitive-procedure? proc) 339 (let ((doc-string (primitive-procedure-documentation proc))) 340 (if doc-string 341 (let ((newline (string-find-next-char doc-string #\newline))) 342 (if newline 343 (string-head doc-string newline) 344 doc-string)) 345 (string-append (write-to-string proc) 346 " has no documentation string."))) 347 (let ((code (procedure-lambda proc))) 348 (if code 349 (lambda-components* code 350 (lambda (name required optional rest body) 351 name body 352 (append required 353 (if (null? optional) '() `(#!OPTIONAL ,@optional)) 354 (if rest `(#!REST ,rest) '())))) 355 "No debugging information available for this procedure."))))