1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
2
3    Author:        Jan Wielemaker and Anjo Anjewierden
4    E-mail:        J.Wielemaker@cs.vu.nl
5    WWW:           http://www.swi-prolog.org/projects/xpce/
6    Copyright (c)  1985-2011, University of Amsterdam
7                              VU University Amsterdam
8    All rights reserved.
9
10    Redistribution and use in source and binary forms, with or without
11    modification, are permitted provided that the following conditions
12    are met:
13
14    1. Redistributions of source code must retain the above copyright
15       notice, this list of conditions and the following disclaimer.
16
17    2. Redistributions in binary form must reproduce the above copyright
18       notice, this list of conditions and the following disclaimer in
19       the documentation and/or other materials provided with the
20       distribution.
21
22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33    POSSIBILITY OF SUCH DAMAGE.
34*/
35
36:- module(emacs_buffer, []).
37:- use_module(library(pce)).
38:- require([ between/3
39           , default/3
40           , ignore/1
41           ]).
42
43:- pce_begin_class(emacs_buffer(file, name), text_buffer).
44
45variable(name,            name,         get,  "Name of this buffer").
46variable(directory,       directory,    both, "Associated CWD").
47variable(file,            file*,        get,  "Associated file").
48variable(prompt_reload,   bool := @on,  both, "Prompt before reloading").
49variable(mode,            name,         get,  "Major mode of operation").
50variable(time_stamp,      date*,        get,  "Time-stamp for file").
51variable(ensure_newline,  bool := @on,  both, "Add newline when done").
52variable(ensure_no_whitespace_errors,
53                          bool,         both, "Remove trailing whitespace when done").
54variable(tab_width,       int := 8,     both, "Width of a tab").
55variable(auto_save_mode,  bool,         both, "Auto-save?").
56variable(auto_save_count, number,       get,  "Auto-save at expiration").
57variable(saved_caret,     int,          both, "Saved caret on last quit").
58variable(saved_fill,      bool := @off, both, "Saved fill_mode on quit").
59variable(margin_width,    '0..' := 0,   get,  "Margin width of editors").
60variable(coloured_generation,
61         int := -1,
62         both,
63         "Last generation of the text-buffer that was coloured").
64variable(xref_generation,
65         int := -1,
66         both,
67         "Last generation we analysed").
68
69class_variable(undo_buffer_size,      int, 40000).
70class_variable(ensure_no_whitespace_errors, bool, @on).
71class_variable(newline_existing_file, {posix,dos,detect}, detect).
72class_variable(newline_new_file,      {posix,dos},        posix).
73:- if(current_prolog_flag(windows, true)).
74class_variable(newline_new_file,      {posix,dos},        dos).
75class_variable(unicode_encoding,      {utf8,unicode_le,unicode_be}, unicode_le).
76:- else.
77class_variable(newline_new_file,      {posix,dos},        posix).
78class_variable(unicode_encoding,      {utf8,unicode_le,unicode_be}, utf8).
79:- endif.
80
81initialise(B, File:file*, Name:[name]) :->
82    "Create from file and name"::
83    send(B, send_super, initialise),
84    send(B, saved_caret, 0),
85
86    (   File == @nil
87    ->  send(B, undo_buffer_size, 0),
88        send(B, auto_save_mode, @off),
89        default(Name, '*scratch*', BufBaseName),
90        (   BufBaseName == '*scratch*'
91        ->  send(B, slot, mode, prolog),
92            scratch_text(Text),
93            send(B, insert, 0, Text),
94            send(B, saved_caret, B?size)
95        ;   send(B, slot, mode, fundamental)
96        ),
97        send(B, directory, directory('.'))
98    ;   send(File, absolute_path),
99        get(File, base_name, FileBaseName),
100        default(Name, FileBaseName, BufBaseName),
101        send(B, file, File),
102        send(B, auto_save_mode, @on),
103        send(@emacs_base_names, append, FileBaseName, B),
104        send(B, determine_initial_mode),
105        (   object(@emacs_mark_list)
106        ->  ignore(send(@emacs_mark_list, loaded_buffer, B))
107        ;   true
108        )
109    ),
110
111    send(B, init_mode_defaults),
112    send(B, slot, auto_save_count, number(300)),
113    send(B, name, BufBaseName).
114
115
116unlink(B) :->
117    "Remove from buffer-list and base_name table"::
118    send(@emacs_buffers, delete, B?name),
119    (   get(B, file, File), File \== @nil
120    ->  send(@emacs_base_names, delete, File?base_name, B)
121    ;   true
122    ),
123    send(B, send_super, unlink).
124
125report(B,
126       Kind:kind={status,inform,progress,done,warning,error,fatal},
127       Format:format=[char_array],
128       Argv:any ...) :->
129    "Report to associated editors"::
130    get(B, editors, Editors),
131    Message =.. [message, @arg1, report, Kind, Format | Argv],
132    send(Editors, for_all, Message).
133
134
135scratch_text('% This buffer is for notes you don\'t want to save.\n\c
136              % If you want to create a file, visit that file with C-x C-f,\n\c
137              % then enter the text in that file\'s own buffer.\n\n').
138
139:- pce_global(@emacs_interpreter_regex,
140              new(regex('#!(\\S+)\\s'))).
141:- pce_global(@emacs_mode_regex,        % -*- Mode -*-
142                                        % -*- mode: Mode; ... -*-
143              new(regex('.*-\\*-\\s*([Mm]ode:\\s*(\\w+);.*-\\*-|(\\w+)\\s*-\\*-)'))).
144
145
146% ->determine_initial_mode uses the following steps:
147%
148%   1. If the file is a loaded file, it is a Prolog file
149%   2. The Emacs magic sequences -*- Mode -*- or -*- mode: Mode; ... -*-
150%   3. Try @emacs_content_mode_list
151%   4. Try #! interpreter (PrologScript)
152%   5. Try the file-name
153
154determine_initial_mode(B) :->
155    "Determine initial mode"::
156    (   get(B, file, File), File \== @nil,
157        get(File, name, FileName),
158        absolute_file_name(FileName, FilePath),
159        source_file(FilePath),
160        \+ source_file_property(FilePath, derived_from(_,_))
161    ->  send(B, slot, mode, prolog)
162    ;   send(@emacs_mode_regex, match, B),
163        member(Reg, [2,3]),
164        get(@emacs_mode_regex, register_value, B, Reg, Mode0),
165        get(Mode0?downcase, value, Mode),
166        get(@pce, convert, Mode, emacs_mode, _ModeObject)
167    ->  send(B, slot, mode, Mode)
168    ;   content_from_mode(B, Mode)
169    ->  send(B, slot, mode, Mode)
170    ;   (   send(@emacs_interpreter_regex, match, B),
171            get(@emacs_interpreter_regex, register_value, B, 1, Match),
172            To = @emacs_interpreter_mode_list
173        ;   get(B, file, File),
174            get(File, base_name, Match),
175            To = @emacs_mode_list
176        ),
177        get(To?members, find,
178            message(@arg1?name, match, Match), Att)
179    ->  send(B, slot, mode, Att?value)
180    ;   send(B, slot, mode, @emacs_default_mode)
181    ),
182    send(B, set_temp_file).
183
184set_temp_file(B) :->
185    "Clear ->prompt_reload if this is a temp file"::
186    get(B, file, File),
187    (   no_backup(File)
188    ->  send(B, prompt_reload, @off)
189    ;   true
190    ).
191
192
193%!  content_from_mode(+Buffer, -Mode) is semidet.
194%
195%   Search Buffer with the patterns from @emacs_content_mode_list
196
197content_from_mode(B, Mode) :-
198    get(@emacs_content_mode_list?members, find,
199         message(@arg1?name?first, search, B,
200                 0, @arg1?name?second),
201        Att),
202    get(Att, value, Mode).
203
204
205attach(B, E:editor) :->
206    "A new editor is attached.  Prepare it"::
207    get(B, editors, Editors),
208    (   send(Editors, empty)
209    ->  get(B, saved_caret, Caret),
210        get(B, saved_fill, Fill),
211        get(B, tab_width, TabWidth)
212    ;   get(Editors?head, caret, Caret),
213        get(Editors?head, fill_mode, Fill),
214        get(Editors?head, tab_distance, TabWidth)
215    ),
216    get(B, margin_width, MW),
217    send(B, send_super, attach, E),
218    send(E, caret, Caret),
219    send(E, fill_mode, Fill),
220    send(E, margin_width, MW),
221    send(E, tab_distance, TabWidth).
222
223
224detach(B, E:editor) :->
225    "An editor is detached"::
226    get(B, editors, Editors),
227    (   get(Editors, size, 1)
228    ->  send(B, saved_caret, E?caret),
229        send(B, saved_fill, E?fill_mode)
230    ;   true
231    ),
232    send(B, send_super, detach, E).
233
234
235name(B, Name:name) :->
236    "Rename buffer to name"::
237    get(B, name, OldName),
238    (   Name == OldName
239    ->  true
240    ;   (   get(@emacs_buffers, member, Name, _)
241        ->  between(2, 1000000, N),
242            get(Name, append, string('<%d>', N), BufName),
243            \+ get(@emacs_buffers, member, BufName, _),
244            !
245        ;   BufName = Name
246        ),
247        send(B, slot, name, BufName),
248        (   OldName \== @nil,
249            get(@emacs_buffers, member, OldName, DictItem)
250        ->  send(DictItem, key, BufName)
251        ;   send(@emacs_buffers, append, dict_item(BufName, @default, B))
252        ),
253        send(B, update_label),
254        send(B?editors, for_some, message(@arg1?frame, label, BufName))
255    ).
256
257
258lookup(_Ctx, File:file*, Name:[name], Buffer:emacs_buffer) :<-
259    "Lookup in name and file-table"::
260    (   Name \== @default,
261        get(@emacs_buffers, member, Name, DictItem),
262        get(DictItem, object, Buffer)
263    ->  true
264    ;   File \== @nil,
265        get(@emacs_base_names, member, File?base_name, Chain),
266        get(Chain, find, message(@arg1?file, same, File), Buffer)
267    ;   File \== @nil,
268        send(File, exists),
269        send(File, check_object),
270        get(File, object, Buffer),
271        send(Buffer, instance_of, emacs_buffer),
272        get(Buffer, name, BufName),
273        send(Buffer, slot, name, ''),
274        send(Buffer, name, BufName),
275        send(Buffer, slot, file, File),
276        send(@emacs_base_names, append, File?base_name, Buffer),
277        send(Buffer, reset_undo),
278        send(Buffer, modified, @off),
279        send(Buffer, slot, time_stamp, File?time),
280        send(Buffer, loaded)
281    ).
282
283
284                 /*******************************
285                 *           LOAD/SAVE          *
286                 *******************************/
287
288file(B, File:file) :->
289    "Switch to indicated file"::
290    send(B, clear),
291    (   send(directory(File?name), exists)
292    ->  send(File, error, open_file, read, 'is a directory')
293    ;   send(File, exists)
294    ->  get(B, newline_existing_file, OpenMode),
295        send(File, newline_mode, OpenMode),
296        ignore(send(B, insert_file, 0, File)),
297        send(B, reset_undo),
298        send(B, modified, @off),
299        send(B, slot, time_stamp, File?time)
300    ;   send(B, reset_undo),
301        send(B, modified, @off),
302        get(B, newline_new_file, Mode),
303        send(File, newline_mode, Mode)
304    ),
305    send(B, slot, file, File),
306    new(F2, file(File?absolute_path)),
307    send(B, directory, F2?directory_name).
308
309
310save(B, File:[file]) :->
311    "->do_save and update time_stamp"::
312    (   File == @default
313    ->  get(B, file, SaveFile),
314        (   SaveFile == @nil
315        ->  send(B, report, error, 'No file associated to this buffer'),
316            fail
317        ;   true
318        )
319    ;   SaveFile = File,
320        (   get(B, file, OldFile), OldFile \== @nil
321        ->  send(@emacs_base_names, delete, OldFile?base_name, B)
322        ;   true
323        ),
324        send(File, absolute_path),
325        get(File, base_name, BaseName),
326        send(B, slot, file, File),
327        send(B, directory, File?directory_name),
328        send(B, name, BaseName),
329        send(@emacs_base_names, append, File?base_name, B)
330    ),
331    (   get(B, ensure_newline, @on)
332    ->  send(B, complete_last_line)
333    ;   true
334    ),
335    (   get(B, ensure_no_whitespace_errors, @on)
336    ->  send(B, fix_whitespace_errors)
337    ;   true
338    ),
339    (   no_backup(SaveFile)
340    ->  true
341    ;   ignore(send(SaveFile, backup))
342    ),
343    send(B, do_save, SaveFile),
344    send(B, slot, time_stamp, SaveFile?time),
345    (   object(@emacs_mark_list)
346    ->  ignore(send(@emacs_mark_list, saved_buffer, B))
347    ;   true
348    ).
349
350no_backup(File) :-
351    get(@emacs_no_backup_list, find,
352        message(@arg1, match, File?name), _).
353
354
355complete_last_line(B) :->
356    "Add \\n if needed"::
357    get(B, size, Size),
358    (   (   Size == 0
359        ;   get(B, character, Size-1, 10)
360        )
361    ->  true
362    ;   send(B, append, string('\n'))
363    ).
364
365fix_whitespace_errors(B) :->
366    "Remove trailing spaces and tabs from lines"::
367    new(Count, number(0)),
368    send(B, fix_trailing_space_errors, Count),
369    send(B, fix_space_tab_errors, Count),
370    (   get(Count, value, 0)
371    ->  true
372    ;   send(B, report, status,
373             'Fixed %d whitespace errors', Count)
374    ).
375
376fix_trailing_space_errors(B, Count:number) :->
377    "Remove trailing spaces and tabs from lines"::
378    new(Re, regex('[ \t]+\n')),
379    send(Re, for_all, B,
380         and(message(@arg1, replace, @arg2, '\n'),
381             message(Count, plus, 1))).
382
383fix_space_tab_errors(B, Count:number) :->
384    "Replace space+tab sequences"::
385    new(Re, regex(' +\t')),
386    send(Re, for_all, B,
387         and(message(B, fix_space_tab, Re),
388             message(Count, plus, 1))).
389
390fix_space_tab(B, Re:regex) :->
391    "Fix matched spaces followed by tab"::
392    (   get(B?editors, head, E)
393    ->  get(Re, register_start, 0, Start),
394        get(Re, register_end, 0, End),
395        get(E, column, Start, StartCol),
396        get(E, column, End, EndCol),
397        get(E, tab_distance, TD),
398        tabs(StartCol, EndCol, TD, Tabs),
399        tab_atom(Tabs, Atom),
400        send(Re, replace, B, Atom)
401    ;   true
402    ).
403
404tabs(SC, EC, _, 0) :-
405    SC >= EC,
406    !.
407tabs(SC, EC, TD, N) :-
408    SC2 is ((SC+TD)//TD)*TD,
409    tabs(SC2, EC, TD, N0),
410    N is N0+1.
411
412tab_atom(N, Atom) :-
413    length(List, N),
414    maplist(=(0'\t), List),
415    atom_codes(Atom, List).
416
417
418do_save(B, SaveFile:file, Start:[int], Length:[int]) :->
419    "Do the actual saving"::
420    get(B, unicode_encoding, FallBackEncoding),
421    (   pce_catch_error(io_error,
422                        send_super(B, save, SaveFile, Start, Length))
423    ->  true
424    ;   get(SaveFile, name, FileName),
425        \+ access_file(FileName, write)
426    ->  send(B, report, error, 'Cannot write %s (permission denied)', FileName),
427        fail
428    ;   get(SaveFile, encoding, Encoding),
429        Encoding \== FallBackEncoding
430    ->  send(SaveFile, encoding, FallBackEncoding),
431        send(SaveFile, bom, @on),
432        send_super(B, save, SaveFile, Start, Length),
433        once(user_encoding(FallBackEncoding, UserEnc)),
434        send(B, report, warning,
435             'Could not save using default locale; saved using %s', UserEnc)
436    ;   send_super(B, save, SaveFile, Start, Length)
437    ).
438
439user_encoding(utf8, 'UTF-8').
440user_encoding(unicode_le, 'UTF-16 (little endian)').
441user_encoding(unicode_be, 'UTF-16 (big endian)').
442user_encoding(Enc, Enc).
443
444
445write_region(B, File:file, Start:int, Length:int) :->
446    "Wrote region to file (start, length)"::
447    send(B, do_save, File, Start, Length).
448
449
450save_if_modified(B, Confirm:[bool]) :->
451    "Save if associated with a file and modified"::
452    (   get(B, modified, @on),
453        get(B, file, File), File \== @nil
454    ->  (   (   Confirm == @off
455            ;   send(@display, confirm,
456                     '%s is modified.  Save?', File?name)
457            )
458        ->  send(B, save)
459        ;   fail
460        )
461    ;   true
462    ).
463
464
465                 /*******************************
466                 *           AUTO-SAVE          *
467                 *******************************/
468
469check_auto_save(B) :->
470    "Check whether to auto_save"::
471    (   get(B, modified, @on),
472        get(B, auto_save_count, C),
473        send(C, minus, 1),
474        send(C, equal, 0),
475        get(B, auto_save_mode, @on)
476    ->  send(B, auto_save)
477    ;   true
478    ).
479
480
481auto_save_file(B, F:file) :<-
482    get(B, file, File), File \== @nil,
483    get(File, backup_file_name, '#', Name),
484    new(F, file(Name)).
485
486
487auto_save(B) :->
488    "Auto-save the buffer (when file)"::
489    (   get(B, auto_save_file, File)
490    ->  send(B, report, status, 'Auto saving ...'),
491        send(@display, flush),
492        ignore(send(B, send_super, save, File, 0, B?size)),
493        send(B?auto_save_count, value, 300),
494        send(B, report, status, 'Auto saving ... done')
495    ;   true
496    ).
497
498
499delete_auto_save_file(B) :->
500    "Delete the autosave-file if present"::
501    (   get(B, auto_save_file, File)
502    ->  ignore(send(File, remove))
503    ;   true
504    ).
505
506
507                 /*******************************
508                 *            KILL              *
509                 *******************************/
510
511kill(B) :->
512    "->save_if_modified and ->free"::
513    (   get(B, modified, @off)
514    ->  send(B, free)
515    ;   get(B, file, File), File \== @nil, \+ get(B, size, 0)
516    ->  new(D, dialog('Kill modified buffer?')),
517        send(D, append, new(L, label(reporter))),
518        send(L, format, 'Buffer %s is modified', B?name),
519        send(D, append,
520             button('save & kill', message(D, return, save_and_kill))),
521        send(D, append,
522             button(kill, message(D, return, kill))),
523        send(D, append,
524             button(cancel, message(D, return, cancel))),
525        get(D, confirm_centered, Rval),
526        send(D, destroy),
527        (   Rval == save_and_kill
528        ->  send(B, save),
529            send(B, free)
530        ;   Rval == kill
531        ->  send(B, free)
532        ;   fail
533        )
534    ;   send(B, free)
535    ).
536
537
538revert(B) :->
539    "Reload associated file"::
540    get(B, file, File),
541    (   File == @nil
542    ->  send(B, report, warning, 'No file'),
543        fail
544    ;   new(Carets, chain),
545        get(B, editors, Editors),
546        send(Editors, for_all, message(Carets, append, @arg1?caret)),
547        new(@emacs_reverting, object), % avoid trap
548        send(B, file, File),
549        send(Editors, for_all,
550             and(message(@arg1, caret, Carets?head),
551                 message(Carets, delete_head))),
552        (   get(Editors, head, First)
553        ->  send(First?mode, auto_colourise_buffer)
554        ;   true
555        ),
556        free(@emacs_reverting),
557        send(B, report, status, 'Reloaded %s', File?absolute_path)
558    ).
559
560
561                 /*******************************
562                 *          NAME/LABEL          *
563                 *******************************/
564
565update_label(B) :->
566    "Update label in the buffer-menu"::
567    get(B, name, Name),
568    (   Name \== @nil
569    ->  get(@emacs_buffers, member, Name, DictItem),
570        (   get(B, modified, @on)
571        ->  send(DictItem, label, string('%s\t**', Name)),
572            new(EditorLabel, string('%s [modified]', Name))
573        ;   send(DictItem, label, Name),
574            EditorLabel = Name
575        ),
576        send(B?editors, for_all,
577             message(@arg1, label, EditorLabel))
578    ;   true
579    ).
580
581
582                 /*******************************
583                 *            MARGINS           *
584                 *******************************/
585
586margin_width(B, W:'0..') :->
587    "Set width of the margin for associated editors"::
588    send(B, slot, margin_width, W),
589    send(B?editors, for_all,
590         message(@arg1, margin_width, W)).
591
592
593                 /*******************************
594                 *           MODIFIED           *
595                 *******************************/
596
597modified(B, Val:bool) :->
598    "Check the file; mark buffer-menu"::
599    send_super(B, modified, Val),
600    (   Val == @on
601    ->  send(B, check_modified_file)
602    ;   send(B, delete_auto_save_file)
603    ),
604    send(B, update_label).
605
606
607check_modified_file(B, Frame:frame=[frame], Confirm:confirm=[bool]) :->
608    "Check if file has been modified after buffer"::
609    (   get(B, file, File),
610        File \== @nil,
611        send(File, exists),
612        get(B, time_stamp, Stamp),
613        get(File, time, FileStamp),
614        \+ send(Stamp, equal, FileStamp),
615        \+ object(@emacs_reverting)
616    ->  (   confirm_reload(B, Frame, Confirm, File)
617        ->  send(B, revert)
618        ;   true
619        )
620    ;   true
621    ).
622
623confirm_reload(_, _, @off, _) :- !.
624confirm_reload(B, _, @default, _) :-
625    get(B, prompt_reload, @off),
626    !,
627    send(B, saved_caret, 0),
628    send(B?editors, for_all, message(@arg1, caret, 0)).
629confirm_reload(_, Frame, _, File) :-
630    new(D, dialog('Modified file')),
631    send(D, append,
632         label(title,  string('File %N was modified', File))),
633    send(D, append,
634         button(reload_file, message(D, return, reload_file))),
635    send(D, append,
636         button(edit_buffer, message(D, return, edit_buffer))),
637    (   Frame \== @default
638    ->  EmacsFrame = Frame
639    ;   get(@emacs, current_frame, EmacsFrame)
640    ->  true
641    ;   EmacsFrame = @nil
642    ),
643    (   EmacsFrame \== @default
644    ->  get(EmacsFrame?area, center, Position),
645        send(D, transient_for, EmacsFrame)
646    ;   Position = @default
647    ),
648    get(D, confirm_centered, Position, RVal),
649    send(D, destroy),
650    RVal == reload_file.
651
652
653                 /*******************************
654                 *          OPEN WINDOW         *
655                 *******************************/
656
657open(B, How:[{here,tab,window}], Frame:emacs_frame) :<-
658    "Create window for buffer"::
659    (   How == window
660    ->  send(new(Frame, emacs_frame(B)), open)
661    ;   How == tab,
662        get(@emacs, current_frame, Frame)
663    ->  send(Frame, tab, B, @on),
664        send(Frame, expose)
665    ;   get(@emacs, current_frame, Frame)
666    ->  send(Frame, buffer, B),
667        send(Frame, expose)
668    ;   send(new(Frame, emacs_frame(B)), open)
669    ),
670    send(B, check_modified_file, Frame).
671
672open(B, How:[{here,tab,window}]) :->
673    "Create window for buffer"::
674    get(B, open, How, _).
675
676
677                 /*******************************
678                 *            MODE              *
679                 *******************************/
680
681mode(B, Mode:name) :->
682    "Switch to named mode"::
683    (   get(B, mode, Mode)
684    ->  true
685    ;   send(B, slot, mode, Mode),
686        send(B, init_mode_defaults),
687        send(B?editors, for_some, message(@arg1, mode, Mode))
688    ).
689
690init_mode_defaults(B) :->
691    "Initialise defaults from the current mode"::
692    get(B, mode, ModeName),
693    atomic_list_concat([emacs_, ModeName, '_mode'], ClassName),
694    get(@pce, convert, ClassName, class, ModeClass),
695    (   copy_class_var(Name),
696        get(ModeClass, class_variable, Name, CV),
697        get(CV, value, Value),
698        send(B, Name, Value),
699        fail
700    ;   true
701    ).
702
703copy_class_var(indent_tabs).
704copy_class_var(tab_width).
705
706
707                 /*******************************
708                 *       LANGUAGE SUPPORT       *
709                 *******************************/
710
711%       emacs_buffer<-name_and_arity returns the name and arity if the
712%       caret is in the functor of the term.  If the arity cannot be
713%       determined, arity is returned as @default.
714
715name_and_arity(TB, Pos:int, Tuple:tuple) :<-
716    "Find name and arity of term at position"::
717    (   get(TB, character, Pos, C0)
718    ;   get(TB, character, Pos-1, C0)
719    ),
720    send(TB?syntax, has_syntax, C0, word),
721    !,
722    get(TB, scan, Pos, word, 0, start, P1),
723    get(TB, scan, P1, word, 0, end, P2),
724    get(TB, contents, P1, P2-P1, NameString),
725    (   get(TB, character, P2, 0'()
726    ->  P4 is P2 + 1,
727        (   count_args(TB, P4, 0, 0, Arity)
728        ->  true
729        ;   Arity = @default
730        )
731    ;   Arity = 0
732    ),
733    new(Tuple, tuple(NameString?value, Arity)).
734
735
736count_args(TB, Here, _, _, _) :-
737    get(TB, size, Here),
738    !,
739    fail.
740count_args(_TB, _Here, 20, _, _) :-
741    !,
742    fail.
743count_args(TB, Here, NAT, A0, A) :-
744    get(TB, scan, Here, term, 1, EndTerm),
745    get(TB, skip_comment, EndTerm, Next),
746    (   get(TB, character, Next, 0'))
747    ->  A is A0 + 1
748    ;   get(TB, character, Next, 0',)
749    ->  A1 is A0 + 1,
750        count_args(TB, EndTerm, 0, A1, A)
751    ;   NNAT is NAT + 1,
752        count_args(TB, EndTerm, NNAT, A0, A)
753    ).
754
755:- pce_end_class.
756
757
758