3
;;; $Id: editor.scm,v 1.253 2001/12/19 05:25:25 cph Exp $
5
;;; Copyright (c) 1986, 1989-2001 Massachusetts Institute of Technology
7
;;; This program is free software; you can redistribute it and/or
8
;;; modify it under the terms of the GNU General Public License as
9
;;; published by the Free Software Foundation; either version 2 of the
10
;;; License, or (at your option) any later version.
12
;;; This program is distributed in the hope that it will be useful,
13
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15
;;; General Public License for more details.
17
;;; You should have received a copy of the GNU General Public License
18
;;; along with this program; if not, write to the Free Software
19
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
3
$Id: editor.scm,v 1.258 2003/02/14 18:28:12 cph Exp $
5
Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
6
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
7
Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
9
This file is part of MIT/GNU Scheme.
11
MIT/GNU Scheme is free software; you can redistribute it and/or modify
12
it under the terms of the GNU General Public License as published by
13
the Free Software Foundation; either version 2 of the License, or (at
14
your option) any later version.
16
MIT/GNU Scheme is distributed in the hope that it will be useful, but
17
WITHOUT ANY WARRANTY; without even the implied warranty of
18
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19
General Public License for more details.
21
You should have received a copy of the GNU General Public License
22
along with MIT/GNU Scheme; if not, write to the Free Software
23
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
22
28
;;;; Editor Top Level
271
279
(debug-internal-errors?
272
280
(error condition))
274
(maybe-debug-scheme-error
275
(ref-variable-object debug-on-internal-error)
276
condition "internal")
278
(message (condition/report-string condition))
279
(return-to-command-loop condition))))
282
(maybe-debug-scheme-error 'INTERNAL condition))))
284
(define (maybe-debug-scheme-error error-type condition)
286
(variable-default-value
287
(or (name->variable (symbol-append 'DEBUG-ON- error-type '-ERROR) #f)
288
(ref-variable-object debug-on-internal-error)))))
290
(debug-scheme-error error-type condition (eq? p 'ASK))))
291
(standard-error-report error-type condition #f)
293
(return-to-command-loop condition))
281
295
(define-variable debug-on-internal-error
282
"True means enter debugger if error is signalled while the editor is running.
296
"True means enter debugger if an internal error is signalled.
297
False means ignore the error and resume editing (this is the default value).
298
The symbol ASK means ask what to do.
283
299
This does not affect editor errors or evaluation errors."
301
(lambda (x) (or (boolean? x) (eq? x 'ASK))))
287
303
(define debug-internal-errors? #f)
289
305
(define condition-type:editor-error
290
306
(make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS)
291
307
(lambda (condition port)
292
(write-string "Editor error: " port)
293
308
(write-string (message-args->string (editor-error-strings condition))
305
320
(condition-accessor condition-type:editor-error 'STRINGS))
307
322
(define (editor-error-handler condition)
308
(maybe-debug-scheme-error (ref-variable-object debug-on-editor-error)
311
(let ((strings (editor-error-strings condition)))
312
(if (not (null? strings))
313
(apply message strings)))
314
(return-to-command-loop condition))
323
(maybe-debug-scheme-error 'EDITOR condition))
316
325
(define-variable debug-on-editor-error
317
"True means signal Scheme error when an editor error occurs."
326
"True means enter debugger if an editor error is signalled.
327
False means ignore the error and resume editing (this is the default value).
328
The symbol ASK means ask what to do.
329
This does not affect internal errors or evaluation errors."
331
(lambda (x) (or (boolean? x) (eq? x 'ASK))))
321
(define (standard-error-report condition error-type-name in-prompt?)
322
(let ((report-string (condition/report-string condition)))
333
(define (standard-error-report error-type condition in-prompt?)
335
(string-append (string-capitalize (symbol->string error-type))
337
(report-string (condition/report-string condition))
340
(string->temporary-buffer (apply string-append strings)
323
343
(let ((typein-report
325
(message (string-capitalize error-type-name)
345
(if (eq? error-type 'EDITOR)
346
(message report-string)
347
(message type-string ": " report-string))))
328
348
(error-buffer-report
330
(string->temporary-buffer report-string "*error*"
332
(message (string-capitalize error-type-name) " error")
351
(if (eq? error-type 'EDITOR)
352
(get-error-buffer report-string)
353
(get-error-buffer type-string ":\n" report-string))
355
(get-error-buffer report-string)
356
(message type-string)))
333
357
(update-screens! #f)))
334
358
(transcript-report
336
360
(and (ref-variable enable-transcript-buffer)
338
362
(with-output-to-transcript-buffer
341
(write-string ";Error: ")
342
(write-string report-string)
366
(write-string type-string)
368
(write-string report-string)
346
372
(let ((fit-report
348
374
(if (and (not in-prompt?)
349
375
(not (string-find-next-char report-string #\newline))
352
(variable-default-value
353
(ref-variable-object char-image-strings)))
376
(< (string-columns report-string 0 8
377
(ref-variable char-image-strings
354
379
(window-x-size (typein-window))))
356
381
(error-buffer-report)))))
365
390
"Value of this variable controls the way evaluation error messages
367
392
STANDARD like FIT, except messages also appear in transcript buffer,
393
if it is enabled (this is the default value).
369
394
FIT messages appear in typein window if they fit;
370
in *error* buffer if they don't.
395
in \"*error*\" buffer if they don't.
371
396
TYPEIN messages appear in typein window.
372
ERROR-BUFFER messages appear in *error* buffer.
397
ERROR-BUFFER messages appear in \"*error*\" buffer.
373
398
TRANSCRIPT messages appear in transcript buffer, if it is enabled;
374
399
otherwise this is the same as FIT."
376
401
(lambda (value) (memq value '(STANDARD TRANSCRIPT ERROR-BUFFER TYPEIN FIT))))
378
405
(define condition-type:abort-current-command
379
406
(make-condition-type 'ABORT-CURRENT-COMMAND #f '(INPUT)
380
407
(lambda (condition port)
458
485
(define (exit-scheme)
459
486
(within-continuation editor-abort %exit))
461
(define (unwind-protect setup body cleanup)
462
(dynamic-wind (or setup (lambda () unspecific)) body cleanup))
464
488
(define (editor-grab-display editor receiver)
465
489
(display-type/with-display-grabbed (editor-display-type editor)
466
490
(lambda (with-display-ungrabbed operations)
added
removed
src/edwin/editor.scm
