├── .gitignore ├── Emacs.apl ├── README.md ├── dyalog-mode.el └── melpa_recipe.txt /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc -------------------------------------------------------------------------------- /Emacs.apl: -------------------------------------------------------------------------------- 1 | :Namespace Emacs 2 | transtable←0 8 10 13 32 12 6 7 27 9 9014 14 37 39 9082 9077 95 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 1 2 175 46 9068 48 49 50 51 52 53 54 55 56 57 3 8866 165 36 163 162 8710 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 4 5 253 183 127 9049 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 123 8364 125 8867 9015 168 192 196 197 198 9064 201 209 214 216 220 223 224 225 226 228 229 230 231 232 233 234 235 237 238 239 241 91 47 9023 92 9024 60 8804 61 8805 62 8800 8744 8743 45 43 247 215 63 8714 9076 126 8593 8595 9075 9675 42 8968 8970 8711 8728 40 8834 8835 8745 8746 8869 8868 124 59 44 9073 9074 9042 9035 9033 9021 8854 9055 9017 33 9045 9038 9067 9066 8801 8802 243 244 246 248 34 35 30 38 8217 9496 9488 9484 9492 9532 9472 9500 9508 9524 9516 9474 64 249 250 251 94 252 96 166 182 58 9079 191 161 8900 8592 8594 9053 41 93 31 160 167 9109 9054 9059 3 | :Namespace editor 4 | eomraw←27 5 | eom←⎕UCS eomraw 6 | null←⎕UCS 0 7 | nl←⎕UCS 10 8 | recvbuf←⍬ 9 | state←'ready' 10 | saltdelim←⎕UCS 253⊃##.transtable 11 | ⍝ onMissing contains the name of a function to call when the name that 12 | ⍝ is being edited doesn't exist. It recives the name being edited as 13 | ⍝ right argument and is expected to establish the name in the session. 14 | onMissing←'' 15 | ⍝ getPath contains the name of a function to call to get the path to 16 | ⍝ the source of a given name. It receives a name as right argument and 17 | ⍝ is expected to return the path to the source file the function is 18 | ⍝ defined in. If the path is unknown, getPath should return ''. 19 | getPath←'' 20 | ⍝ If boxing is 1, display of nested arrays in the editor is 21 | ⍝ automatically done with boxed values, similar to the DISPLAY 22 | ⍝ function. 23 | boxing←0 24 | ⍝ afterFix contains the name of a function to call after fixing a 25 | ⍝ function, namespace or class. It receives the result of the fix, 26 | ⍝ i.e. either the name that was fixed or the line number of an error 27 | ⍝ that prevented fixing. 28 | afterFix←'' 29 | 30 | ∇ init 31 | ⎕CY'display' 32 | disp←DISPLAY 33 | ⎕EX'DISPLAY' 34 | ∇ 35 | 36 | ∇ {r}←edit rarg;name;lineno;_;src;path;shortname 37 | 38 | :If 1=≡rarg 39 | rarg←,⊂rarg 40 | :EndIf 41 | 42 | name lineno←2↑rarg,¯1 43 | ⍝ Remove explicit reference to root, if any 44 | name←(2×'#.'≡2↑name)↓name 45 | 46 | :If 0=⊃#.⎕NC name 47 | ⍝ Trigger loading of code if the name isn't established in the 48 | ⍝ session 49 | _←getsource name 50 | :EndIf 51 | 52 | :Select ⊃#.⎕NC name ⍝ check again because it might have loaded now 53 | :CaseList 3 4 9 54 | src path←getsource name 55 | editfun name lineno src path 56 | :Case 2 57 | editarray name lineno 58 | :Case 0 59 | ⍝ Editing a name that doesn't exist, open an empty function 60 | shortname←purename name 61 | src←' ',shortname,nl 62 | path←getpath shortname 63 | editfun name 1 src path 64 | :EndSelect 65 | ∇ 66 | 67 | ∇ {r}←editfun rarg;name;lineno;src;path;linespec;msg 68 | name lineno src path←rarg 69 | linespec←(⎕IO+¯1=lineno)⊃('[',(⍕lineno),']')'' 70 | msg←'edit ',name,linespec,null,path,null,src 71 | r←send #.⎕SE.Emacs∆socket(msg,eom) 72 | ∇ 73 | 74 | ∇ {r}←editarray rarg;name;lineno;type;value;msg 75 | name lineno←rarg 76 | type value←getvalue name 77 | msg←'editarray ',name,' ',type,' ',value 78 | r←send #.⎕SE.Emacs∆socket(msg,eom) 79 | ∇ 80 | 81 | ∇ setupmenu shortcut;title;acc 82 | title acc←2↑shortcut,'Ctrl+Alt+Enter'(13 6) 83 | '⎕SE.popup.emacs'⎕WC'MenuItem'('Caption'('Edit in Emacs',⎕AV[10],title)) 84 | '⎕SE.popup.emacs'⎕WS'Event' 'Select' '#.Emacs.editor.sessionedit' 85 | '⎕SE.popup.emacs'⎕WS'Accelerator'acc 86 | ∇ 87 | 88 | ∇ {msg}←sessionedit msg;name;pos;log;focus;line;aftercursor;symbolalphabet;lineno;si 89 | name pos log←'⎕SE'⎕WG'CurObj' 'CurPos' 'Log' 90 | focus←2 ⎕NQ'.' 'GetFocus' 91 | 92 | :If '⎕SE'≡focus 93 | :If 0∊⍴name 94 | :AndIf 1<⍴si←⎕SI 95 | ⍝ We pressed edit on whitespace while suspended in the debugger, edit the 96 | ⍝ suspended function 97 | name←⊃1↓⎕SI 98 | lineno←¯1 99 | :Else 100 | ⍝ Below line is actually broken since symbols can contain 101 | ⍝ diacritics, but I'm lazy 102 | symbolalphabet←⎕A,⎕D,'abcdefghijklmnopqrstuvwxyz_∆' 103 | line←(⊃pos)⊃log 104 | aftercursor←(⎕IO⌈¯1+1↓pos)↓line 105 | 106 | :If 0∊⍴name 107 | ⍝ If we invoke edit while the cursor is before the first character of 108 | ⍝ a symbol, CurObj is '', but Dyalog invokes the editor on the symbol. 109 | ⍝ So for backwards compatability, we try to emulate this behaviour. 110 | name←symbolalphabet↑##.slurp aftercursor 111 | :EndIf 112 | 113 | lineno←{'['≠⊃⍵:¯1 ⋄ 1+⊃2⊃⎕VFI ⎕D↑##.slurp 1↓⍵}symbolalphabet↓##.slurp aftercursor 114 | :EndIf 115 | :Else 116 | ⍝ Inside the editor we can't get the full text around the 117 | ⍝ cursor (including any line number within brackets), so we just 118 | ⍝ use the default line number 119 | lineno←¯1 120 | :EndIf 121 | 122 | edit name lineno 123 | ∇ 124 | 125 | ∇ {r}←connect;socket;host;port;lispconnect;elisp;_ 126 | ⍝ Start listening, and have Emacs connect back to us. 127 | socket←listen ⍬ 128 | host port←socket ⎕WG'LocalAddr' 'LocalPort' 129 | lispconnect←'(dyalog-editor-connect \"',host,'\" ',(⍕port),')' 130 | 131 | :If 0∊⍴r←⎕SH'emacsclient --no-wait -e "',lispconnect,'"' 132 | ⍝ Emacs server not running, start Emacs in background 133 | ⎕←'Emacs server not running, starting a new instance...' 134 | elisp←'(progn ',lispconnect,'(iconify-frame nil))' 135 | r←'' 136 | :If ##.isunix 137 | _←⎕SH'emacs --eval "',elisp,'" &' 138 | :Else 139 | ⎕CMD('runemacs --eval "',elisp,'"')'' 140 | :EndIf 141 | :EndIf 142 | ∇ 143 | 144 | ∇ {r}←listen port;sockname;callbacks;_ 145 | init 146 | sockname←'⎕SE.Emacs_socket',⍕port 147 | callbacks←⊂('Event' 'TCPAccept' '#.Emacs.editor.accept') 148 | callbacks,←⊂('Event' 'TCPRecv' '#.Emacs.editor.receive') 149 | callbacks,←⊂('Event' 'TCPError' '#.Emacs.editor.error') 150 | callbacks,←⊂('Event' 'TCPClose' '#.Emacs.editor.close') 151 | sockname ⎕WC'TCPSocket' '127.0.0.1 '(port)('Style' 'Raw'),callbacks 152 | r←sockname 153 | #.⎕SE.Emacs∆socket←sockname 154 | ∇ 155 | 156 | ∇ {r}←accept msg;socket;newname 157 | socket←1⊃msg 158 | newname←socket,⍕?¯2+2*31 159 | newname ⎕WC'TCPSocket'('SocketNumber'(3⊃msg))('Event'(socket ⎕WG'Event')) 160 | sendgreeting socket 161 | r←newname 162 | ∇ 163 | 164 | ∇ {r}←send args;socket;text;raw 165 | socket text←args 166 | raw←##.text2bytes text 167 | r←2 ⎕NQ socket'TCPSend'raw 168 | ∇ 169 | 170 | ∇ {r}←receive msg;socket;raw;ip;uni;data;i;command;src;name;marker;complete 171 | 172 | socket raw ip←msg[1 3 4] 173 | 174 | :If ip≢'127.0.0.1' 175 | :Return 176 | :EndIf 177 | 178 | marker←raw⍳eomraw 179 | complete←marker≤⊃⍴raw 180 | 181 | :Select state 182 | :Case 'ready' 183 | i←raw⍳'UTF-8'⎕UCS' ' 184 | command←'UTF-8'⎕UCS raw[⍳i-1] 185 | 186 | :Select command 187 | :Case 'fx' 188 | :If complete 189 | fix socket(i↓raw)(marker-i) 190 | recvbuf←⍬ 191 | :Else 192 | recvbuf,←i↓raw 193 | state←'fx' 194 | :EndIf 195 | :Case 'src' 196 | :If complete 197 | sendsource socket(i↓raw)(marker-i) 198 | recvbuf←⍬ 199 | :Else 200 | recvbuf,←i↓raw 201 | state←'src' 202 | :EndIf 203 | :Case 'focus' 204 | :If complete 205 | focus 206 | recvbuf←⍬ 207 | :Else 208 | recvbuf,←i↓raw 209 | state←'focus' 210 | :EndIf 211 | :Else 212 | ⎕←'Received invalid command: ',command 213 | :EndSelect 214 | 215 | :Case 'fx' 216 | :If complete 217 | fix socket raw marker 218 | state←'ready' 219 | recvbuf←⍬ 220 | :Else 221 | recvbuf,←raw 222 | :EndIf 223 | 224 | :Case 'src' 225 | :If complete 226 | sendsource socket(i↓raw)(marker-i) 227 | recvbuf←⍬ 228 | :Else 229 | recvbuf,←i↓raw 230 | :EndIf 231 | :Case 'focus' 232 | :If complete 233 | focus 234 | recvbuf←⍬ 235 | :Else 236 | recvbuf,←i↓raw 237 | :EndIf 238 | :EndSelect 239 | ∇ 240 | 241 | ∇ {r}←fix args;socket;raw;marker;src;header;hasKeyword 242 | socket raw marker←args 243 | src←##.bytes2text recvbuf,raw[⍳marker-1] 244 | header←↑##.splitlines ##.tolower src[⍳512⌊⊃⍴src] 245 | hasKeyword←{ 246 | instring←{⍵∨≠\⍵}⍺='''' 247 | incomment←(~instring)∧∨\⍺='⍝' 248 | ∨/∨/(~incomment∨instring)∧⍵⍷⍺ 249 | } 250 | 251 | :If header hasKeyword':class' 252 | :OrIf header hasKeyword':namespace' 253 | r←#.⎕FIX ##.splitlines src 254 | :Else 255 | r←#.⎕FX↑##.splitlines src 256 | :EndIf 257 | :If 3=⎕NC'#.',afterFix 258 | (#.⍎'#.',afterFix)r 259 | :EndIf 260 | send socket('fxresult ',(,⍕r),eom) 261 | ∇ 262 | 263 | ∇ {r}←sendsource args;socket;raw;marker;fullname;name;lineno 264 | socket raw marker←args 265 | fullname←##.bytes2text recvbuf,raw[⍳marker-1] 266 | name lineno←parsename fullname 267 | edit name lineno 268 | ∇ 269 | 270 | ∇ {r}←focus;_;ShowWindow;GetWindowThreadProcessId;GetForegroundWindow;GetCurrentThreadId;tid1;tid2;SW_SHOWNORMAL;handle;AttachThreadInput;BringWindowToTop 271 | :If ~##.isunix 272 | ⎕NA'I user32|ShowWindow I I' 273 | ⎕NA'I user32|GetWindowThreadProcessId I I' 274 | ⎕NA'I kernel32|GetCurrentThreadId' 275 | ⎕NA'I user32|GetForegroundWindow' 276 | ⎕NA'I user32|AttachThreadInput I I I' 277 | ⎕NA'I user32|BringWindowToTop I' 278 | tid1←GetWindowThreadProcessId GetForegroundWindow 0 279 | tid2←GetCurrentThreadId 280 | SW_SHOWNORMAL←1 281 | handle←'⎕SE'⎕WG'Handle' 282 | :If tid1≠tid2 283 | _←AttachThreadInput tid1 tid2 1 284 | _←BringWindowToTop handle 285 | _←ShowWindow handle SW_SHOWNORMAL 286 | _←AttachThreadInput tid1 tid2 0 287 | :Else 288 | _←BringWindowToTop handle 289 | _←ShowWindow handle SW_SHOWNORMAL 290 | :EndIf 291 | ⎕NQ'⎕SE' 'GotFocus' 292 | :EndIf 293 | ∇ 294 | 295 | ∇ {r}←sendgreeting socket;version;wsid;cwd;body;ride;tagged 296 | version←2⊃'.'⎕WG'AplVersion' 297 | wsid←⎕WSID 298 | cwd←##.getcurrentdir 299 | ride←2 ⎕NQ'.' 'GetEnvironment' 'RIDE_INIT' 300 | tagged←'version' 'wsid' 'dir' 'ride'{⍺,': ',,⍕⍵}¨version wsid cwd ride 301 | body←nl ##.joinlines tagged 302 | send socket('dyaloghello ',nl,body,nl,eom) 303 | ∇ 304 | 305 | ∇ {r}←close msg 306 | ⎕EX 1⊃msg 307 | r←1 308 | ∇ 309 | 310 | ∇ {r}←error msg 311 | ∘ 312 | ∇ 313 | 314 | ∇ path←getpath name;saltpath;dyapath 315 | :If ~0∊⍴saltpath←getSALTpath name 316 | path←saltpath 317 | :ElseIf ~0∊⍴dyapath←getSourcePath name 318 | path←dyapath 319 | :ElseIf 3=⎕NC'#.',getPath 320 | path←(#.⍎'#.',getPath)name 321 | :Else 322 | path←'' 323 | :EndIf 324 | ∇ 325 | 326 | ∇ path←getSourcePath name;version;sourceMap;absName;b;relName;namePath 327 | version←{⊃2⊃⎕VFI(∧\⍵≠'.')/⍵}2⊃'.'⎕WG'AplVersion' 328 | :If version<16 329 | path←'' 330 | :Return 331 | :EndIf 332 | 333 | absName←name,⍨('#.'≢2↑name)/'#.' 334 | b←{⌽∧\⍵≠'.'}⌽absName 335 | namePath←{(¯1×'.'=⊃⌽⍵)↓⍵}(~b)/absName 336 | relName←((9=#.⎕NC absName)/'#.'),b/absName 337 | sourceMap←↑5177⌶⍬ 338 | sourceMap[;1 2]←⍕¨sourceMap[;1 2] 339 | b←(↓sourceMap[;1 2])∊⊂relName namePath 340 | :If ∨/b 341 | path←⊃b/sourceMap[;4] 342 | :Else 343 | path←'' 344 | :EndIf 345 | ∇ 346 | 347 | ∇ path←getSALTpath name;src;tagline 348 | 349 | :If 0≠#.⎕NC name,'.SALT_Data.SourceFile' 350 | path←#.⍎name,'.SALT_Data.SourceFile' 351 | :ElseIf 3 4∊⍨#.⎕NC name 352 | src←##.leftalign #.⎕CR name 353 | tagline←⊃##.cm2v(src ##.startswith'⍝∇⍣')⌿src 354 | path←{(∧\⍵≠saltdelim)/⍵}(1+⍴'⍝∇⍣')↓tagline 355 | :Else 356 | path←'' 357 | :EndIf 358 | ∇ 359 | 360 | ∇ r←purename fullname 361 | r←(∧\fullname≠'[')/fullname 362 | ∇ 363 | 364 | ∇ r←{noload}getsource fullname;name;src;path;_ 365 | :If 0=⎕NC'noload' 366 | noload←0 367 | :EndIf 368 | 369 | name←purename fullname 370 | 371 | :Select ⊃#.⎕NC name 372 | :Case 0 373 | :If 3≠⎕NC'#.',onMissing 374 | :OrIf noload 375 | src←path←'' 376 | :Else 377 | (#.⍎'#.',onMissing)name 378 | src path←1 getsource name 379 | :EndIf 380 | :CaseList 3 4 381 | src←##.joinlines ##.cm2v #.⎕CR name 382 | path←getpath name 383 | :Case 9 384 | src←##.joinlines #.⎕SRC(#.⍎name) 385 | path←getpath name 386 | :Else 387 | src←path←'' 388 | :EndSelect 389 | 390 | r←src path 391 | ∇ 392 | 393 | ∇ r←getvalue name;type;value;src 394 | value←#.⍎name 395 | :If 1=≡value 396 | :AndIf ''≡0⍴value 397 | type←⊃'charvec' 'charmat' 'array'[1 2⍳⍴⍴value] 398 | :ElseIf 1=⍴⍴value 399 | :AndIf 326=⎕DR value 400 | dr←{ 401 | 11::⊃⎕NC'⍵' ⍝ use ⎕NC if DOMAIN ERROR 402 | ⎕DR ⍵ 403 | }¨value 404 | 405 | :If ∧/dr∊80 82 160 320 406 | type←'stringvec' 407 | :Else 408 | type←'array' 409 | :EndIf 410 | :Else 411 | type←'array' 412 | :EndIf 413 | 414 | :Select type 415 | :Case 'stringvec' 416 | src←##.joinlines value 417 | :Case 'charvec' 418 | src←value 419 | :Case 'charmat' 420 | src←##.joinlines ##.cm2v value 421 | :Else 422 | :If boxing 423 | value←1 disp value 424 | :Else 425 | value←⍕value 426 | :EndIf 427 | src←##.joinlines ##.cm2v value 428 | :EndSelect 429 | 430 | r←type src 431 | ∇ 432 | 433 | ∇ r←parsename fullname;name;linespec;line 434 | name←(+/∧\fullname≠'[')↑fullname 435 | linespec←(∨\fullname='[')/fullname 436 | line←1+⊃2⊃⎕VFI ⎕D↑##.slurp 1↓linespec 437 | r←name line 438 | ∇ 439 | :EndNamespace 440 | 441 | :Namespace session 442 | cr←⎕UCS 13 443 | lf←⎕UCS 10 444 | 445 | ∇ {r}←listen port;sockname;callbacks;_ 446 | sockname←'⎕SE.Emacs_socket',⍕port 447 | callbacks←⊂('Event' 'TCPAccept' '#.Emacs.session.accept') 448 | callbacks,←⊂('Event' 'TCPRecv' '#.Emacs.session.receive') 449 | callbacks,←⊂('Event' 'TCPError' '#.Emacs.session.error') 450 | callbacks,←⊂('Event' 'TCPClose' '#.Emacs.session.close') 451 | sockname ⎕WC'TCPSocket' ''(port)('Style' 'Raw'),callbacks 452 | r←sockname 453 | ∇ 454 | 455 | ∇ {r}←accept msg;socket;newname 456 | socket←1⊃msg 457 | newname←socket,⍕?¯2+2*31 458 | newname ⎕WC'TCPSocket'('SocketNumber'(3⊃msg))('Event'(socket ⎕WG'Event')) 459 | r←newname 460 | send socket(6⍴' ') 461 | ∇ 462 | 463 | ∇ {r}←send args;socket;text;raw 464 | socket text←args 465 | raw←##.text2bytes text 466 | r←2 ⎕NQ socket'TCPSend'raw 467 | ∇ 468 | 469 | ∇ {r}←receive msg;socket;raw;ip;data;z;prompt;dm;err;stack;cursor;m;n;len;logbefore;logafter;match 470 | 471 | socket raw ip←msg[1 3 4] 472 | 473 | :If ip≢'127.0.0.1' 474 | :Return 475 | :EndIf 476 | 477 | data←##.bytes2text raw 478 | prompt←6⍴' ' 479 | data←(-+/(¯2↑data)∊cr lf)↓data 480 | 481 | :If data∧.=' ' ⍝ An empty input line 482 | :OrIf ∧/(data=' ')∨∨\data='⍝' ⍝ A comment 483 | send socket prompt 484 | :Return 485 | :EndIf 486 | 487 | :Trap 0 488 | m←⊃⍴logbefore←'#.⎕SE'⎕WG'Log' 489 | :If 3=#.⎕NC data 490 | :AndIf 0=1⊃1⊃#.⎕AT data 491 | #.⍎data 492 | z←0 0⍴'' 493 | :ElseIf ∨/'⎕WC'⍷data 494 | :OrIf ∨/'⎕WS'⍷data 495 | #.⍎data 496 | z←0 0⍴'' 497 | :Else 498 | z←#.⍎data 499 | :EndIf 500 | n←⊃⍴logafter←'#.⎕SE'⎕WG'Log' 501 | 502 | :If 3=⎕NC'z' 503 | r←' ∇',data 504 | :Else 505 | r←⎕FMT z 506 | :EndIf 507 | 508 | :If logbefore≢logafter ⍝ Log changed, must be due to output to session 509 | :If n≠m 510 | len←|n-m 511 | :Else 512 | match←(¯1×''≡⊃⌽logbefore)↓(-11⌊n)↑logbefore 513 | len←(+/∨\⌽<\⌽match⍷logafter)-(⊃⍴match)+''≡⊃⌽logafter 514 | :EndIf 515 | r←↑(logafter[(n-len)+¯1+⍳len]),##.cm2v r 516 | :EndIf 517 | 518 | :If '←'∊data ⍝ TODO: Better test for assignment 519 | send socket prompt 520 | :Else 521 | send socket((,(r,cr),lf),prompt) 522 | :EndIf 523 | :Else 524 | dm←⎕DM 525 | err←(('⍎'=⊃⊃dm)∧~'⍎'∊data)↓1⊃dm 526 | cursor←3⊃dm 527 | :If 'receive[25] '≡12↑stack←2⊃dm 528 | stack←prompt,12↓stack 529 | cursor←6↓cursor 530 | :EndIf 531 | send socket(##.joinlines err stack cursor prompt) 532 | :EndTrap 533 | ∇ 534 | 535 | ∇ {r}←close msg 536 | ⎕EX 1⊃msg 537 | r←1 538 | ∇ 539 | 540 | ∇ {r}←error msg 541 | ∘ 542 | ∇ 543 | :EndNamespace 544 | 545 | listen←{ 546 | sessionport editorport←2↑⍵,7979 8080 547 | a←session.listen sessionport 548 | a,editor.listen editorport 549 | } 550 | 551 | join←{ 552 | 0=⍴,⍵:⍵ 553 | (-⍴,⍺)↓⊃,/⍵,¨⊂⍺ 554 | } 555 | 556 | split←{ 557 | p←⊃1↑⍵ 558 | 1↓¨(1,⍺)⊂p,⍵ 559 | } 560 | 561 | splitlines←{ 562 | s←⍵~⎕UCS 13 563 | (s∊⎕UCS 10)split s 564 | } 565 | 566 | joinlines←{ 567 | (⎕UCS 13 10)join ⍵ 568 | } 569 | 570 | cm2v←{(+/∨\' '≠⌽⍵)↑¨↓⍵} 571 | 572 | tolower←{ 573 | s←⍵ 574 | i←⎕A⍳s 575 | hits←i≤⊃⍴⎕A 576 | s[hits/⍳⍴s]←'abcdefghijklmnopqrstuvwxyz'[hits/i] 577 | s 578 | } 579 | 580 | text2bytes←{ 581 | ⎕AVU←transtable 582 | 'UTF-8'⎕UCS ⍵ 583 | } 584 | 585 | bytes2text←{ 586 | ⎕AVU←transtable 587 | 'UTF-8'⎕UCS ⍵ 588 | } 589 | 590 | slurp←{(+/∧\⍵∊⍺)⍺⍺ ⍵} 591 | 592 | leftalign←{(+/∧\⍵=' ')⌽⍵} 593 | 594 | startswith←{ 595 | s←,⍵ 596 | 2=⍴⍴⍺:(((1↑⍴⍺),⍴s)↑⍺)∧.=s 597 | s≡(⍴s)↑⍺ 598 | } 599 | 600 | ∇ r←getcurrentdir 601 | :If isunix 602 | r←⊃⎕SH'pwd' 603 | :Else 604 | ⍝ The chcp works around a Dyalog bug that incorrectly decodes 605 | ⍝ strings from ⎕CMD if they aren't in Windows 1252. E.g. the default 606 | ⍝ encoding for cmd on Swedish windows is CP850. 607 | r←⊃⌽⎕CMD'chcp 1252 && cd' 608 | :EndIf 609 | ∇ 610 | 611 | ∇ r←isunix 612 | r←'W'≠⊃3⊃'.'⎕WG'AplVersion' 613 | ∇ 614 | 615 | :EndNamespace -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Dyalog mode 2 | =========== 3 | 4 | Dyalog-mode is a GNU Emacs major mode for editing Dyalog APL source code. It 5 | integrates with the Dyalog IDE so you can use Emacs instead of the built in 6 | Dyalog editor. 7 | 8 | Features 9 | -------- 10 | 11 | Dyalog mode supports syntax highlighting (including correct highlighting of 12 | localized variables), indentation and convenience functions like toggling 13 | localization of variables. 14 | 15 | Supported platforms 16 | ------------------- 17 | Dyalog requires Emacs 24, but for full functionality, you should 18 | use Emacs 24.3 or newer. 19 | 20 | Dyalog mode itself works on all platforms supported by Emacs, but the 21 | integration with the Dyalog session requires functionality only present in the 22 | GUI version of the Dyalog IDE, so that part only works on Windows. However, 23 | you can still connect Emacs and Dyalog when running on Linux, you just have to 24 | manually invoke editing in Emacs by calling `Emacs.editor.edit 'funcname'`. 25 | 26 | Installation 27 | ------------ 28 | 29 | ### From MELPA ### 30 | 31 | Since version 24.1, Emacs includes a package management system. Using the 32 | [MELPA](http://melpa.org) package repository is the easiest way to install and 33 | update Dyalog mode. 34 | 35 | If you have installed packages from Melpa before, all you have to do is: 36 | 37 | `M-x package-install RET dyalog-mode RET` 38 | 39 | If you haven't used Melpa before, then you have to configure `package.el` 40 | first. Add the following to your 41 | [init file](http://www.gnu.org/software/emacs/manual/html_node/emacs/Init-File.html) 42 | 43 | ```lisp 44 | (require 'package) 45 | (add-to-list 'package-archives 46 | '("melpa" . "http://melpa.org/packages/") t) 47 | ``` 48 | 49 | Restart Emacs and update the package cache by running: 50 | 51 | `M-x package-refresh-contents RET` 52 | 53 | You can now install Dyalog mode by running `M-x package-install`, as above. 54 | 55 | #### Installing in older versions of Emacs #### 56 | 57 | If you have an older version of Emacs, please follow the 58 | [instruction from MELPA](http://melpa.org/#/getting-started). 59 | 60 | ### Installing manually 61 | 62 | To install manually, clone the 63 | [git repository](https://github.com/harsman/dyalog-mode.git) and add the 64 | following to your init file: 65 | 66 | ```lisp 67 | (autoload 'dyalog-mode "/path/to/dyalog-mode.el" "Edit Dyalog APL" t) 68 | (autoload 'dyalog-editor-connect "/path/to/dyalog-mode.el" "Connect Emacs to Dyalog" t) 69 | (add-to-list 'auto-mode-alist '("\\.apl\\'" . dyalog-mode)) 70 | (add-to-list 'auto-mode-alist '("\\.dyalog$" . dyalog-mode)) 71 | ``` 72 | 73 | #### Dependencies #### 74 | 75 | If you install with `package.el` then dependencies are automatically 76 | installed. If you install manually, you have to install dependencies manually 77 | as well. 78 | 79 | * `cl-lib` is installed by default in Emacs 24.3 and newer. It provides 80 | various Common Lisp forms, but unlike the older `cl` library, it doesn't 81 | pollute the global namespace. If you have an older Emacs version, without 82 | `cl-lib`, you can install it from the [GNU ELPA](http://elpa.gnu.org/) 83 | repository by using `package.el` (by doing `M-x package-install RET cl-lib 84 | RET`), or you can get it manually 85 | [here](http://elpa.gnu.org/packages/cl-lib.html). 86 | 87 | Getting started 88 | --------------- 89 | 90 | To get started, just open any text file with APL source code and a .dyalog 91 | extension in Emacs. 92 | 93 | You can also use Emacs as the editor inside a Dyalog APL session. First you 94 | need to load the code for this into Dyalog. Issue the following commands at 95 | the Dyalog prompt: 96 | 97 | ```apl 98 | ]load /path/to/dyalog-mode/Emacs.apl 99 | Emacs.editor.setupmenu ⍬ 100 | Emacs.editor.connect 101 | ``` 102 | 103 | This will first try to connect to a running Emacs instance, and if one isn't 104 | available, start Emacs and connect to it from the Dyalog session. The call to 105 | `setupmenu` will add a shortcut to the session's context menu, called "Edit in 106 | Emacs" with the keyboard shortcut `Ctrl+Alt+Enter`. 107 | 108 | To edit a function, class or namespace in Emacs, just place the cursor on a 109 | name in the Dyalog session or editor and press `Ctrl+Alt+Enter`. Once you are 110 | happy with your changes, press `C-c C-c` in Emacs to fix the changes back in 111 | the Dyalog session. While you are editing in Emacs, you can press `C-c C-e` to 112 | edit the name at point. You can also open arrays in Emacs, although currently 113 | no arrays are editable, i.e. they are all read-only. 114 | 115 | If you edit a namespace or class that has been loaded with Dyalog's SALT 116 | toolkit (e.g. by using `]load` at the session prompt), the path to the source 117 | file will be sent to Emacs, so you can also save directly from there. If Emacs 118 | doesn't know the path to the source file, it will ask you to name a file when 119 | you try to save. 120 | 121 | ### Entering APL characters in Emacs ### 122 | By installing and enabling the Dyalog IME you can enter APL characters in 123 | Emacs. Note that the classic Dyalog layout uses the Control key for entering 124 | APL characters, which tends to conflict with Emacs' keyboard shortcuts. Your 125 | best bet is to use a layout that uses AltGr or Ctrl+Alt instead (the Dyalog 126 | keyboard for Linux uses a special compose key called the APL key). 127 | 128 | If you use AltGr to enter APL characters in Emacs on Windows, Emacs may 129 | interpret commands where you press Ctrl+Alt+key as Ctrl+Alt+aplchar. To avoid 130 | this, call dyalog-fix-altgr-chars. For example, if you want to enable the 131 | Dyalog IME globally in Emacs and want to fix the global keymap, so that ⊃, 132 | which you produce by pressing AltGr+x, isn't confused with C-M⊃, you would 133 | add the following to your init file: 134 | 135 | ```lisp 136 | (dyalog-fix-altgr-chars (current-global-map) "⊃" "x") 137 | ``` 138 | 139 | Configuration 140 | ------------- 141 | 142 | ### Emacs ### 143 | 144 | Run `M-x customize-group dyalog RET` to customize the various settings 145 | available. 146 | 147 | ### Dyalog ### 148 | 149 | If you want to use another keyboard shortcut for editing, just call 150 | `setupmenu` with an argument of the `Accelerator` property for your desired 151 | keyboard shortcut. For more information, see the built in Dyalog help for the 152 | Accelerator property. 153 | 154 | If you use something other than SALT to load source code into the session, you 155 | can set `Emacs.editor.getPath` to the name of a function that given a name 156 | (relative to root), will return the path to the corresponding source file. 157 | 158 | The variable `Emacs.editor.onMissing` is the name of a function to call when 159 | trying to edit a name that doesn't exist. It is called with the name as an 160 | argument and should try to establish the corresponding function, namespace or 161 | class. That way, you can press edit on names that haven't been established in 162 | the session yet. 163 | 164 | If `Emacs.editor.boxing` is true, arrays will be displayed with boxing inside 165 | Emacs, using the DISPLAY function from the display workspace that comes with 166 | Dyalog. 167 | 168 | Known issues and limitations 169 | ---------------------------- 170 | 171 | Arrays are always read-only and cannot be edited. 172 | 173 | In versions of Dyalog before 14.0, if you invoke Emacs to edit the current 174 | function suspended in the debugger from inside the debugger and fix that 175 | function, the debuggers display of the function's source code isn't updated. 176 | This is a Dyalog bug and cannot be fixed in Dyalog mode. 177 | 178 | If you invoke Emacs to edit the name under the cursor in the Dyalog editor, 179 | any line number specified is ignored, e.g. even if you edit FUNC[3] Emacs 180 | won't open with the cursor on line 3. This is a Dyalog limitation, the 181 | required information isn't available from within the editor. 182 | -------------------------------------------------------------------------------- /dyalog-mode.el: -------------------------------------------------------------------------------- 1 | ;;; dyalog-mode.el --- Major mode for editing Dyalog APL source code -*- coding: utf-8 lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2008, 2009, 2010, 2011 Joakim Hårsman 4 | 5 | ;; Author: Joakim Hårsman 6 | ;; Version: 0.7 7 | ;; Package-Requires: ((cl-lib "0.2")(emacs "24.3")) 8 | ;; Keywords: languages 9 | ;; URL: https://github.com/harsman/dyalog-mode.git 10 | 11 | ;; This file is not part of GNU Emacs. 12 | 13 | ;; This program is free software; you can redistribute it and/or modify 14 | ;; it under the terms of the GNU General Public License as published by 15 | ;; the Free Software Foundation, either version 3 of the License, or 16 | ;; (at your option) any later version. 17 | 18 | ;; This program is distributed in the hope that it will be useful, 19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21 | ;; GNU General Public License for more details. 22 | 23 | ;; You should have received a copy of the GNU General Public License 24 | ;; along with this program. If not, see . 25 | 26 | ;;; Commentary: 27 | ;; 28 | ;; Dyalog-mode is a major mode for editing Dyalog APL source code. 29 | ;; 30 | ;; It supports syntax highlighting, indentation and convenience function like 31 | ;; toggling localization of variables. It can communicate with Dyalog 32 | ;; processes over a socket, allowing Emacs to be used as the editor for a 33 | ;; Dyalog session. 34 | ;; 35 | ;; Get the latest version at https://github.com/harsman/dyalog-mode 36 | 37 | ;;; Code: 38 | 39 | 40 | 41 | (require 'cl-lib) 42 | (require 'json) 43 | (require 'comint) 44 | 45 | ;; Set up mode specific keys below 46 | (defvar dyalog-mode-map 47 | (let ((map(make-keymap))) 48 | (define-key map (kbd"M-RET") 'comment-indent-new-line) 49 | (define-key map (kbd"C-c C-c") 'dyalog-editor-fix) 50 | (define-key map (kbd"C-c C-q") 'dyalog-editor-fix-and-quit) 51 | (define-key map (kbd"C-c C-e") 'dyalog-editor-edit-symbol-at-point) 52 | (define-key map (kbd"C-c C-l") 'dyalog-toggle-local) 53 | (define-key map (kbd"C-C C-h") 'dyalog-help-for-symbol-at-point) 54 | map) 55 | "Keymap for Dyalog APL mode.") 56 | 57 | (defvar dyalog-array-mode-map 58 | (let ((map(make-sparse-keymap))) 59 | ;;(define-key map (kbd"C-c C-c") 'dyalog-array-fix) 60 | (define-key map (kbd"C-c C-e") 'dyalog-editor-edit-symbol-at-point) 61 | map) 62 | "Keymap for Dyalog Array edit mode.") 63 | 64 | ;;;###autoload 65 | (defun dyalog-fix-altgr-chars (keymap aplchars regularchars) 66 | "Fix a key map so AltGr+char isn't confused with C-M-char. 67 | 68 | KEYMAP is an Emacs keymap. 69 | 70 | APLCHARS is a string of APL-characters produced by pressing AltGr together 71 | with some character. 72 | 73 | REGULARCHARS is a string of the characters that when pressed 74 | together with AltGr produce the corresponding apl character in APLCHARS." 75 | (dolist (pair (cl-mapcar #'cons aplchars regularchars)) 76 | (let* ((aplchar (car pair)) 77 | (char (cdr pair)) 78 | (aplkey (vector (list 'control 'meta aplchar))) 79 | (regkey (vector (list 'control 'meta char))) 80 | (fun (lookup-key (current-global-map) regkey))) 81 | (when fun 82 | (define-key keymap aplkey fun))))) 83 | 84 | (defconst dyalog-label-regex 85 | "^\\s-*\\([A-Za-z_][A-Za-z0-9_]*:\\)") 86 | 87 | (defconst dyalog-keyword-regex 88 | (concat "\\(\\(?:^\\s-*\\|\\(?5:" dyalog-label-regex " *\\)\\)" 89 | "\\(?2::[A-Za-z]+\\)\\)\\|\\(⋄\\s-*\\(?2::[A-Za-z]+\\)\\)")) 90 | 91 | (defconst dyalog-middle-keyword-regex 92 | "\\(?: \\|\\_>\\)\\(:\\(In\\|InEach\\)\\)\\_>") 93 | 94 | (defconst dyalog-comment-regex 95 | "^\\s-*⍝") 96 | 97 | (defvar dyalog-ascii-chars "][<>+---=/¨~\\?*(){}&|.;@!" 98 | "APL symbols also present in ASCII.") 99 | 100 | (defvar dyalog-keyword-chars 101 | "×≤≥≠∨∧÷∊⍴↑↓⍳○←→⌈⌊∘⍎⍕⊂⊃⊆⊇∩∪⊥⊤⍨⍒⍋⌽⍉⊖⍟⍱⍲⍬⌹≡≢⍪⌿⍀⍺⍵⎕⍞⋄⍷⍸⌷⍣⊣⊢⌶⌺⍥⍠") 102 | 103 | (defconst dyalog-name "[A-Za-z∆_][A-Za-z∆_0-9]*") 104 | 105 | (defconst dyalog-real-number-regex 106 | "¯?\\([0-9]+\\.?[0-9]*\\|\\.[0-9]+\\)\\([Ee]¯?[0-9]+\\.?[0-9]*\\)?") 107 | 108 | (defvar dyalog-number 109 | (concat "[^A-Za-z_∆0-9]\\(" dyalog-real-number-regex 110 | "\\([Jj]" dyalog-real-number-regex "\\)?\\)")) 111 | 112 | (defconst dyalog-access-type 113 | "^\\s-*:Access +\\(WebMethod\\|\\(?:\\(Public\\|Private\\)\\)?\\(?: +\\(Instance\\( +Override\\|Overridable\\)\\|Shared\\)\\)?\\)") 114 | 115 | (defconst dyalog-field-def 116 | (concat "^\\s-*:Field" 117 | "\\(?: +\\(Public\\|Private\\)\\)?" 118 | "\\(?: +\\(Instance\\|Shared\\)\\)?" 119 | "\\(?: +\\(ReadOnly\\)\\)?" 120 | " +" "\\(" dyalog-name "\\)")) 121 | 122 | (defconst dyalog-naked-nabla "^\\s-*∇\\s-*$") 123 | 124 | (defconst dyalog-func-start "\\(?:\\`\\|∇[\r\n]*\\)\\s-*") 125 | 126 | (defun dyalog-name-list (id) 127 | "Return a regex with group ID matching a dyalog name list. 128 | Name lists are (optionally) used for naming the elements of the 129 | return value or right argument of a traditional defined function." 130 | (concat "( *\\(?" id ":" dyalog-name "\\(?: +" dyalog-name "\\)+\\)" 131 | "*)")) 132 | 133 | (defconst dyalog-func-retval 134 | (concat "\\(?:" 135 | "\\(?:" "\\(?2:" dyalog-name "\\)" "\\|" 136 | "\\(?:" (dyalog-name-list "2") "\\)" "\\|" 137 | "\\(?:" "{\\(?2:" dyalog-name "\\)}\\)" "\\|" 138 | "\\(?:" "{ *" (dyalog-name-list "2") " *}\\)" 139 | "\\) *← *\\)?")) 140 | 141 | (defconst dyalog-func-larg 142 | (concat 143 | "\\(?:" 144 | "\\(?3:" dyalog-name "\\)\\(?:\\_>\\| +\\)" "\\|" 145 | "{\\(?3:" dyalog-name "+\\)}" 146 | "*\\)")) 147 | 148 | (defconst dyalog-func-name (concat "\\(?1:" dyalog-name "\\)")) 149 | 150 | (defconst dyalog-op-def (concat "\\(?:" "( *" 151 | "\\(?6:" dyalog-name "\\)" ; left operand 152 | " +" 153 | "\\(?7:" dyalog-name "\\)" ; operator name 154 | "\\(?:" " +" 155 | "\\(?8:" dyalog-name "\\)" ; right operand 156 | "\\)?" " *)" "\\)")) 157 | 158 | (defconst dyalog-func-def (concat "\\(?:" dyalog-func-name "\\|" 159 | dyalog-op-def "\\)")) 160 | 161 | (defvar dyalog-func-rarg (concat "\\(?:\\(?:\\(?: +\\|\\_<\\)\\(?4:" 162 | dyalog-name "\\)\\)\\|" 163 | "\\(?: *" (dyalog-name-list "4") "\\)\\)")) 164 | 165 | (defconst dyalog-func-header-end "\\s-*\\(?5:;\\|$\\)") 166 | 167 | (defconst dyalog-tradfn-header (concat dyalog-func-start dyalog-func-retval 168 | "\\(?:" 169 | "\\(?:" dyalog-func-larg dyalog-func-def 170 | dyalog-func-rarg "\\)" "\\|" 171 | "\\(?:" dyalog-func-def dyalog-func-rarg "?" 172 | "\\)" "\\)" 173 | dyalog-func-header-end)) 174 | 175 | (defface dyalog-apl-char 176 | '((t (:inherit font-lock-keyword-face))) 177 | "Face used for APL characters and punctuation." 178 | :group 'dyalog) 179 | 180 | (defface dyalog-local-name 181 | '((t (:inherit font-lock-constant-face))) 182 | "Face used for localized names inside APL functions." 183 | :group 'dyalog) 184 | 185 | (defface dyalog-local-system-name 186 | '((t (:inherit font-lock-variable-name-face))) 187 | "Face used for localized system variables inside APL functions." 188 | :group 'dyalog) 189 | 190 | (defface dyalog-label-definition-face 191 | '((t (:inherit font-lock-keyword-face))) 192 | "Face used for label definitions inside APL functions" 193 | :group 'dyalog) 194 | 195 | (defvar dyalog-font-lock-keywords 196 | (list 197 | ;; See emacs help for `font-lock-keywords' for a description of how the 198 | ;; below values work 199 | ;; System functions 200 | '("⎕[A-Za-z]*" . font-lock-builtin-face) 201 | ;; Keywords 202 | `(,dyalog-keyword-regex 203 | . (2 font-lock-keyword-face nil)) 204 | `(,dyalog-middle-keyword-regex . (2 font-lock-keyword-face nil)) 205 | ;; Labels 206 | `(,dyalog-label-regex . (1 'dyalog-label-definition-face t)) 207 | ;; Numeric constans 208 | `(,dyalog-number (1 font-lock-constant-face nil)) 209 | ;; APL chars 210 | (cons (concat "[" dyalog-ascii-chars dyalog-keyword-chars ":" "]") 211 | ''dyalog-apl-char) 212 | ;; Localizations 213 | '(";\\([A-Za-z0-9_∆]+\\)" (1 font-lock-constant-face nil)) 214 | ;; Illegal chars (and del/nabla) 215 | '("[∇$\"%]+" . font-lock-warning-face) 216 | ;; Local names. Note that the face specified here doesn't matter since 217 | ;; dyalog-fontify-locals-matcher always returns nil and sets the face on 218 | ;; its own. 219 | `(dyalog-fontify-locals-matcher (1 font-lock-keyword-face nil)) 220 | `(,dyalog-access-type (1 font-lock-keyword-face)) 221 | `(,dyalog-field-def (1 font-lock-keyword-face t t) 222 | (4 font-lock-variable-name-face) 223 | (2 font-lock-keyword-face t t) 224 | (3 font-lock-keyword-face t t))) 225 | "Default highlighting mode for Dyalog mode.") 226 | 227 | (defvar dyalog-mode-syntax-table 228 | (let ((st (make-syntax-table))) 229 | ;; Make various APL chars punctuation 230 | (dolist (char 231 | (string-to-list (concat dyalog-keyword-chars dyalog-ascii-chars))) 232 | (modify-syntax-entry char "." st)) 233 | ;; Make sure delta, quad and underscore are part of symbol names 234 | ;; This doesn't seem to work for delta and quad? 235 | (modify-syntax-entry ?_ "_" st) 236 | (modify-syntax-entry ?∆ "_" st) 237 | (modify-syntax-entry ?⎕ "_" st) 238 | ;; Comments 239 | (modify-syntax-entry ?⍝ "<" st) 240 | (modify-syntax-entry ?\n">" st) 241 | ;; Strings 242 | (modify-syntax-entry ?' "\"" st) 243 | (modify-syntax-entry ?\" "." st) 244 | ;; Delimiters 245 | (modify-syntax-entry ?\[ "(]" st) 246 | (modify-syntax-entry ?\] ")[" st) 247 | (modify-syntax-entry ?\( "()" st) 248 | (modify-syntax-entry ?\) ")(" st) 249 | (modify-syntax-entry ?{ "(}" st) 250 | (modify-syntax-entry ?\} "){" st) 251 | st) 252 | "Syntax table for `dyalog-mode'.") 253 | 254 | (defvar dyalog-array-mode-syntax-table 255 | (let ((st (make-syntax-table))) 256 | (dolist (char 257 | (string-to-list (concat dyalog-keyword-chars dyalog-ascii-chars))) 258 | (modify-syntax-entry char "." st)) 259 | (modify-syntax-entry ?_ "_" st) 260 | (modify-syntax-entry ?∆ "_" st) 261 | (modify-syntax-entry ?⎕ "_" st) 262 | ;; Delimiters 263 | (modify-syntax-entry ?\[ "(]" st) 264 | (modify-syntax-entry ?\] ")[" st) 265 | (modify-syntax-entry ?\( "()" st) 266 | (modify-syntax-entry ?\) ")(" st) 267 | (modify-syntax-entry ?{ "(}" st) 268 | (modify-syntax-entry ?\} "){" st) 269 | st) 270 | "Syntax table for `dyalog-array-mode'.") 271 | 272 | (defconst dyalog-dfun-syntax-table 273 | (let ((st (copy-syntax-table dyalog-mode-syntax-table))) 274 | (modify-syntax-entry ?\( "." st) 275 | (modify-syntax-entry ?\) "." st) 276 | (modify-syntax-entry ?\[ "." st) 277 | (modify-syntax-entry ?\] "." st) 278 | st) 279 | "Syntax table to only consider {} as parens.") 280 | 281 | ;;;###autoload 282 | (defun dyalog-ediff-forward-word () 283 | "Move point forward one word." 284 | (interactive) 285 | (or (> (skip-chars-forward "A-Za-z_∆0-9") 0) ; name 286 | (> (skip-chars-forward "⎕:A-Za-z") 0) ; sys name/keyword 287 | (> (skip-chars-forward "0-9E¯.") 0) ; numbers 288 | (> (skip-chars-forward "⍺⍵∇") 0) ; meta chars 289 | (> (skip-chars-forward " ") 0) ; white space 290 | (forward-char))) ; fallback 291 | 292 | (defconst dyalog-delimiter-match 293 | (let ((h (make-hash-table :test 'equal))) 294 | (dolist (e '((":if" . ":endif")("{"."}") 295 | (":for" . ":endfor")(":repeat" . ":until") 296 | (":while" . ":endwhile")(":trap" . ":endtrap") 297 | (":hold" . ":endhold")(":with" . ":endwith") 298 | (":namespace" . ":endnamespace")(":class" . ":endclass") 299 | (":select" . ":endselect")(":interface" . ":endinterface") 300 | (":property" . ":endproperty"))) 301 | (puthash (car e) (list (cdr e) 'block-start) h) 302 | (puthash (cdr e) (list (car e) 'block-end) h)) 303 | (dolist (e '((":andif". ":if")(":orif".":if")(":elseif".":if"))) 304 | (puthash (car e) (list (cdr e) 'block-pause) h)) 305 | (dolist (e '((":else" . ":\\(if\\|select\\|trap\\|hold\\)") 306 | (":case" . ":\\(select\\|trap\\)") 307 | (":caselist" . ":\\(select\\|trap\\)"))) 308 | (puthash (car e) (list (cdr e) 'block-pause) h)) 309 | (dolist (e '((":field" . ":\\(class\\|interface\\)"))) 310 | (puthash (car e) (list (cdr e) nil) h)) 311 | (dolist (e '(":access" ":using")) 312 | (puthash e (list "" nil) h)) 313 | (puthash ":endrepeat" (list ":repeat" 'block-end) h) 314 | (puthash ":end" (list nil 'block-end) h) 315 | (puthash ":section" (list ":endsection" nil) h) 316 | (puthash ":endsection" (list ":section" nil) h) 317 | h)) 318 | 319 | (defconst dyalog-any-delimiter 320 | ":*" 321 | "A bogus keyword used to indicate a match with any keyword.") 322 | 323 | (defgroup dyalog nil 324 | "Major mode `dyalog-mode' for editing Dyalog APL code." 325 | :group 'languages 326 | :prefix "dyalog-") 327 | 328 | (defcustom dyalog-mode-hook nil 329 | "List of functions to be executed on entry to `dyalog-mode'." 330 | :type 'hook 331 | :group 'dyalog) 332 | 333 | (defcustom dyalog-leading-spaces 1 334 | "The number of leading spaces to use for unknown buffer types. 335 | Namespaces, classes and interfaces have 0 leading spaces in the left margin, and 336 | functions have 1, but for buffers that cannot be qualified into one of these types, 337 | the number of leading spaces defined here is used." 338 | :type 'integer 339 | :group 'dyalog) 340 | 341 | (defcustom dyalog-indent-comments t 342 | "True if comments should be indented according to the surrounding scope." 343 | :type 'boolean 344 | :group 'dyalog) 345 | 346 | (defcustom dyalog-fix-whitespace-before-save nil 347 | "If true, indent and delete redundant whitespace before saving." 348 | :type 'boolean 349 | :group 'dyalog) 350 | 351 | (defvar dyalog-buffer-type nil 352 | "Whether a buffer contains a function, namespace or something else. 353 | This affects indentation, functions have a leading space on each 354 | line, but namespaces don't. Valid values are 'space-or-class 355 | 'function and 'unknown.") 356 | 357 | ;;; Indentation 358 | 359 | (defun dyalog-matching-delimiter (delimiter) 360 | "Return the match for the given DELIMITER. 361 | For example, if ':EndIf' is provided, return ':If' and vice versa." 362 | (car (gethash (downcase delimiter) dyalog-delimiter-match nil))) 363 | 364 | (defun dyalog-keyword-indent-type (keyword) 365 | "Return a symbol indicating how a KEYWORD affects indentation. 366 | If KEYWORD introduces a new block, (e.g :If), return 367 | 'block-start. If it ends a block (e.g. :EndIf), return 368 | 'block-end. If it ends a block and immediately starts a new 369 | block (e.g. :Else or :Case), return 'block-pause. If the keyword 370 | should be indented the same way as everything else, return nil." 371 | (let ((d (gethash (downcase keyword) dyalog-delimiter-match nil))) 372 | (and d (nth 1 d)))) 373 | 374 | (defun dyalog-specific-keyword-regex (keyword) 375 | "Return a regex mathcing KEYWORD when point is at bol." 376 | (concat "\\(\\(?:^\\s-*\\|\\(?:" dyalog-label-regex " *\\)\\)" 377 | keyword "\\)\\|\\(⋄\\s-*" keyword "\\)")) 378 | 379 | (defun dyalog-relative-indent (n) 380 | "Return the no spaces to indent N tabstops relative to the current line." 381 | (max (+ (current-indentation) (* tab-width n)) 382 | (dyalog-leading-indentation))) 383 | 384 | (defun dyalog-previous-logical-line () 385 | "Move backwards to the start of the previous logical line. 386 | Assumes point is at the beginning of a logical line." 387 | (let ((bol (line-beginning-position)) 388 | (done nil)) 389 | (if (eq (point) bol) 390 | (progn 391 | (forward-line -1) 392 | (end-of-line)) 393 | (when (eq (char-before) ?⋄) 394 | (backward-char))) 395 | (while (not done) 396 | (skip-chars-backward "^⋄\r\n") 397 | (if (eq (char-before) ?⋄) 398 | (progn 399 | (setq done (not (dyalog-in-comment-or-string))) 400 | (when (not done) 401 | (backward-char))) 402 | (setq done t))))) 403 | 404 | (defun dyalog-next-logical-line () 405 | "Move forward to the start of the next logical line. 406 | Assumes point is at the start of a logical line." 407 | (let ((done nil)) 408 | (when (eq (char-after) ?⋄) 409 | (forward-char)) 410 | (while (not done) 411 | (skip-chars-forward "^⋄\r\n") 412 | (if (eq (char-after) ?⋄) 413 | (setq done (not (dyalog-in-comment-or-string))) 414 | (setq done t)) 415 | (if (eobp) 416 | nil 417 | (forward-char))))) 418 | 419 | (defun dyalog-indent-parse-line (dfunstack on-tradfn-header) 420 | "Parse the current logical line for indentation purposes. 421 | DFUNSTACK is a list of delimiters of currently open dfun blocks. 422 | This affects the parsing of :. ON-TRADFN-HEADER is true if the 423 | line is a tradfn header, this affects the parsing of { and }. 424 | Return a plist with properties :keyword, the keyword at the head 425 | of the line, :label which is the label at the start of the line 426 | if any, :dfunstack which is a list of dfun delimiters open at end 427 | of line, and finally :next-line which is the character position 428 | the next logical line starts at." 429 | (let ((done nil) 430 | (eol (line-end-position)) 431 | (in-dfun (equal "{" (car dfunstack))) 432 | (dfun-count nil) 433 | (label nil) 434 | (keyword nil) 435 | (indent-type nil) 436 | (start nil)) 437 | (save-excursion 438 | (if (eq (char-after) ?⋄) 439 | (forward-char) 440 | (if (and (not in-dfun) (looking-at dyalog-label-regex)) 441 | (progn 442 | (setq label (match-string-no-properties 1)) 443 | (goto-char (match-end 0))))) 444 | (setq start (point)) 445 | (cond 446 | ((looking-at-p "[ \t]*$") 447 | (setq indent-type 'blank)) 448 | ((looking-at-p "[ \t]*⍝") 449 | (setq indent-type 'comment))) 450 | (while (not done) 451 | (skip-chars-forward "^⋄\r\n'{}⍝:") 452 | (pcase (char-after) 453 | (?' 454 | (progn 455 | (condition-case nil 456 | (forward-sexp) 457 | (scan-error (goto-char eol))) 458 | (when (> (point) eol) 459 | (goto-char eol) 460 | (setq done t)))) 461 | (?⍝ 462 | (progn 463 | (goto-char eol) 464 | (setq done t))) 465 | (?{ 466 | (if on-tradfn-header 467 | (forward-char) 468 | (progn 469 | (push "{" dfunstack) 470 | (setq dfun-count (1+ (or dfun-count 0))) 471 | (if (eobp) 472 | (setq done t) 473 | (forward-char)) 474 | (setq in-dfun t)))) 475 | (?} 476 | (if on-tradfn-header 477 | (forward-char) 478 | (progn 479 | (when dfunstack 480 | (pop dfunstack) 481 | (setq dfun-count (1- (or dfun-count 0))) 482 | (setq in-dfun (equal (car dfunstack) "{"))) 483 | (if (eobp) 484 | (setq done t) 485 | (forward-char))))) 486 | (?: 487 | (if (or in-dfun keyword) 488 | (forward-char) 489 | (progn 490 | (setq keyword 491 | (buffer-substring-no-properties 492 | (point) 493 | (progn 494 | (skip-chars-forward ":A-Za-z") 495 | (point))) 496 | indent-type 497 | (dyalog-keyword-indent-type keyword))))) 498 | (_ 499 | (setq done t)))) 500 | (cond 501 | ((and dfun-count (> dfun-count 0)) 502 | (setq indent-type 'dfun-start)) 503 | ((and dfun-count (< dfun-count 0)) 504 | (setq indent-type 505 | (if (eq (save-excursion 506 | (goto-char start) 507 | (skip-syntax-forward " ") 508 | (char-after)) 509 | ?}) 510 | 'dfun-end-and-dedent 511 | 'dfun-end)))) 512 | (unless (eobp) 513 | (forward-char)) 514 | (list :label label :keyword keyword :dfunstack dfunstack 515 | :indent-type indent-type :next-line (point))))) 516 | 517 | (defun dyalog-indent-stop-block-end (match blockstack indent-status _funcount) 518 | "Return whether we have found root for a block end, and amount of to indent. 519 | MATCH is the keyword that matches the block end (e.g. :For 520 | matches :EndFor), BLOCKSTACK is a stack of currently open blocks, 521 | INDENT-STATUS is the indentation status of the current line (the 522 | return value from `dyalog-indent-status', and FUNCOUNT is the 523 | number of currently open tradfn definitions." 524 | (let ((indent-type (plist-get indent-status :indent-type))) 525 | (cond 526 | ((and (not blockstack) 527 | (if match 528 | (looking-at-p (dyalog-specific-keyword-regex match)) 529 | (memq indent-type '(block-start block-pause)))) 530 | (list t (dyalog-relative-indent 0))) 531 | ((and (memq indent-type '(tradfn-start tradfn-end)) 532 | (not (string-match ":\\(End\\)?\\(Namespace\\|Class\\|Section\\)" match))) 533 | (list t (skip-chars-forward " ∇")))))) 534 | 535 | (defun dyalog-indent-stop-tradfn (blockstack indent-status _funcount) 536 | "Return whether we have found root for a tradfn, and chars to indent. 537 | BLOCKSTACK is a stack of currently open blocks, INDENT-STATUS is 538 | the indentation status of the current line (the return value from 539 | `dyalog-indent-status', and FUNCOUNT is the number of currently 540 | open tradfn definitions." 541 | (cond ((and (not blockstack) 542 | (looking-at-p (dyalog-specific-keyword-regex 543 | ":\\(Class\\|Namespace\\)"))) 544 | (list t (dyalog-relative-indent 1))) 545 | ((and (not blockstack) 546 | (memq (plist-get indent-status :indent-type) 547 | '(tradfn-start tradfn-end))) 548 | (list t (current-indentation))))) 549 | 550 | (defun dyalog-indent-search-stop-function (keyword 551 | &optional match_ indent-type_) 552 | "Given a KEYWORD, return a function to check for indentation root. 553 | Optional argument MATCH_ is the matching keyword (e.g. :If 554 | for :EndIf) and only needs to be supplied if it differs from the 555 | default. INDENT-TYPE_ is also optional, and is the indentation 556 | type for the given keyword (see `dyalog-keyword-indent-type') and 557 | only needs to be supplied if it differs from the default." 558 | (let* ((match (or match_ (dyalog-matching-delimiter keyword))) 559 | (indent-type (or indent-type_ (dyalog-keyword-indent-type keyword)))) 560 | (cond 561 | ((eq 'block-start indent-type) 562 | #'dyalog-indent-search-stop-generic) 563 | ((memq indent-type '(block-end block-pause)) 564 | (apply-partially 'dyalog-indent-stop-block-end match)) 565 | ((member (downcase keyword) '(":access" ":using")) 566 | #'dyalog-indent-search-stop-access) 567 | (t 568 | #'dyalog-indent-search-stop-generic)))) 569 | 570 | (defun dyalog-indent-search-stop-access (blockstack indent-status funcount) 571 | "Return if we have found an indentation root and no chars to indent. 572 | :Access keywords are a special case since they are aligned 573 | either to a tradfn or at the same level as their parent :Property or :Class block." 574 | (let ((indent-type (plist-get indent-status :indent-type)) 575 | (delimiter (plist-get indent-status :delimiter)) 576 | (label-at-bol (plist-get indent-status :label-at-bol))) 577 | (cond 578 | ((member (downcase (or delimiter "")) '(":class" ":property")) 579 | (list t (current-indentation))) 580 | ((and (eq indent-type 'tradfn-start) 581 | (eq funcount 0)) 582 | (list t (skip-chars-forward " ∇"))) 583 | ((bobp) 584 | (list t (dyalog-leading-indentation))) 585 | (t 586 | (list nil 0))))) 587 | 588 | (defun dyalog-indent-search-stop-generic (blockstack indent-status funcount) 589 | "Return if we have found an indentation root, and no chars to indent. 590 | BLOCKSTACK is a stack of currently open blocks, INDENT-STATUS is 591 | the indentation status of the current keyword (if any), and 592 | FUNCOUNT is the number of currently open tradfn definitions." 593 | (let ((indent-type (plist-get indent-status :indent-type)) 594 | (label-at-bol (plist-get indent-status :label-at-bol))) 595 | (cond 596 | ((and (eq indent-type 'block-start) (not blockstack) (eq funcount 0)) 597 | (list t (+ (dyalog-relative-indent 1) 598 | (if label-at-bol 1 0)))) 599 | ((and (eq indent-type 'block-end) (not blockstack) (eq funcount 0)) 600 | (list t (+ (current-indentation) 601 | (if label-at-bol 1 0)))) 602 | ((and (eq indent-type 'tradfn-start) 603 | (eq funcount 0)) 604 | (list t (skip-chars-forward " \t∇"))) 605 | ((eq indent-type 'tradfn-end) 606 | (list t (skip-chars-forward " \t"))) 607 | ((bobp) 608 | (list t (dyalog-leading-indentation))) 609 | (t 610 | (list nil 0))))) 611 | 612 | (defun dyalog-indent-status (dfunstack) 613 | "Return a list of information on the current indentation status. 614 | DFUNSTACK is a list of open dfun blocks at point. The list of 615 | information returned includes whether we are at the start of a 616 | block, or the end (or at a pause inside a block), and the name of 617 | the delimiter that triggers the starting or ending of a 618 | block (e.g. \":If\" or \"∇\"." 619 | (let ((next-line (min (point-max) (1+ (line-end-position))))) 620 | (cond 621 | ((and (not dfunstack) (dyalog-on-tradfn-header)) 622 | (list :indent-type 'tradfn-start :delimiter nil :label-at-bol nil 623 | :next-line next-line)) 624 | ((looking-at dyalog-naked-nabla) 625 | (list :indent-type 'tradfn-end :delimiter nil :label-at-bol nil 626 | :next-line next-line)) 627 | (t 628 | (let* ((indent-parse (dyalog-indent-parse-line dfunstack nil)) 629 | (keyword (plist-get indent-parse :keyword)) 630 | (indent-type (plist-get indent-parse :indent-type)) 631 | (label (plist-get indent-parse :label)) 632 | (next-line (plist-get indent-parse :next-line))) 633 | (list :indent-type indent-type :delimiter keyword 634 | :label-at-bol label :next-line next-line 635 | :dfunstack (plist-get indent-parse :dfunstack))))))) 636 | 637 | (defun dyalog-search-indent-root (at-root-function) 638 | "Given function AT-ROOT-FUNCTION, search backwards for the root indent. 639 | AT-ROOT-FUNCTION assumes point is at the beginning of a logical 640 | line and returns t when point is at the line containing the 641 | indentation root. For example if we are indenting a :EndFor, 642 | AT-ROOT-FUNCTION returns t when we have reached the corresponding :For." 643 | (let* ((indentation nil) 644 | (blockstack ()) 645 | (funcount 0)) 646 | (save-excursion 647 | (while (not indentation) 648 | ;; TODO: We should probably skip past d-funs 649 | 650 | (dyalog-previous-logical-line) 651 | (let* ((in-dfun (dyalog-in-dfun)) 652 | (status (dyalog-indent-status nil)) 653 | (keyword (plist-get status :delimiter)) 654 | (indent-type (plist-get status :indent-type)) 655 | (root (apply at-root-function 656 | (list blockstack status funcount))) 657 | (at-root (car root))) 658 | (setq indentation 659 | (cond 660 | (in-dfun 661 | (goto-char (plist-get in-dfun :start)) 662 | (dyalog-next-logical-line) 663 | (dyalog-previous-logical-line) 664 | nil) 665 | (at-root 666 | (nth 1 root)) 667 | ((eq 'block-end indent-type) 668 | (progn 669 | (push (or (dyalog-matching-delimiter keyword) 670 | dyalog-any-delimiter) 671 | blockstack) 672 | nil)) 673 | ((eq 'block-start indent-type) 674 | (progn 675 | (when (or (equal dyalog-any-delimiter (car blockstack)) 676 | (compare-strings keyword nil nil 677 | (or (car blockstack) "") nil nil 678 | 'ignore-case)) 679 | (pop blockstack)) 680 | nil)) 681 | ((eq 'tradfn-end indent-type) 682 | (setq funcount (1+ funcount)) 683 | nil) 684 | ((eq 'tradfn-start indent-type) 685 | (setq funcount (1- funcount)) 686 | nil))) 687 | (when (and (not indentation) (bobp)) 688 | (setq indentation (dyalog-leading-indentation))))) 689 | (list :indent indentation :has-label nil 690 | :funcount funcount :blockstack blockstack)))) 691 | 692 | (defun dyalog-calculate-dfun-indent () 693 | "Calculate the indentation amount for a line in a dfun." 694 | (let* ((start (point)) 695 | (line-start (+ start (skip-syntax-forward "-")))) 696 | (save-excursion 697 | (let ((containing-brace (scan-lists start -1 1))) 698 | (if (< containing-brace line-start) 699 | (progn 700 | (goto-char containing-brace) 701 | (dyalog-relative-indent 702 | (if (equal (char-after line-start) ?}) 703 | 0 1))) 704 | (dyalog-leading-indentation)))))) 705 | 706 | (defun dyalog-calculate-indent () 707 | "Calculate the amount of indentation for the current line. 708 | Return a plist with the indent in spaces, and whether the current 709 | line has a label." 710 | (save-excursion 711 | (move-beginning-of-line nil) 712 | (let* ((dfunstack (dyalog-current-dfun-stack)) 713 | (indent-status (dyalog-indent-status dfunstack)) 714 | (indent-type (plist-get indent-status :indent-type)) 715 | (label (plist-get indent-status :label-at-bol)) 716 | (keyword (plist-get indent-status :delimiter)) 717 | (indent-info nil) 718 | (current-line-indent-info nil)) 719 | (setq indent-info 720 | (cond 721 | ((bobp) 722 | (list :indent (dyalog-leading-indentation) 723 | :has-label nil 724 | :is-comment nil 725 | :funcount 0 726 | :blockstack nil)) 727 | (dfunstack 728 | (list :indent (dyalog-calculate-dfun-indent) 729 | :has-label nil 730 | :is-comment nil 731 | :funcount 0 732 | :dfunstack dfunstack)) 733 | (label 734 | (let* ((label-indent-info (dyalog-search-indent-root 735 | #'dyalog-indent-stop-tradfn)) 736 | (label-indent (plist-get label-indent-info :indent)) 737 | (old-label (dyalog-remove-label)) 738 | (rest-indent-info (dyalog-calculate-indent))) 739 | ;; A label is always aligned 1 space to the left of the 740 | ;; surrounding tradfn, and since we search for tradfn 741 | ;; delimiters, we align to the nabla. So if we've reached the 742 | ;; beginning of the buffer, we subtract one and if we've 743 | ;; aligned to the nabla we add one. 744 | (setq label-indent (max 0 (+ label-indent 745 | (if (= label-indent 746 | (dyalog-leading-indentation)) 747 | -1 748 | 1)))) 749 | (insert old-label) 750 | (plist-put rest-indent-info :has-label t) 751 | (plist-put rest-indent-info :label-indent label-indent) 752 | rest-indent-info)) 753 | ((eq indent-type 'comment) 754 | (if dyalog-indent-comments 755 | (let ((l (dyalog-search-indent-root 756 | #'dyalog-indent-search-stop-generic))) 757 | (plist-put l :is-comment t)) 758 | (list :indent (current-indentation) 759 | :has-label nil 760 | :is-comment t 761 | :funcount 0 762 | :blockstack nil))) 763 | (keyword 764 | (dyalog-search-indent-root 765 | (dyalog-indent-search-stop-function keyword))) 766 | ((eq 'tradfn-end indent-type) 767 | (dyalog-search-indent-root #'dyalog-indent-stop-tradfn)) 768 | ((eq 'tradfn-start indent-type) 769 | (dyalog-search-indent-root #'dyalog-indent-stop-tradfn)) 770 | (t 771 | (dyalog-search-indent-root #'dyalog-indent-search-stop-generic)))) 772 | (setq current-line-indent-info 773 | (dyalog-indent-from-indent-type indent-status indent-info 774 | (current-indentation))) 775 | (unless (eq 'blank indent-type) 776 | (plist-put indent-info :next-indent 777 | (plist-get current-line-indent-info :next-indent))) 778 | indent-info))) 779 | 780 | (defun dyalog-leading-indentation () 781 | "Return the number of spaces to indent by in the current buffer. 782 | This varies depending of the type of object being edited, 783 | namespaces or classes have no extra leading indentation, but functions have 784 | one extra space, to be consistent with separating multiple 785 | functions with ∇." 786 | (pcase (or dyalog-buffer-type (dyalog-guess-buffer-type)) 787 | (`space-or-class 0) 788 | (`function 1) 789 | (`unknown dyalog-leading-spaces))) 790 | 791 | (defun dyalog-indent-line-with (indent-info) 792 | "Indent the current line according to INDENT-INFO. 793 | INDENT-INFO is the return value from `dyalog-calculate-indent'." 794 | (let* ((indent (plist-get indent-info :indent)) 795 | (has-label (plist-get indent-info :has-label)) 796 | (is-comment (plist-get indent-info :is-comment))) 797 | (if has-label 798 | (let* ((old-label (dyalog-remove-label)) 799 | (label-length (length old-label)) 800 | (label-indent (plist-get indent-info :label-indent))) 801 | (if (and (not dyalog-indent-comments) is-comment) 802 | (setq indent (- indent label-indent)) 803 | (if (> label-length indent) 804 | ;; Label is longer than required indentation, so line 805 | ;; should be flush with label 806 | (setq indent 0) 807 | (setq indent (max 0 808 | (- indent (+ label-length label-indent)))))) 809 | ;; Keywords are never flush with the label, since they start with 810 | ;; a colon, and the label ends with one 811 | (beginning-of-line) 812 | (when (looking-at-p "^ *:") 813 | (setq indent (max 1 indent))) 814 | (indent-line-to indent) 815 | (beginning-of-line) 816 | (insert (make-string label-indent ? )) 817 | (insert old-label) 818 | (back-to-indentation)) 819 | (indent-line-to indent)))) 820 | 821 | (defun dyalog-indent-line () 822 | "Indent the current line." 823 | (interactive) 824 | (let* ((restore-pos (> (current-column) (current-indentation))) 825 | (old-pos (point)) 826 | (indent-info (dyalog-calculate-indent))) 827 | (dyalog-indent-line-with indent-info) 828 | (when restore-pos 829 | (goto-char (min old-pos (line-end-position)))))) 830 | 831 | (defun dyalog-current-tradfn-indentation () 832 | "Return the column 0 indentation of the tradfn point is in, otherwise nil." 833 | (let* ((tradfn-info (dyalog-tradfn-info)) 834 | (tradfn-name (car tradfn-info)) 835 | (end-of-header (nth 3 tradfn-info))) 836 | (when (not (zerop (length tradfn-name))) 837 | (save-excursion 838 | (goto-char end-of-header) 839 | (beginning-of-line) 840 | (skip-chars-forward " ∇") 841 | (current-column))))) 842 | 843 | (defun dyalog-current-dfun-stack () 844 | "Return a list of open dynamic functions delimiters." 845 | (let ((in-dfun nil) 846 | (dfunstack ())) 847 | (save-excursion 848 | (while (setq in-dfun (dyalog-in-dfun)) 849 | (push "{" dfunstack) 850 | (goto-char (plist-get in-dfun :start))) 851 | dfunstack))) 852 | 853 | (defun dyalog-indent-region (start end) 854 | "Indent every line in the current region. 855 | START and END specify the region to indent." 856 | (let ((deactivate-mark nil) 857 | (indent-info nil)) 858 | (save-excursion 859 | (goto-char end) 860 | (setq end (point-marker)) 861 | (goto-char start) 862 | (goto-char (setq start (line-beginning-position))) 863 | (forward-line -1) 864 | (setq indent-info (dyalog-calculate-indent)) 865 | (plist-put indent-info :tradfn-indent 866 | (dyalog-current-tradfn-indentation)) 867 | (plist-put indent-info :nabla-indent 868 | (dyalog-current-nabla-indent)) 869 | (when (= (point) start) 870 | ;; if start is on the first line of the buffer, we zero 871 | ;; next-indent, since we haven't actually initialized indent-info 872 | ;; with values from a previous line. 873 | (plist-put indent-info :next-indent 0)) 874 | (goto-char start) 875 | (while (< (point) end) 876 | (setq indent-info (dyalog-indent-update indent-info)) 877 | (when (bolp) 878 | (save-excursion 879 | (dyalog-indent-line-with indent-info))) 880 | (dyalog-next-logical-line)) 881 | (move-marker end nil)) 882 | nil)) 883 | 884 | (defun dyalog-indent-update (indent-info) 885 | "Calculate an updated indentation after the current logical line. 886 | INDENT-INFO is a plist of indentation information, on the same 887 | form as the return value from `dyalog-calculate-indent'. Return 888 | the updated plist of indentation information." 889 | (let* ((dfunstack (plist-get indent-info :dfunstack)) 890 | (indent-status (dyalog-indent-status dfunstack)) 891 | (label (plist-get indent-status :label-at-bol)) 892 | (current-indent nil)) 893 | (plist-put indent-info :is-comment nil) 894 | (plist-put indent-info :dfunstack (plist-get indent-status 895 | :dfunstack)) 896 | (if label 897 | (let* ((label-indent (max 0 (1- (or (plist-get indent-info 898 | :tradfn-indent) 899 | (dyalog-leading-indentation)))))) 900 | (plist-put indent-info :has-label t) 901 | (plist-put indent-info :label-indent label-indent) 902 | (setq current-indent 903 | (save-excursion 904 | (max 905 | (- (+ (skip-chars-forward "^:") 906 | (skip-chars-forward ":") 907 | (skip-chars-forward " \t")) 908 | (length label)) 909 | 0)))) 910 | (progn 911 | (plist-put indent-info :has-label nil) 912 | (setq current-indent (current-indentation)))) 913 | (setq indent-info (dyalog-indent-from-indent-type indent-status 914 | indent-info 915 | current-indent)) 916 | indent-info)) 917 | 918 | (defun dyalog-indent-from-indent-type (indent-status indent-info 919 | current-indent) 920 | "Calculate an updated indentation, disregarding any label. 921 | INDENT-STATUS is the indentation status of the current logical 922 | line (as returned by `dyalog-indent-status'). INDENT-INFO is a 923 | plist of indentation information, in the same form as the return 924 | value from `dyalog-calculate-indent'. CURRENT-INDENT is the 925 | current indentation in spaces, disregarding any label. Return the 926 | updated plist of indentation information." 927 | (let* ((indent-type (plist-get indent-status :indent-type)) 928 | (delimiter (plist-get indent-status :delimiter)) 929 | (blockstack (plist-get indent-info :blockstack)) 930 | (next-indent (or (plist-get indent-info :next-indent) 0)) 931 | (previous-indent (plist-get indent-info :indent)) 932 | (indent (+ previous-indent 933 | next-indent)) 934 | (temp-indent 0) 935 | (tradfn-indent (plist-get indent-info :tradfn-indent)) 936 | (nabla-indent (plist-get indent-info :nabla-indent)) 937 | (ret (copy-sequence indent-info))) 938 | (cond 939 | ((eq 'comment indent-type) 940 | (if (not dyalog-indent-comments) 941 | (progn 942 | (setq next-indent (- indent current-indent) 943 | indent current-indent) 944 | (plist-put ret :is-comment t)) 945 | (setq next-indent 0))) 946 | ((eq 'block-end indent-type) 947 | (progn 948 | ;; (unless (string-equal (car blockstack) 949 | ;; (dyalog-matching-delimiter delimiter)) 950 | ;; (error "Non matching delimiter")) 951 | ;; We assume delimiters match, since the region might cover 952 | ;; only part of matched delimiters 953 | (when blockstack 954 | (pop blockstack)) 955 | (setq indent (- indent tab-width) 956 | next-indent 0))) 957 | ((eq 'block-start indent-type) 958 | (progn 959 | (push delimiter blockstack) 960 | (setq next-indent tab-width))) 961 | ((eq 'block-pause indent-type) 962 | (setq indent (- indent tab-width) 963 | next-indent tab-width)) 964 | ((eq 'dfun-start indent-type) 965 | (setq next-indent tab-width)) 966 | ((eq 'dfun-end indent-type) 967 | (setq next-indent (- tab-width))) 968 | ((eq 'dfun-end-and-dedent indent-type) 969 | (setq indent (- indent tab-width) 970 | next-indent 0)) 971 | ((eq 'tradfn-end indent-type) 972 | (setq tradfn-indent nil 973 | indent (or nabla-indent indent) 974 | next-indent 0 975 | nabla-indent nil)) 976 | ((eq 'tradfn-start indent-type) 977 | (let ((nabla-at-bol (looking-at-p " *∇"))) 978 | (setq tradfn-indent (if nabla-at-bol 979 | (+ (save-excursion 980 | (skip-chars-forward "^∇") 981 | (skip-chars-forward " ∇")) 982 | indent) 983 | (save-excursion 984 | (skip-chars-forward " "))) 985 | next-indent (- tradfn-indent indent) 986 | nabla-indent (if nabla-at-bol 987 | indent 988 | previous-indent)))) 989 | ((eq 'blank indent-type) 990 | (setq next-indent indent 991 | indent 0)) 992 | ((member (downcase (or delimiter "")) '(":access" ":using")) 993 | (setq temp-indent indent 994 | indent (or tradfn-indent (- indent tab-width)) 995 | next-indent (- temp-indent indent))) 996 | ;; TODO: dfuns 997 | (t 998 | (setq next-indent 0))) 999 | (plist-put ret :blockstack blockstack) 1000 | (plist-put ret :indent indent) 1001 | (plist-put ret :next-indent next-indent) 1002 | (plist-put ret :tradfn-indent tradfn-indent) 1003 | (plist-put ret :nabla-indent nabla-indent) 1004 | ret)) 1005 | 1006 | (defun dyalog-nabla-indent () 1007 | "Return the current indentation of the nabla preceding a tradfn definition. 1008 | Assumes point is at the start of a line with a tradfn header." 1009 | (save-excursion 1010 | (if (looking-at-p "^ *∇") 1011 | (skip-chars-forward " ") 1012 | (forward-line -1) 1013 | (skip-chars-forward " ")))) 1014 | 1015 | (defun dyalog-current-nabla-indent () 1016 | "Return the indentation of the nabla preceding the tradfn defun point is in." 1017 | (let* ((info (dyalog-tradfn-info)) 1018 | (name (nth 0 info)) 1019 | (end-of-header (nth 3 info))) 1020 | (when (and name (not (equal "" name))) 1021 | (save-excursion 1022 | (goto-char end-of-header) 1023 | (beginning-of-line) 1024 | (dyalog-nabla-indent))))) 1025 | 1026 | (defun dyalog-remove-label () 1027 | "Remove the current label token at beginning of line, and return it." 1028 | (beginning-of-line) 1029 | (skip-chars-forward " \t") 1030 | (let* ((start (point)) 1031 | (end (+ start 1 (skip-chars-forward "A-Za-z_0-9"))) 1032 | (label (buffer-substring-no-properties start end))) 1033 | (delete-region start end) 1034 | (goto-char start) 1035 | label)) 1036 | 1037 | (defun dyalog-guess-buffer-type () 1038 | "Guess whether the current buffer is a function or namespace/class. 1039 | Return 'space-or-class if it looks like a namespace or class, 1040 | 'unkown if the buffer type is unknown and 'function if it looks 1041 | like a function definition." 1042 | (save-excursion 1043 | (goto-char (point-min)) 1044 | (cond 1045 | ((looking-at-p " *:") 1046 | 'space-or-class) 1047 | ((or (dyalog-on-tradfn-header) 1048 | (looking-at-p (concat " *" dyalog-name " *← *{"))) 1049 | 'function) 1050 | (t 1051 | 'unknown)))) 1052 | 1053 | (defun dyalog-fix-whitespace-before-save () 1054 | "Clean up whitespace and indent the current buffer before saving." 1055 | (when (and (eq major-mode 'dyalog-mode) dyalog-fix-whitespace-before-save) 1056 | (dyalog-fix-whitespace))) 1057 | 1058 | (defun dyalog-fix-whitespace () 1059 | "Clean up white space and indent the current buffer. 1060 | This attempts to match formatting done by Dyalog's auto format feature." 1061 | (interactive) 1062 | (let ((dyalog-indent-comments nil) 1063 | (punctuation-char "\\s.\\|\\s(\\|\\s)\\|'")) 1064 | 1065 | (save-excursion 1066 | (delete-trailing-whitespace) 1067 | ;; Reduce all runs of whitespace to a single space, except when 1068 | ;; preceeded by a newline, succeeded by a comment character, or if 1069 | ;; inside a comment or string literal 1070 | (goto-char (point-min)) 1071 | (while (re-search-forward "\\([^ \r\n]\\)\\( +\\)\\([^⍝ \r\n]\\)" (point-max) t) 1072 | (let ((ws-start (match-beginning 2))) 1073 | (unless (dyalog-in-comment-or-string ws-start) 1074 | (replace-match "\\1 \\3")))) 1075 | ;; Remove spaces before punctuation 1076 | (goto-char (point-min)) 1077 | (while (re-search-forward (concat "\\([^ \r\n]\\)" "\\( +\\)" 1078 | "\\(" punctuation-char "\\)") 1079 | (point-max) 1080 | t) 1081 | (let ((start (match-beginning 0)) 1082 | (ws-start (match-beginning 2)) 1083 | (token-start (match-beginning 1)) 1084 | (punctuation-start (match-beginning 3))) 1085 | (unless (or (string-equal "⍝" (match-string 3)) 1086 | (dyalog-in-comment-or-string ws-start) 1087 | (string-match-p "[∇⋄⍬⍺⍵]" (match-string 3)) 1088 | (string-match-p "[∇⋄⍬⍺⍵]" (match-string 1)) 1089 | (and (string-match-p "[⎕A-Za-z_∆⍺⍵⍬0-9]" (match-string 1)) 1090 | (string-match-p "\\`[⍺⍵⍬#]" (match-string 3))) 1091 | (and (string-match-p "['¯0-9]" (match-string 1)) 1092 | (string-equal "'" (match-string 3))) 1093 | (and (string-equal ":" (substring (match-string 3) 0 1)) 1094 | (not (dyalog-position-is-in-dfun punctuation-start))) 1095 | (dyalog-in-keyword token-start)) 1096 | (replace-match "\\1\\3") 1097 | (goto-char start)))) 1098 | ;; Now remove spaces after punctuation unless they are followed by a 1099 | ;; comment. We can't remove spaces both before and after punctuation in 1100 | ;; one pass because matches might overlap. 1101 | (goto-char (point-min)) 1102 | (while (re-search-forward (concat "\\(" punctuation-char "\\)" 1103 | "\\( +\\)" "\\([^⍝ \r\n]\\)") 1104 | (point-max) 1105 | t) 1106 | (let ((start (match-beginning 0)) 1107 | (ws-start (match-beginning 2)) 1108 | (match-1 (match-string 1)) 1109 | (match-3 (match-string 3)) 1110 | (match-3-start (match-beginning 3))) 1111 | (unless (or (string-equal "⍝" match-1) 1112 | (dyalog-in-comment-or-string ws-start) 1113 | (string-match-p "[∇⋄]" match-1) 1114 | (string-match-p "[∇⋄]" match-3) 1115 | (and (string-match-p "[⍺⍵⍬#]\\'" match-1) 1116 | (string-match-p "\\`[⎕A-Za-z_∆⍺⍵⍬0-9¯]" match-3)) 1117 | (and (string-equal "'" match-1) 1118 | (string-match-p "['¯0-9]" match-3)) 1119 | (and (string-equal ":" (substring match-3 0 1)) 1120 | (not (dyalog-position-is-in-dfun match-3-start)))) 1121 | (replace-match "\\1\\3") 1122 | (goto-char start)))) 1123 | (dyalog-indent-buffer)))) 1124 | 1125 | (defun dyalog-indent-buffer () 1126 | "Indent the current buffer." 1127 | (save-excursion 1128 | (indent-region (point-min) (point-max)))) 1129 | 1130 | ;;; Defun recognition and navigation 1131 | 1132 | (defun dyalog-imenu-create-index () 1133 | "Return an alist suitable for use as an imenu index for the current buffer." 1134 | (reverse (dyalog-functions-in-buffer))) 1135 | 1136 | (defun dyalog-functions-in-buffer () 1137 | "Return an alist of names and positions for defuns in the current buffer." 1138 | (save-excursion 1139 | (let ((funs ()) 1140 | (done nil) 1141 | (space-scan nil)) 1142 | (goto-char (point-min)) 1143 | (while (not done) 1144 | (setq space-scan (dyalog-update-space-scan space-scan (point))) 1145 | (let* ((info (cadr (dyalog-defun-info (/= (point) (point-min))))) 1146 | (name (plist-get info :name)) 1147 | (start (plist-get info :start)) 1148 | (current-space (dyalog-current-space space-scan (point))) 1149 | (space-name (mapconcat 'identity current-space ".")) 1150 | (full-name (if current-space 1151 | (concat space-name "." name) 1152 | name))) 1153 | (if (not (zerop (length name))) 1154 | (progn 1155 | (push (cons full-name (copy-marker start)) funs) 1156 | (goto-char (plist-get info :end)) 1157 | (setq done (unless (looking-at-p dyalog-tradfn-header) 1158 | (not (dyalog-next-defun))))) 1159 | (setq done (not (dyalog-next-defun)))))) 1160 | funs))) 1161 | 1162 | (defun dyalog-space-stack-at-pos (pos) 1163 | "Return the stack of namespaces and/or classes for position POS." 1164 | (let ((space-scan 1165 | (save-excursion 1166 | (goto-char (point-min)) 1167 | (dyalog-add-spaces-to-stack nil pos)))) 1168 | (dyalog-current-space space-scan pos))) 1169 | 1170 | (defun dyalog-update-space-scan (space-scan pos) 1171 | "Update SPACE-SCAN incrementally, given that point is at POS." 1172 | (save-excursion 1173 | (let* ((space-stack (plist-get space-scan :stack)) 1174 | (max-reached (plist-get space-scan :max-reached)) 1175 | (trimmed-stack (dyalog-trim-passed-spaces space-stack pos)) 1176 | (top (car trimmed-stack)) 1177 | (start (plist-get top :start)) 1178 | (end (plist-get top :end))) 1179 | (if (and (not end) (or (not start) (> pos start)) 1180 | (or (not max-reached) (< max-reached (point-max)))) 1181 | (progn 1182 | (goto-char (or max-reached pos)) 1183 | (dyalog-add-spaces-to-stack trimmed-stack pos)) 1184 | (list :stack trimmed-stack :max-reached max-reached))))) 1185 | 1186 | (defun dyalog-trim-passed-spaces (space-stack pos) 1187 | "Remove any spaces in SPACE-STACK that were closed before position POS." 1188 | (let ((done nil)) 1189 | (while (not done) 1190 | (let* ((top (car space-stack)) 1191 | (end (plist-get top :end))) 1192 | (if (and end (> pos end)) 1193 | (setq space-stack (cdr space-stack)) 1194 | (setq done t)))) 1195 | space-stack)) 1196 | 1197 | (defun dyalog-add-spaces-to-stack (space-stack pos) 1198 | "Add any spaces found between max reached in SPACE-STACK and POS to SPACE-STACK." 1199 | (let ((reached nil) 1200 | (done nil) 1201 | (space-scan nil) 1202 | (trimmed-stack nil)) 1203 | (while (not done) 1204 | (setq trimmed-stack (dyalog-trim-passed-spaces space-stack pos) 1205 | space-scan (dyalog-next-space-or-class trimmed-stack) 1206 | space-stack (plist-get space-scan :stack) 1207 | reached (plist-get space-scan :max-reached) 1208 | done (or (> reached pos) (= reached (point-max))))) 1209 | space-scan)) 1210 | 1211 | (defun dyalog-next-space-or-class (&optional space-stack) 1212 | "Move forward to the start or end of the next namepace or class def. 1213 | Optional argument SPACE-STACK can be used to store state between invocations." 1214 | (let ((done nil) 1215 | (ret ) 1216 | (hit nil)) 1217 | (dyalog-skip-comment-or-string) 1218 | (while (not done) 1219 | (if (setq hit (re-search-forward 1220 | (concat ":\\(End\\(Namespace\\|Class\\)\\)\\|" 1221 | "\\(\\(Namespace\\|Class\\) +" 1222 | "\\(" dyalog-name "\\)\\)") nil 'no-errors)) 1223 | (setq done (not (dyalog-in-comment-or-string))) 1224 | (setq done t))) 1225 | (setq ret 1226 | (if hit 1227 | (let* ((space-name (match-string-no-properties 5)) 1228 | (endword (match-string-no-properties 1)) 1229 | (startword (match-string-no-properties 4)) 1230 | (pos (match-end 0)) 1231 | (start-type (when startword 1232 | (dyalog-type-char-to-symbol (aref startword 0)))) 1233 | (end-type (when endword 1234 | (dyalog-type-char-to-symbol (aref endword 3))))) 1235 | (if (and space-name hit) 1236 | (let ((hit 1237 | (list :name space-name :start pos :type start-type))) 1238 | (push hit space-stack) 1239 | (list :stack space-stack :max-reached pos)) 1240 | (if space-stack 1241 | (let* ((top (car space-stack)) 1242 | (type (plist-get top :type))) 1243 | (if (equal type end-type) 1244 | (progn 1245 | (plist-put top :end pos) 1246 | (list :stack (cons top (cdr space-stack)) 1247 | :max-reached pos)) 1248 | (list :stack space-stack :max-reached pos))) 1249 | (list :stack space-stack :max-reached (point))))) 1250 | (list :stack space-stack :max-reached (point)))) 1251 | ret)) 1252 | 1253 | (defun dyalog-type-char-to-symbol (type-char) 1254 | "Given a TYPE-CHAR defininf a type, return the corresponding symbol." 1255 | (cond 1256 | ((= type-char ?N) 1257 | 'namespace) 1258 | ((= type-char ?C) 1259 | 'class))) 1260 | 1261 | (defun dyalog-current-space (space-scan pos) 1262 | "Given a SPACE-SCAN and position POS, return the current namespace POS is in. 1263 | SPACE-SCAN is created by calling `dyalog-update-space-scan`." 1264 | (let ((stack (plist-get space-scan :stack)) 1265 | (space nil)) 1266 | (while stack 1267 | (let* ((top (car stack)) 1268 | (name (plist-get top :name)) 1269 | (start (plist-get top :start)) 1270 | (end (plist-get top :end))) 1271 | (if (and end (> pos end)) 1272 | (setq stack ()) 1273 | (when (and (> pos start) (or (not end) (< pos end))) 1274 | (push name space)) 1275 | (setq stack (cdr stack))))) 1276 | space)) 1277 | 1278 | 1279 | (defun dyalog-beginning-of-dfun () 1280 | "Move backward to the beginning of a dynamic function definition. 1281 | Assumes that point is within a dynamic function definition." 1282 | (dyalog-skip-comment-or-string) 1283 | (with-syntax-table dyalog-dfun-syntax-table 1284 | (condition-case nil 1285 | (goto-char (scan-lists (point) -1 1)) 1286 | (scan-error nil)))) 1287 | 1288 | (defun dyalog-previous-defun (&optional tradfn-only) 1289 | "Move backward to the start of a function definition. 1290 | If TRADFN-ONLY is t, only consider traditional function definitions. 1291 | Return t if a function definition was found, otherwise return nil." 1292 | ;; Point can be anywhere when this function is called 1293 | (let ((done nil) 1294 | (first-hit nil) 1295 | (found nil) 1296 | (start (point)) 1297 | (dfun-info (dyalog-in-dfun))) 1298 | (if dfun-info 1299 | (progn 1300 | (goto-char (plist-get dfun-info :start)) 1301 | t) 1302 | (while (not done) 1303 | (skip-chars-backward (if tradfn-only "^∇" "^∇{}")) 1304 | (if (or (bobp) (not (dyalog-in-comment-or-string))) 1305 | (progn 1306 | (setq done t) 1307 | (if (and (dyalog-on-tradfn-header 'only-after-nabla) (not (dyalog-in-dfun))) 1308 | (progn 1309 | (skip-chars-backward "^∇") 1310 | (ignore-errors (backward-char)) 1311 | (setq first-hit nil 1312 | found t)) 1313 | (let ((before (char-before))) 1314 | (cond 1315 | ((eq before ?{) 1316 | (backward-char) 1317 | (if (not first-hit) 1318 | (setq first-hit (point))) 1319 | (setq done nil)) 1320 | ((eq before ?}) 1321 | (backward-sexp) 1322 | (if (not first-hit) 1323 | (setq first-hit (point))) 1324 | (setq done nil)) 1325 | ((eq before ?∇) 1326 | (backward-char) 1327 | (if first-hit 1328 | (progn 1329 | (setq found t 1330 | done t) 1331 | (goto-char first-hit)) 1332 | (setq done nil))) 1333 | ((bobp) 1334 | (when first-hit 1335 | (setq found t) 1336 | (goto-char first-hit))))))) 1337 | (ignore-errors (backward-char)))) 1338 | (and found (not (= (point) start)))))) 1339 | 1340 | (defun dyalog-next-defun (&optional limit) 1341 | "Move to the beginning of the next defun. 1342 | If supplied, LIMIT limits the search." 1343 | (let ((lim (or limit (point-max))) 1344 | (done nil) 1345 | (found nil)) 1346 | (when (looking-at "[{∇]") 1347 | (ignore-errors (forward-char))) 1348 | (while (not done) 1349 | (skip-chars-forward "^∇{" lim) 1350 | (cond 1351 | ((>= (point) lim) 1352 | (setq found nil 1353 | done t)) 1354 | ((dyalog-in-comment-or-string) 1355 | (ignore-errors (forward-char))) 1356 | ((and (dyalog-on-tradfn-header 'only-after-nabla) (not (dyalog-in-dfun))) 1357 | (setq found t 1358 | done t)) 1359 | (t 1360 | (cond 1361 | ((looking-at "{") 1362 | (setq found t 1363 | done t)) 1364 | ((looking-at "∇") 1365 | (ignore-errors (forward-char))))))) 1366 | found)) 1367 | 1368 | (defun dyalog-beginning-of-defun (&optional arg) 1369 | "Move backward to the beginning of a function definition. 1370 | If supplied, ARG moves that many defuns back." 1371 | (interactive "^p") 1372 | (unless arg (setq arg 1)) 1373 | (if (< arg 0) 1374 | (while (< arg 0) 1375 | (dyalog-next-defun) 1376 | (cl-incf arg)) 1377 | (while (> arg 0) 1378 | (dyalog-previous-defun) 1379 | (cl-decf arg)))) 1380 | 1381 | (defun dyalog-end-of-defun (&optional bound) 1382 | "Move forward to the end of a function definition. 1383 | If it is supplied, BOUND limits the search." 1384 | ;; We can assume point is at the start of a defun when 1385 | ;; this function is called. 1386 | (let ((end (or bound (point-max))) 1387 | (done nil) 1388 | (dfun-mode 1389 | (and (looking-at "{") 1390 | (not (dyalog-on-tradfn-header 'only-after-nabla))))) 1391 | (if dfun-mode 1392 | (condition-case nil 1393 | (forward-sexp) 1394 | (scan-error (goto-char end))) 1395 | (ignore-errors (forward-char)) ; skip past nabla 1396 | (while (not done) 1397 | (if (not (re-search-forward "^ *∇" end t)) 1398 | (progn 1399 | (goto-char end) 1400 | (setq done t)) 1401 | (when (setq done (not (dyalog-in-dfun))) 1402 | (ignore-errors (backward-char 1)) 1403 | (if (looking-at dyalog-tradfn-header) 1404 | (ignore-errors (backward-char 1)) 1405 | (ignore-errors (forward-char 1))))))))) 1406 | 1407 | (defun dyalog-end-of-tradfn (&optional bound) 1408 | "Move forward to the end of the function definition starting at point. 1409 | If it is supplied, BOUND limits the search." 1410 | (let ((end (or bound (point-max))) 1411 | (done nil)) 1412 | (ignore-errors (forward-char)) ; skip past nabla 1413 | (while (not done) 1414 | (skip-chars-forward "^{∇" end) 1415 | (cond 1416 | ((dyalog-in-comment-or-string) 1417 | (ignore-errors (forward-char))) 1418 | ((eq (char-after) ?{) 1419 | (condition-case nil 1420 | (forward-sexp) 1421 | (scan-error (goto-char end)))) 1422 | ((eq (char-after) ?∇) 1423 | (if (save-excursion 1424 | (goto-char (line-beginning-position)) 1425 | (looking-at-p "^ *∇")) 1426 | (setq done t) 1427 | (forward-char))) 1428 | (t 1429 | (ignore-errors (forward-char)))) 1430 | (setq done (or done (>= (point) end)))))) 1431 | 1432 | (defun dyalog-skip-comment-or-string (&optional context) 1433 | "If point is in a comment or string, move backward out of it. 1434 | CONTEXT is the result of `syntax-ppss' at point, or nil." 1435 | (let ((ctx (syntax-ppss-context (or context (syntax-ppss))))) 1436 | (cond 1437 | ((eq ctx 'string) (re-search-backward "\\s\"")) 1438 | ((eq ctx 'comment) (re-search-backward "\\s<"))))) 1439 | 1440 | (defun dyalog-dfun-name () 1441 | "If point is inside a dynamic function return the functions name. 1442 | If point is inside an anonymous function, return \"\", and if it 1443 | isn't inside a dynamic function, return nil" 1444 | (interactive) 1445 | (plist-get (dyalog-dfun-info) :name)) 1446 | 1447 | 1448 | (defun dyalog-dfun-info (&optional point-is-at-dfun-start) 1449 | "Return the name, start and end position of the dfun point is in. 1450 | If POINT-IS-AT-DFUN-START is t, point must be at the nabla or 1451 | brace starting the defun, and no backwards search for the 1452 | function definition start is made, which improves performance. 1453 | The return value is a plist with :name, :start and :end 1454 | properties. If point isn't inside a dfun, return nil. If the dfun 1455 | is open (i.e. has no closing brace, :end is nil. If the dfun is 1456 | anonymous, :name is \"\"." 1457 | (save-excursion 1458 | (let ((in-dfun (dyalog-in-dfun point-is-at-dfun-start)) 1459 | (dfun-name nil)) 1460 | (if in-dfun 1461 | (progn 1462 | (goto-char (plist-get in-dfun :start)) 1463 | (setq dfun-name 1464 | (if (looking-back (concat "\\_<\\(" dyalog-name "\\) *← *") 1465 | (line-beginning-position) 1466 | t) 1467 | (match-string-no-properties 1) 1468 | "")) 1469 | (setq dfun-name 1470 | (condition-case nil 1471 | (progn 1472 | (forward-sexp) 1473 | (if (looking-at-p " *[^\r\n ⋄⍝]") 1474 | "" 1475 | dfun-name)) 1476 | (scan-error dfun-name))) 1477 | (plist-put in-dfun :name dfun-name) 1478 | in-dfun) 1479 | nil)))) 1480 | 1481 | (defun dyalog-position-of-open-brace () 1482 | "If point is inside open braces, return the position of the opening brace." 1483 | (let ((done nil) 1484 | (pos nil)) 1485 | (save-excursion 1486 | (while (not done) 1487 | (let* ((state (syntax-ppss)) 1488 | (start-of-containing-parens (nth 1 state))) 1489 | (if start-of-containing-parens 1490 | (if (eq (char-after start-of-containing-parens) ?{) 1491 | (setq pos start-of-containing-parens 1492 | done t) 1493 | (setq done (= (point) (point-min))) 1494 | (goto-char start-of-containing-parens)) 1495 | (setq done t)))) 1496 | pos))) 1497 | 1498 | (defun dyalog-in-dfun (&optional point-is-at-dfun-start) 1499 | "If point is inside a dfun, return a plist with it's start and end position. 1500 | If point isn't inside a dfun, return nil. If optional argument 1501 | POINT-IS-AT-DFUN-START is t, point must be at the opening brace 1502 | of a dfun. Supplying POINT-IS-AT-DFUN-START improves 1503 | performance." 1504 | (progn ;; with-syntax-table can't be at defun top-level apparently... 1505 | (if (and point-is-at-dfun-start (looking-at-p "{")) 1506 | (list :start (point) 1507 | :end (save-excursion 1508 | (condition-case nil 1509 | (progn 1510 | (forward-sexp) 1511 | (point)) 1512 | (scan-error nil)))) 1513 | (let* ((pos (point)) 1514 | (start-of-containing-parens (dyalog-position-of-open-brace))) 1515 | (if start-of-containing-parens 1516 | (save-excursion 1517 | (goto-char start-of-containing-parens) 1518 | (if (not (dyalog-on-tradfn-header 'only-after-nabla)) 1519 | (let ((end (condition-case nil 1520 | (progn 1521 | (forward-sexp) 1522 | (point)) 1523 | (scan-error nil)))) 1524 | (unless (or (< pos start-of-containing-parens) 1525 | (and end (<= end pos))) 1526 | ;; Sometimes, when syntax-ppss is called during 1527 | ;; jit-lock, it breaks and gives erronous results, 1528 | ;; saying we are inside parens when we are not. We 1529 | ;; detect this by checking if the the sexp we're 1530 | ;; supposed to be in ends before, or begins after the 1531 | ;; position we started parsing at. 1532 | (list :start start-of-containing-parens 1533 | :end end))) 1534 | nil)) 1535 | nil))))) 1536 | 1537 | (defun dyalog-position-is-in-dfun (pos) 1538 | "Return true if position POS is inside a dfun." 1539 | (save-excursion 1540 | (goto-char pos) 1541 | (dyalog-in-dfun))) 1542 | 1543 | (defun dyalog-current-defun () 1544 | "Return the name of the defun point is in." 1545 | (let ((dfun-name (dyalog-dfun-name))) 1546 | (or dfun-name (car (dyalog-tradfn-info))))) 1547 | 1548 | (defun dyalog-on-tradfn-header (&optional only-after-nabla) 1549 | "Return t if point is on a tradfn header line, otherwise return nil. 1550 | If ONLY-AFTER-NABLA is t, only return t when point is after 1551 | the nabla in the tradfn header." 1552 | (save-excursion 1553 | (let ((start (point)) 1554 | (min (line-beginning-position)) 1555 | (max (progn 1556 | (forward-line) 1557 | (line-end-position)))) 1558 | (goto-char min) 1559 | (if (re-search-forward dyalog-tradfn-header max t) 1560 | (let ((end-char (match-end 0)) 1561 | (start-char (match-beginning 0))) 1562 | (goto-char end-char) 1563 | (and (>= start (if only-after-nabla 1564 | start-char 1565 | (min start-char 1566 | (line-beginning-position)))) 1567 | (<= start (line-end-position)) 1568 | (not (dyalog-in-comment-or-string start-char)))) 1569 | nil)))) 1570 | 1571 | (defun dyalog-tradfn-info (&optional point-is-at-start-of-defun) 1572 | "Return a list of information on the tradfn defun point is in. 1573 | This name is only valid if point isn't inside a dfn. The list 1574 | contains the name of the function a list containing the names of 1575 | the arguments, a list containing localized names, the character 1576 | position where the function header ends and the character 1577 | position where the defun ends. If POINT-IS-AT-START-OF-DEFUN is 1578 | t, point must be at the nabla starting the tradfn definition, and 1579 | no search for the function definition start is made, which 1580 | improves performance." 1581 | (save-excursion 1582 | (let ((start-pos (point)) 1583 | (on-tradfn-header 1584 | (if point-is-at-start-of-defun 1585 | (looking-at dyalog-tradfn-header) 1586 | (dyalog-previous-defun 'tradfn-only) 1587 | (when (not (looking-at "∇")) 1588 | (forward-line -1)) ; Nabla is on its own line 1589 | (re-search-forward dyalog-tradfn-header nil t)))) 1590 | (if on-tradfn-header 1591 | (let* ((start-of-defun (match-beginning 0)) 1592 | (tradfn-name (match-string-no-properties 1)) 1593 | (retval (save-match-data 1594 | (split-string (or (match-string-no-properties 2) "")))) 1595 | (larg (match-string-no-properties 3)) 1596 | (rarg (save-match-data 1597 | (split-string (or (match-string-no-properties 4) "")))) 1598 | (localstart (match-end 5)) 1599 | (left-operand (match-string-no-properties 6)) 1600 | (tradop-name (match-string-no-properties 7)) 1601 | (right-operand (match-string-no-properties 8)) 1602 | (name (or tradop-name tradfn-name)) 1603 | (end-of-header (save-excursion 1604 | (goto-char (match-end 0)) 1605 | (line-end-position))) 1606 | (args (list retval (when larg (list larg)) rarg)) 1607 | (operands (remq nil (list left-operand right-operand))) 1608 | (locals nil) 1609 | (end-of-defun 0)) 1610 | (dyalog-end-of-tradfn) 1611 | (setq end-of-defun (point)) 1612 | (if (or (< end-of-defun start-pos) (< start-pos start-of-defun)) 1613 | (list "" nil nil 0 0 0 nil) 1614 | (progn 1615 | (setq locals 1616 | (split-string 1617 | (buffer-substring-no-properties localstart end-of-header) 1618 | "[; ]" 'omit-nulls)) 1619 | (list name args locals end-of-header end-of-defun 1620 | start-of-defun operands)))) 1621 | (list "" nil nil 0 0 0 nil))))) 1622 | 1623 | ;;; Font Lock 1624 | 1625 | (defun dyalog-defun-info (&optional point-is-at-start-of-defun) 1626 | "Return information on the defun at point. 1627 | If POINT-IS-AT-START-OF-DEFUN is t, point must be at the nabla 1628 | or brace starting the defun, and no backwards search for the 1629 | function definition start is made, which improves performance." 1630 | (save-excursion 1631 | (if (and point-is-at-start-of-defun 1632 | (not (looking-at-p "[{∇]"))) 1633 | (list 'tradfn (list "" nil nil 0 0 0 nil)) 1634 | (when (and (not point-is-at-start-of-defun) (looking-at-p "{")) 1635 | (forward-char)) 1636 | (let ((dfun-info (dyalog-dfun-info point-is-at-start-of-defun))) 1637 | (if dfun-info 1638 | (list 'dfun dfun-info) 1639 | (list 'tradfn 1640 | (progn 1641 | (unless point-is-at-start-of-defun 1642 | (ignore-errors (forward-char))) 1643 | (let* ((info 1644 | (dyalog-tradfn-info point-is-at-start-of-defun)) 1645 | (start (nth 5 info)) 1646 | (name (car info)) 1647 | (args (nth 1 info)) 1648 | (locals (nth 2 info)) 1649 | (end-of-header (nth 3 info)) 1650 | (end (nth 4 info)) 1651 | (operands (nth 6 info))) 1652 | (list :start start :name name :args args 1653 | :locals locals :end-of-header end-of-header 1654 | :end end :operands operands))))))))) 1655 | 1656 | (defun dyalog-local-names (defun-info) 1657 | "Return a list of local names given DEFUN-INFO. 1658 | DEFUN-INFO is the return value from `dyalog-defun-info'." 1659 | (let ((args (apply 'append (plist-get defun-info :args))) 1660 | (operands (plist-get defun-info :operands)) 1661 | (localizations (plist-get defun-info :locals))) 1662 | (append args operands localizations))) 1663 | 1664 | (defun dyalog-fontify-dfun (dfun-info start end) 1665 | "Fontify the dynamic function defined by DFUN-INFO. 1666 | START and END delimit the region to fontify." 1667 | (when dfun-info 1668 | (let* ((dfunstart (plist-get dfun-info :start)) 1669 | (dfunend (plist-get dfun-info :end)) 1670 | (rx (concat "\\_<\\(" dyalog-name "\\)\\_>")) 1671 | (limit (min (or dfunend end) end))) 1672 | (goto-char (max dfunstart start)) 1673 | (while (re-search-forward rx limit t) 1674 | (let* ((symbol-start (match-beginning 0)) 1675 | (symbol-end (match-end 0)) 1676 | (state (syntax-ppss)) 1677 | (context (syntax-ppss-context state)) 1678 | (in-string (eq 'string context)) 1679 | (in-comment (eq 'comment context)) 1680 | (sysvar (eq ?⎕ (char-after symbol-start))) 1681 | (face (if sysvar 1682 | 'dyalog-local-system-name 1683 | 'dyalog-local-name))) 1684 | (unless (or in-string in-comment) 1685 | (put-text-property symbol-start symbol-end 1686 | 'face 1687 | face) 1688 | (put-text-property symbol-start symbol-end 1689 | 'fontified 1690 | t)))) 1691 | (goto-char (min (or dfunend end) end))))) 1692 | 1693 | (defun dyalog-fontify-tradfn (info start end) 1694 | "Fontify the traditional function defined by INFO. 1695 | START and END delimit the region to fontify." 1696 | (let ((fname (plist-get info :name))) 1697 | (when (and fname (not (equal fname ""))) 1698 | (let* ((locals (dyalog-local-names info)) 1699 | (end-of-header (plist-get info :end-of-header)) 1700 | (end-of-defun (plist-get info :end)) 1701 | (limit (min end-of-defun end)) 1702 | (rx (concat "\\_<\\(" 1703 | (mapconcat 'identity locals "\\|") 1704 | "\\)\\_>")) 1705 | (fontify-start (max end-of-header start))) 1706 | (goto-char fontify-start) 1707 | (while (re-search-forward rx limit t) 1708 | (let* ((symbol-start (match-beginning 0)) 1709 | (symbol-end (match-end 0)) 1710 | (sysvar (eq ?⎕ (char-after symbol-start))) 1711 | (face (if sysvar 1712 | 'dyalog-local-system-name 1713 | 'dyalog-local-name))) 1714 | (unless (dyalog-in-comment-or-string) 1715 | (put-text-property symbol-start symbol-end 1716 | 'face 1717 | face) 1718 | (put-text-property symbol-start symbol-end 1719 | 'fontified 1720 | t) 1721 | (while (and (equal ?. (char-after symbol-end)) 1722 | (looking-at (concat "\\." dyalog-name))) 1723 | (put-text-property (match-beginning 0) 1724 | (match-end 0) 1725 | 'face 1726 | face) 1727 | (put-text-property (match-beginning 0) 1728 | (match-end 0) 1729 | 'fontified 1730 | t) 1731 | (goto-char (match-end 0)) 1732 | (setq symbol-end (point)))))) 1733 | ;; Now we need to fontify any names inside dfns defined inside this 1734 | ;; tradfn 1735 | (goto-char fontify-start) 1736 | (while (< (point) limit) 1737 | (dyalog-next-defun limit) 1738 | (when (eq (char-after) ?{) ; we are at a dfun 1739 | (let* ((all-info (dyalog-defun-info t)) 1740 | (info (cadr all-info))) 1741 | (dyalog-fontify-dfun info start limit)))) 1742 | (goto-char limit))))) 1743 | 1744 | (defun dyalog-fontify-locals-matcher (limit) 1745 | "Font-lock mathcer to fontify local names. 1746 | LIMIT limits the extents of the search for local names to 1747 | fontify. Note that this function always returns nil and leaves 1748 | point at limit, since it sets font-lock faces on its own and 1749 | doesn't need the general font-lock machinery to set faces." 1750 | (dyalog-fontify-locals (point) limit) 1751 | nil) 1752 | 1753 | (defun dyalog-fontify-locals (start end) 1754 | "Fontify local names in tradfns. 1755 | START and END signify the region to fontify." 1756 | (save-excursion 1757 | (let* ((beg-line (progn (goto-char start)(line-beginning-position))) 1758 | (case-fold-search nil) 1759 | (all-info nil) 1760 | (type nil) 1761 | (info nil) 1762 | (at-start-of-defun nil)) 1763 | (goto-char beg-line) 1764 | (while (< (point) end) 1765 | (setq all-info (dyalog-defun-info at-start-of-defun) 1766 | type (car all-info) 1767 | info (cadr all-info)) 1768 | (if (eq type 'dfun) 1769 | (progn 1770 | (dyalog-fontify-dfun info (point) end) 1771 | (setq at-start-of-defun nil)) 1772 | (if (equal "" (plist-get info :name)) 1773 | ;; We are between tradfn definitions, skip to next function 1774 | (setq at-start-of-defun (dyalog-next-defun)) 1775 | (dyalog-fontify-tradfn info (point) end) 1776 | (setq at-start-of-defun nil))))))) 1777 | 1778 | ;;; Syntax 1779 | 1780 | (defun dyalog-syntax-propertize-function (start end) 1781 | "Alter syntax table for escaped single quotes within strings. 1782 | START and END delimit the region to analyze." 1783 | (save-excursion 1784 | (goto-char start) 1785 | (while (and 1786 | (search-forward "''" end 'no-error) 1787 | (< (point) end)) 1788 | (goto-char (match-beginning 0)) 1789 | (let* ((endpos (match-end 0)) 1790 | (in-string (nth 3 (syntax-ppss)))) 1791 | (when in-string 1792 | (put-text-property (point) (+ 2 (point)) 1793 | 'syntax-table 1794 | (string-to-syntax "."))) 1795 | (goto-char endpos))))) 1796 | 1797 | (defun dyalog-current-keyword (&optional pt in-dfun) 1798 | "Return the current keyword and if the keyword is preceded by a label. 1799 | PT is optional and defaults to point and determines where to look 1800 | for the keyword. If PT isn't in a keyword, return nil. If 1801 | provided, IN-DFUN is t if PT is inside a dynamic function. If it 1802 | is not provided, it is computed, which takes some time, so 1803 | providing it is an optimization. Return a two element list with 1804 | the keyword (or nil) and t if it is preceded by a label." 1805 | (save-excursion 1806 | (when pt 1807 | (goto-char pt)) 1808 | (skip-chars-backward "A-Za-z:") 1809 | (skip-syntax-backward "-") 1810 | (when (eq (char-before) ?⋄) 1811 | (backward-char)) 1812 | (when (and 1813 | (not (bolp)) 1814 | (looking-back dyalog-label-regex (line-beginning-position))) 1815 | (beginning-of-line)) 1816 | (pcase-let ((`(,keyword ,label-at-bol) 1817 | (if (or (looking-at dyalog-keyword-regex) 1818 | (looking-at dyalog-middle-keyword-regex)) 1819 | (list (match-string-no-properties 2) 1820 | (not (not (match-string 5)))) 1821 | nil))) 1822 | (if (and keyword (or in-dfun (dyalog-in-dfun))) 1823 | (list nil nil) 1824 | (list keyword label-at-bol))))) 1825 | 1826 | (defun dyalog-in-keyword (&optional pt) 1827 | "Return t if PT (defaults to point) is inside a keyword (e.g. :If)." 1828 | (not (not (car (dyalog-current-keyword (or pt (point))))))) 1829 | 1830 | (defun dyalog-in-comment-or-string (&optional pt) 1831 | "Return t if PT (defaults to point) is inside a string literal or a comment." 1832 | (save-excursion 1833 | (when pt 1834 | (goto-char pt)) 1835 | (save-match-data 1836 | (let ((state (parse-partial-sexp (line-beginning-position) (point)))) 1837 | (not (not (or (nth 3 state) (nth 4 state)))))))) 1838 | 1839 | (defun dyalog-current-symbol () 1840 | "Return the full symbol at point, including namespace qualifications." 1841 | (let* ((regex "\\(\\s_\\|\\sw\\|\\.\\)")) 1842 | (when (looking-at-p regex) 1843 | (buffer-substring-no-properties 1844 | (save-excursion 1845 | (while (looking-back regex (1- (point))) 1846 | (backward-char)) 1847 | (point)) 1848 | (save-excursion 1849 | (while (looking-at-p regex) 1850 | (ignore-errors (forward-char))) 1851 | (point)))))) 1852 | 1853 | (defun dyalog-symbol-parts (symbol-name) 1854 | "Return a list of all the parts of SYMBOL-NAME. 1855 | For example, for \"ns1.ns2.name\", return '(\"ns1\" \"ns2\" \"name\"). 1856 | If there are no parts, just return the name as given." 1857 | (split-string symbol-name "\\." 'omit-nulls)) 1858 | 1859 | (defun dyalog-symbol-root (symbol-name) 1860 | "Return the root namespace SYMBOL-NAME, or nil if there is none." 1861 | (let ((parts (dyalog-symbol-parts symbol-name))) 1862 | (when (< 1 (length parts)) 1863 | (car parts)))) 1864 | 1865 | 1866 | ;;; Go to definition 1867 | 1868 | (defvar dyalog-goto-definition-functions 1869 | '(dyalog-goto-definition-local 1870 | dyalog-goto-definition-single-file 1871 | dyalog-goto-definition-var) 1872 | "A list of functions to call to go to the definition of a symbol. 1873 | Each function receives the name of the symbol and the current 1874 | space as arguments and should go to the definition and return t 1875 | if it knows where the symbol is defined.") 1876 | 1877 | (defvar dyalog-symbol-to-filename-function 1878 | 'dyalog-default-symbol-to-filename 1879 | "A function to call to translate a symbol name to a filename.") 1880 | 1881 | (defvar dyalog-goto-definition-prefer-other-window 1882 | nil 1883 | "Bind this to 'other-window if you want to show a definition in another window.") 1884 | 1885 | (defun dyalog-default-symbol-to-filename (name) 1886 | "Translate APL symbol NAME to a filename, by just appending \".apl\"." 1887 | (concat default-directory name ".apl")) 1888 | 1889 | (defun dyalog-symbol-to-filename (name) 1890 | "Translate APL symbol NAME to a filename. 1891 | If `dyalog-symbol-to-filename-function` is defined, call that, 1892 | otherwise use `dyalog-default-symbol-to-filename`." 1893 | (funcall dyalog-symbol-to-filename-function name)) 1894 | 1895 | (defun dyalog-goto-file-line (symbol-name file line) 1896 | "Go to the definition of SYMBOL-NAME in FILE at LINE." 1897 | (let* ((the-file (or file (dyalog-symbol-to-filename symbol-name))) 1898 | (buffer (find-buffer-visiting the-file)) 1899 | (window (when buffer (get-buffer-window buffer)))) 1900 | (when window 1901 | (select-window window)) 1902 | (dyalog-edit-name symbol-name file line dyalog-goto-definition-prefer-other-window))) 1903 | 1904 | (defun dyalog-goto-marker-definition (marker &optional dont-reposition) 1905 | "Goto definition of name as defined in MARKER." 1906 | (let* ((buffer (marker-buffer marker)) 1907 | (window (when buffer (get-buffer-window buffer)))) 1908 | (cond 1909 | ((and window (not (eq (current-buffer) buffer))) 1910 | (select-window window)) 1911 | (dyalog-goto-definition-prefer-other-window 1912 | (switch-to-buffer-other-window buffer)) 1913 | (t 1914 | (switch-to-buffer buffer))) 1915 | (goto-char marker) 1916 | (unless dont-reposition 1917 | (reposition-window)))) 1918 | 1919 | (defun dyalog-goto-definition () 1920 | "Visit the definition of the symbol at point." 1921 | (interactive) 1922 | (let ((name (dyalog-current-symbol)) 1923 | (current-space (dyalog-space-stack-at-pos (point)))) 1924 | (unless (or (not name) 1925 | (dyalog-in-keyword)) 1926 | (if (fboundp 'xref-push-marker-stack) 1927 | (xref-push-marker-stack) 1928 | (ring-insert find-tag-marker-ring (point-marker))) 1929 | (let ((found nil) 1930 | (hit nil)) 1931 | (cl-loop for func in dyalog-goto-definition-functions 1932 | do 1933 | (setq hit (funcall func name current-space) 1934 | found (not (not hit))) 1935 | (when hit 1936 | (if (markerp hit) 1937 | (dyalog-goto-marker-definition hit) 1938 | (let ((file (plist-get hit :file)) 1939 | (line (plist-get hit :line)) 1940 | (symbol-name (or (plist-get hit :symbol) name)) 1941 | (marker (plist-get hit :marker)) 1942 | (dont-reposition (plist-get hit :dont-reposition))) 1943 | (if marker 1944 | (dyalog-goto-marker-definition marker dont-reposition) 1945 | (dyalog-goto-file-line symbol-name file line))))) 1946 | until found) 1947 | (if found 1948 | t 1949 | (pop-tag-mark) 1950 | (error "Cannot find definition for %s" name)))))) 1951 | 1952 | (defun dyalog-goto-definition-other-window () 1953 | "Visit the definition of the symbol at point, in another window." 1954 | (interactive) 1955 | (let ((dyalog-goto-definition-prefer-other-window 'other-window)) 1956 | (dyalog-goto-definition))) 1957 | 1958 | (defun dyalog-search-token (regex &optional bound) 1959 | "Search for REGEX, ignore use inside comments and strings. 1960 | Optional argument BOUND bounds search." 1961 | (let ((done nil) 1962 | (found nil)) 1963 | (while (not done) 1964 | (if (re-search-forward regex bound t) 1965 | (setq done (not (dyalog-in-comment-or-string)) 1966 | found done) 1967 | (setq done t))) 1968 | found)) 1969 | 1970 | (defun dyalog-search-symbol (symbol-name &optional bound) 1971 | "Search for a use of SYMBOL-NAME, ignore use inside comments and strings. 1972 | Optional argument BOUND bounds the search." 1973 | (let ((regex (concat "\\_<" 1974 | (regexp-quote symbol-name) 1975 | "\\_>"))) 1976 | (dyalog-search-token regex bound))) 1977 | 1978 | (defun dyalog-goto-definition-var (symbol-name &optional _current-space) 1979 | "Move to the first occurence of SYMBOL-NAME within the current defun." 1980 | (let* ((in-dfun (dyalog-in-dfun)) 1981 | (tradfn-info (dyalog-tradfn-info)) 1982 | (tradfn-args (append (nth 1 tradfn-info) (nth 6 tradfn-info))) 1983 | (tradfn-locals (nth 2 tradfn-info)) 1984 | (header-end (nth 3 tradfn-info)) 1985 | (tradfn-end (nth 4 tradfn-info)) 1986 | (start (point))) 1987 | (save-excursion 1988 | (push-mark) 1989 | (if in-dfun 1990 | (let* ((dfun-start (plist-get in-dfun :start)) 1991 | (dfun-max (max (plist-get in-dfun :end) dfun-start))) 1992 | (goto-char dfun-start) 1993 | (unless (dyalog-search-token (concat "\\_<" symbol-name "←") dfun-max) 1994 | (pop-mark) 1995 | (goto-char start) 1996 | nil)) 1997 | (cond 1998 | ((member (or (dyalog-symbol-root symbol-name) symbol-name) 1999 | tradfn-locals) 2000 | (dyalog-beginning-of-defun) 2001 | (goto-char header-end) 2002 | (unless (dyalog-search-symbol symbol-name tradfn-end) 2003 | (pop-mark) 2004 | (goto-char start))) 2005 | ((member symbol-name tradfn-args) 2006 | (dyalog-beginning-of-defun) 2007 | (unless (dyalog-search-symbol symbol-name header-end) 2008 | (pop-mark) 2009 | (goto-char start))))) 2010 | (when (not (eq (point) start)) 2011 | (list :marker (point-marker) :dont-reposition t))))) 2012 | 2013 | (defun dyalog-goto-definition-local (symbol-name &optional current-space) 2014 | "If SYMBOL-NAME is defined as a function in the current buffer, move there. 2015 | If CURRENT-SPACE is non-nil, it is the name space the reference 2016 | SYMBOL-NAME is in and is used to create a qualified name for the 2017 | symbol. A name a inside space b.c can reference either a local 2018 | name a or b.c.a." 2019 | (when (not (fboundp 'imenu--make-index-alist)) 2020 | (require 'imenu)) 2021 | (let* ((alist (condition-case nil 2022 | (imenu--make-index-alist) 2023 | (imenu-unavailable nil))) 2024 | (qualified-name (when current-space 2025 | (mapconcat 'identity (append current-space (list symbol-name)) 2026 | "."))) 2027 | (definition (or (assoc symbol-name alist) 2028 | (assoc qualified-name alist))) 2029 | (found (and alist definition))) 2030 | (when found 2031 | (cdr definition)))) 2032 | 2033 | (defun dyalog-goto-definition-single-file (symbol-name &optional _current-space) 2034 | "If SYMBOL-NAME is a global function, visit the file it's defined in." 2035 | (let* ((name (car (last (dyalog-symbol-parts symbol-name)))) 2036 | (filename (dyalog-symbol-to-filename name))) 2037 | (if (file-exists-p filename) 2038 | (list :file filename)))) 2039 | 2040 | (defvar dyalog-symbol-preferred-window 2041 | () 2042 | "Stack of preferred window to show edit in.") 2043 | 2044 | (defun dyalog-edit-name (symbol-name &optional file line other-window) 2045 | "Edit SYMBOL-NAME (found in FILE) and optionally move point to LINE. 2046 | If OTHER-WINDOW is 'other-window, try to show SYMBOL-NAME in 2047 | another window than the current one. If OTHER-WINDOW is a window, 2048 | show the symbol in that specific window. If an active connection 2049 | to Dyalog exists, use that to get the source, otherwise fetch it 2050 | from disk." 2051 | (let ((conn (dyalog-editor-buffer-connected)) 2052 | (filename (or file (dyalog-symbol-to-filename symbol-name)))) 2053 | (if conn 2054 | (progn 2055 | (when other-window 2056 | (push other-window dyalog-symbol-preferred-window)) 2057 | (dyalog-editor-edit symbol-name line)) 2058 | (if other-window 2059 | (find-file-other-window filename) 2060 | (find-file filename)) 2061 | (when line 2062 | (goto-char (point-min)) 2063 | (forward-line (1- line)) 2064 | (reposition-window))))) 2065 | 2066 | ;;; Socket connection 2067 | (defvar dyalog-connection () 2068 | "The connection to a Dyalog process used for this buffer, if any.") 2069 | 2070 | (defvar dyalog-connections () 2071 | "A list of all connections to Dyalog processes.") 2072 | 2073 | (defvar dyalog-ride-connections () 2074 | "A list of all RIDE connections to Dyalog interpreters.") 2075 | 2076 | ;;;###autoload 2077 | (defun dyalog-session-connect (&optional host port) 2078 | "Connect to a Dyalog session. 2079 | HOST (defaults to localhost) and PORT (defaults to 7979) give 2080 | adress to connect to." 2081 | (interactive (list (read-string "Host (default localhost):" 2082 | "127.0.0.1") 2083 | (read-number "Port (default 7979):" 7979))) 2084 | (make-comint "dyalog" (cons host port)) 2085 | (switch-to-buffer "*dyalog*") 2086 | (set-buffer-process-coding-system 'utf-8-dos 'utf-8-dos) 2087 | (setq-default comint-scroll-show-maximum-output nil) 2088 | (define-key (current-local-map) 2089 | (kbd"C-c C-e") 'dyalog-editor-edit-symbol-at-point) 2090 | (run-hooks 'dyalog-session-connect-hook)) 2091 | 2092 | ;;;###autoload 2093 | (defun dyalog-editor-connect (&optional host port) 2094 | "Connect to a Dyalog process as an editor. 2095 | HOST (defaults to localhost) and PORT (defaults to 8080) give 2096 | adress to connect to." 2097 | (interactive (list (read-string "Host (default localhost):" 2098 | "127.0.0.1") 2099 | (read-number "Port (default 8080):" 8080))) 2100 | (let* ((bufname (generate-new-buffer-name " *dyalog-receive*")) 2101 | (process (make-network-process :name "dyalog-edit" 2102 | :buffer bufname 2103 | :family 'ipv4 :host host :service port 2104 | :sentinel 'dyalog-editor-sentinel 2105 | :filter 'dyalog-editor-receive 2106 | :coding 'utf-8-dos))) 2107 | (push process dyalog-connections) 2108 | (set-process-query-on-exit-flag process nil) 2109 | process)) 2110 | 2111 | (defun dyalog-editor-sentinel (proc msg) 2112 | "Callback for socket errors. 2113 | PROC is the socket/process and MSG is a string describing the event/error." 2114 | (when (string= msg "connection broken by remote peer\n") 2115 | (message (format "client %s has quit" proc)) 2116 | (setq dyalog-connections (delq proc dyalog-connections)))) 2117 | 2118 | (defun dyalog-editor-receive (process output) 2119 | "Receive data from a Dyalog editor connection. 2120 | PROCESS is the socket receiving data and OUTPUT is the data received." 2121 | (with-current-buffer (process-buffer process) 2122 | (save-excursion 2123 | ;; Insert the text, advancing the process marker. 2124 | (goto-char (process-mark process)) 2125 | (insert output) 2126 | (set-marker (process-mark process) (point)) 2127 | (goto-char (point-min)) 2128 | (while (search-forward "\e" nil t) 2129 | (backward-char) 2130 | (let ((m (point))) 2131 | (goto-char (point-min)) 2132 | (dyalog-editor-munge-command process (point) m) 2133 | (with-current-buffer (process-buffer process) 2134 | (set-marker (process-mark process) 1))) 2135 | (sit-for 0.01))))) 2136 | 2137 | (defun dyalog-editor-munge-command (process start end) 2138 | "Parse and delete a Dyalog editor command in the currently active region. 2139 | PROCESS is the socket receiving the command, START is the start 2140 | of the command and END is where it ends." 2141 | (cond ((looking-at 2142 | "edit \\([^ []+\\)\\(\\[\\([0-9]+\\)\\]\\)?\0\\([^\0]*\\)\0") 2143 | (let ((name (match-string 1)) 2144 | (linetext (match-string 3)) 2145 | (lineno nil) 2146 | (path (match-string 4)) 2147 | (src (buffer-substring-no-properties (match-end 0) end))) 2148 | (when linetext 2149 | (set 'lineno (string-to-number linetext))) 2150 | (delete-region start (1+ end)) 2151 | (dyalog-open-edit-buffer process name src lineno path))) 2152 | ((looking-at "fxresult \\([^ ]+\\)\e") 2153 | (let* ((result (match-string 1)) 2154 | (num (string-to-number result))) 2155 | (if (eq num 0) 2156 | (message "Fixed as %s" result) 2157 | (message "Can't fix, error in line %d" num)) 2158 | (delete-region start (1+ end)))) 2159 | ((looking-at "editarray \\([^ ]+\\) \\([^ ]+\\) ") 2160 | (let* ((name (match-string 1)) 2161 | (kind (match-string 2)) 2162 | (src (buffer-substring-no-properties (match-end 0) end))) 2163 | (delete-region start (1+ end)) 2164 | (dyalog-open-edit-array process name kind src))) 2165 | ((looking-at "dyaloghello \n") 2166 | (progn 2167 | (goto-char (match-end 0)) 2168 | (while (looking-at "\\([a-z]+\\): \\([^\r\n]+\\)\n") 2169 | (let* ((key (match-string-no-properties 1)) 2170 | (val (match-string-no-properties 2)) 2171 | (propname (concat "dyalog-" key))) 2172 | (process-put process (intern propname) val) 2173 | (goto-char (match-end 0)))) 2174 | (delete-region start (1+ end)))) 2175 | (t 2176 | (error "Invalid message received")))) 2177 | 2178 | (defun dyalog-open-edit-buffer (process name src &optional lineno path) 2179 | "Open a buffer to edit object from socket PROCESS named NAME with source SRC. 2180 | PROCESS is the socket connection associated with the buffer. 2181 | LINENO optionally moves point to the given line and PATH contains 2182 | a string with the path to the source file associated with the 2183 | edit buffer." 2184 | (let* ((file-name (if (and path (not (string= path ""))) 2185 | path 2186 | nil)) 2187 | (bufname (if file-name 2188 | (file-name-nondirectory file-name) 2189 | name)) 2190 | (buffer (if file-name 2191 | (find-buffer-visiting file-name) 2192 | (get-buffer bufname))) 2193 | (window (when buffer (get-buffer-window buffer))) 2194 | (preferred (when dyalog-symbol-preferred-window 2195 | (pop dyalog-symbol-preferred-window)))) 2196 | (cond 2197 | ((eq preferred 'other-window) 2198 | (pop-to-buffer (or buffer bufname))) 2199 | ((windowp (or window preferred)) 2200 | (select-window (or window preferred))) 2201 | (t 2202 | (switch-to-buffer (or buffer bufname)))) 2203 | (setq buffer-undo-list t) 2204 | (widen) 2205 | (let ((pos (point))) 2206 | (save-excursion 2207 | (delete-region (point-min) (point-max)) 2208 | (insert src)) 2209 | (when file-name 2210 | (set-visited-file-name file-name t) 2211 | (set-buffer-modified-p nil)) 2212 | (dyalog-mode) 2213 | (setq dyalog-connection process) 2214 | (if (fboundp 'font-lock-ensure) 2215 | (font-lock-ensure) 2216 | (font-lock-fontify-buffer)) 2217 | (if lineno 2218 | (forward-line (- lineno 1)) 2219 | (goto-char (min pos (point-max)))) 2220 | (setq buffer-undo-list nil) 2221 | (select-frame-set-input-focus (window-frame (selected-window)))))) 2222 | 2223 | (defun dyalog-open-edit-array (process name _kind src) 2224 | "Open a buffer to edit array. 2225 | PROCESS is the socket connection associated with the buffer, NAME 2226 | is the name of the array, KIND is the type of array and is 2227 | \"charvec\", \"charmat\", \"stringvec\" or \"array\". SRC is the 2228 | formatted contents of the array" 2229 | (switch-to-buffer name) 2230 | (setq buffer-undo-list t) 2231 | (widen) 2232 | (let ((pos (point)) 2233 | (lineno nil)) 2234 | (save-excursion 2235 | (when buffer-read-only 2236 | (setq buffer-read-only nil)) 2237 | (delete-region (point-min) (point-max)) 2238 | (insert src)) 2239 | (dyalog-array-mode) 2240 | (setq dyalog-connection process) 2241 | (if (fboundp 'read-only-mode) ; Only available in 24.4 and later 2242 | (read-only-mode) 2243 | (setq buffer-read-only t)) 2244 | (if lineno 2245 | (forward-line (- lineno 1)) 2246 | (goto-char (min pos (point-max)))) 2247 | (setq buffer-undo-list nil) 2248 | (select-frame-set-input-focus (window-frame (selected-window))))) 2249 | 2250 | (defun dyalog-connection-desc (process) 2251 | "Return a string describing PROCESS." 2252 | (let ((version (process-get process 'dyalog-version)) 2253 | (wsid (process-get process 'dyalog-wsid)) 2254 | (cwd (process-get process 'dyalog-dir)) 2255 | (host (process-contact process :host)) 2256 | (port (process-contact process :service))) 2257 | (if (and version wsid cwd) 2258 | (let ((cwd-short (and (string-match "[^/\\]+\\'" cwd) 2259 | (match-string 0 cwd))) 2260 | (wsid-short (and (string-match "[^/\\]+\\'" wsid) 2261 | (match-string 0 wsid)))) 2262 | (format "%s in %s v%s" wsid-short cwd-short version)) 2263 | (format "%s:%s" host port)))) 2264 | 2265 | (defun dyalog-connection-select (&optional prompt) 2266 | "Select one of the active connections to Dyalog processes. 2267 | PROMPT is the prompt to show to the user." 2268 | (let ((p (or prompt "Select a Dyalog process:")) 2269 | (candidates (mapcar 2270 | 'dyalog-connection-desc dyalog-connections))) 2271 | (or (dyalog-editor-buffer-connected) 2272 | (and (equal 1 (length dyalog-connections)) 2273 | (car dyalog-connections)) 2274 | (nth (cl-position (completing-read p candidates nil t) 2275 | candidates :test 'string-equal) 2276 | dyalog-connections)))) 2277 | 2278 | (defun dyalog-editor-buffer-connected () 2279 | "When the current buffer is connected to Dyalog, return the connection. 2280 | Otherwise return nil." 2281 | (and (process-live-p dyalog-connection) dyalog-connection)) 2282 | 2283 | (defun dyalog-editor-fix (&optional process) 2284 | "Send the contents of the current buffer to the connected Dyalog PROCESS." 2285 | (interactive) 2286 | (let ((process (or process (dyalog-connection-select)))) 2287 | (setq dyalog-connection process) 2288 | (process-send-string process "fx ") 2289 | (process-send-region process (point-min) (point-max)) 2290 | (process-send-string process "\e"))) 2291 | 2292 | (defun dyalog-editor-fix-and-quit () 2293 | "Fix the current buffer, kill it, and move focus to Dyalog." 2294 | (interactive) 2295 | (let ((process (dyalog-connection-select)) 2296 | (kill-buffer-query-functions ())) 2297 | (dyalog-editor-fix process) 2298 | ;; TODO: We really should verify that the fix is successful here... 2299 | (when (kill-buffer) 2300 | (process-send-string process "focus \e")))) 2301 | 2302 | (defun dyalog-editor-edit (name &optional line) 2303 | "Open source of symbol NAME in an edit buffer. 2304 | Optional argument LINE specifies which line to move point to." 2305 | (interactive "s") 2306 | (let ((process (dyalog-connection-select)) 2307 | (linespec (if line (format "[%d]" line) nil ))) 2308 | (setq dyalog-connection process) 2309 | (process-send-string process (concat "src " name linespec "\e")))) 2310 | 2311 | ;; RIDE connections 2312 | 2313 | (defvar dyalog-ride-process 2314 | nil 2315 | "Process used for communicating with Dyalog via RIDE") 2316 | 2317 | (defvar dyalog-ride-session 2318 | nil 2319 | "Buffer used for the session for the given RIDE connection") 2320 | 2321 | (defvar dyalog-window-id 2322 | nil 2323 | "Dyalog window id for the current buffer") 2324 | 2325 | (defvar dyalog-thread-id 2326 | nil 2327 | "Dyalog thread id for the current (debugger) buffer") 2328 | 2329 | (defvar dyalog-ride-selected-thread 2330 | nil 2331 | "The currently selected thread in the Dyalog session. 2332 | A thread needs to be selected before you can issue debugger 2333 | commands such as Continue, TraceForward etc.") 2334 | 2335 | (defun dyalog-ride-connect (host port session-buffer) 2336 | "Connect to a Dyalog process as an editor. 2337 | HOST (defaults to localhost) and PORT (defaults to 8080) give 2338 | adress to connect to." 2339 | (let* ((bufname (generate-new-buffer-name " *dyalog-ride-receive*")) 2340 | (process (make-network-process :name "dyalog-ride" 2341 | :buffer bufname 2342 | :host host :service port 2343 | :sentinel 'dyalog-editor-sentinel 2344 | :filter 'dyalog-ride-receive 2345 | :coding 'no-conversion))) 2346 | (push process dyalog-ride-connections) 2347 | (with-current-buffer (process-buffer process) 2348 | (setq-local dyalog-ride-session session-buffer) 2349 | (set-buffer-multibyte nil)) 2350 | ;;(message "Connected to RIDE using buffer %s" (buffer-name bufname)) 2351 | (set-process-query-on-exit-flag process nil) 2352 | process)) 2353 | 2354 | (defun dyalog-ride-session (&optional host port) 2355 | "Start a session with a Dyalog interpreter via PROCESS-ARG" 2356 | (interactive (list (read-string "Host (default localhost):" 2357 | "localhost") 2358 | (read-number "Port (default 8080):" 8080))) 2359 | (let ((old-point nil) 2360 | (buf-name "*Dyalog-session*") 2361 | (process nil)) 2362 | (unless (comint-check-proc buf-name) 2363 | (with-current-buffer (get-buffer-create buf-name) 2364 | (unless (zerop (buffer-size)) (setq old-point (point))) 2365 | (dyalog-session-mode))) 2366 | (setq process (dyalog-ride-connect host port buf-name)) 2367 | (pop-to-buffer-same-window buf-name) 2368 | (setq-local dyalog-ride-process process 2369 | dyalog-ride-selected-thread nil) 2370 | (when old-point (push-mark old-point)))) 2371 | 2372 | (defvar dyalog-prompt 2373 | " " 2374 | "Default prompt in a Dyalog session") 2375 | 2376 | (defvar dyalog-prompt-regexp 2377 | (concat "^" (regexp-quote dyalog-prompt)) 2378 | "Regexp to match the prompt at the beginning of a line") 2379 | 2380 | (defvar dyalog-session-mode-map 2381 | (let ((map (make-sparse-keymap))) 2382 | (define-key map "\C-m" #'dyalog-ride-send-input) 2383 | (define-key map "\C-j" #'dyalog-ride-send-input) 2384 | (define-key map (kbd "") #'dyalog-ride-session-trace) 2385 | (define-key map (kbd "C-c C-b") #'dyalog-ride-interrupt) 2386 | (define-key map "\177" 'backward-delete-char-untabify) 2387 | map) 2388 | "Default key map for a Dyalog RIDE session.") 2389 | 2390 | (defvar dyalog-debugger-mode-map 2391 | (let ((map (make-sparse-keymap))) 2392 | (define-key map "p" #'dyalog-debugger-backward) 2393 | (define-key map "n" #'dyalog-debugger-forward) 2394 | (define-key map "\C-m" #'dyalog-debugger-step-over) 2395 | (define-key map (kbd "SPC") #'dyalog-debugger-step-over) 2396 | (define-key map (kbd "") #'dyalog-debugger-step-into) 2397 | (define-key map "c" #'dyalog-debugger-continue) 2398 | (define-key map "u" #'dyalog-debugger-cutback) 2399 | map) 2400 | "Default key map for the Dyalog debugger") 2401 | 2402 | (defvar dyalog-ride-input "") 2403 | 2404 | (defun dyalog-ride-input-sender (_proc input) 2405 | ;; Just sets the variable dyalog-ride-input, which is in the scope of 2406 | ;; `dyalog-ride-send-input's call. 2407 | (message "Comint sent input: %s" input) 2408 | (let* ((s (substring-no-properties input)) 2409 | (base (if (string-match "\\(^ *\n\\)*\\(.*\\)$" s) 2410 | (match-string 2 s) 2411 | s))) 2412 | (setq-local dyalog-ride-input base))) 2413 | 2414 | (defun dyalog-ride-send-input () 2415 | "Evaluate the Emacs Lisp expression after the prompt" 2416 | (interactive) 2417 | (comint-send-input) ; update history, markers etc. 2418 | (dyalog-ride-eval-input dyalog-ride-input nil) 2419 | (setq-local dyalog-ride-input "")) 2420 | 2421 | (defun dyalog-ride-eval-input (input trace) 2422 | (let* ((with-nl (if (not (string-match-p "\n$" input)) 2423 | (concat input "\n") 2424 | input)) 2425 | (with-prompt (if (string-match-p dyalog-prompt-regexp with-nl) 2426 | with-nl 2427 | (concat dyalog-prompt with-nl))) 2428 | (trace-arg (if trace 2429 | 1 2430 | 0)) 2431 | (args `((text . ,with-prompt) 2432 | (trace . ,trace-arg)))) 2433 | (dyalog-ride-send-cmd dyalog-ride-process "Execute" args))) 2434 | 2435 | (defun dyalog-ride-session-trace () 2436 | "Trace the expression after the prompt" 2437 | (interactive) 2438 | (comint-send-input) 2439 | (message "tracing expression") 2440 | (dyalog-ride-eval-input dyalog-ride-input t) 2441 | (setq-local dyalog-ride-input "")) 2442 | 2443 | 2444 | (define-derived-mode dyalog-debugger-mode dyalog-mode "Dyalog DBG" 2445 | "Major mode for Dyalog debugger interaction. 2446 | 2447 | Keyboard commands are: 2448 | \\{dyalog-debugger-mode-map\\}" 2449 | :syntax-table dyalog-mode-syntax-table 2450 | (setq buffer-read-only t)) 2451 | 2452 | (define-derived-mode dyalog-session-mode comint-mode "Dyalog IDE" 2453 | "Major mode for the Dyalog RIDE session. 2454 | Keyboard commands are: 2455 | \\{dyalog-session-mode-map\\}" 2456 | :syntax-table dyalog-mode-syntax-table 2457 | 2458 | (setq comint-prompt-regexp dyalog-prompt-regexp) 2459 | ;; (set (make-local-variable 'paragraph-separate) "\\'") 2460 | ;; (set (make-local-variable 'paragraph-start) comint-prompt-regexp) 2461 | (setq comint-input-sender 'dyalog-ride-input-sender) 2462 | (setq comint-process-echoes nil) 2463 | (set (make-local-variable 'comint-prompt-read-only) t) 2464 | ;; (setq-local comint-output-filter-functions 2465 | ;; (list 'comint-postoutput-scroll-to-bottom)) 2466 | (setq-local dyalog-ride-input "") 2467 | ;;(setq comint-get-old-input 'ielm-get-old-input) 2468 | ;;(set (make-local-variable 'comint-completion-addsuffix) '("/" . "")) 2469 | 2470 | ;;(set (make-local-variable 'indent-line-function) #'ielm-indent-line) 2471 | 2472 | ;; A dummy process to keep comint happy. It will never get any input. 2473 | ;; Stolen from ielm/inferior-emacs-lisp-mode 2474 | (unless (comint-check-proc (current-buffer)) 2475 | (condition-case nil 2476 | (start-process "dyalog-ride-dummy" (current-buffer) "hexl") 2477 | (file-error (start-process "dyalog-ride-dummy" (current-buffer) "cat"))) 2478 | (set-process-query-on-exit-flag (get-buffer-process (current-buffer)) nil) 2479 | (goto-char (point-max)) 2480 | 2481 | (set (make-local-variable 'comint-inhibit-carriage-motion) t) 2482 | 2483 | (unless comint-use-prompt-regexp 2484 | (let ((inhibit-read-only t)) 2485 | (add-text-properties 2486 | (point-min) (point-max) 2487 | '(rear-nonsticky t field output inhibit-line-move-field-capture t)))) 2488 | (set-marker comint-last-input-start 2489 | (process-mark (get-buffer-process (current-buffer)))) 2490 | (set-process-filter (get-buffer-process (current-buffer)) 'comint-output-filter))) 2491 | 2492 | 2493 | (defun dyalog-ride-u32 (s) 2494 | "Convert string S to unsigned 32-bit int in network byte order." 2495 | (let* ((bytes (reverse (vconcat s))) 2496 | (shift [0 8 16 24]) 2497 | (res 0)) 2498 | (dotimes (i (length bytes)) 2499 | (let* ((char (aref bytes i)) 2500 | (byte (if (> char 255) 2501 | (- 4194303 char) 2502 | char))) 2503 | (setq res (logior res (ash byte (aref shift i)))))) 2504 | res)) 2505 | 2506 | (defun dyalog-ride-string-from-u32 (n) 2507 | "Convert integer N to string of bytes in network byte order." 2508 | (let ((chars ()) 2509 | (shift [0 8 16 24]) 2510 | (mask 255)) 2511 | (dotimes (i 4) 2512 | (push (logand (ash n (- (aref shift i))) mask) chars)) 2513 | (mapconcat #'byte-to-string chars ""))) 2514 | 2515 | (defun dyalog-ride-unpack () 2516 | "Unpack RIDE message encoded in current buffer. 2517 | Returns a string with the payload." 2518 | (let ((len (- (point-max) (point-min)))) 2519 | (cond ((< len 8) 2520 | nil) 2521 | ((not (string-equal (buffer-substring-no-properties 2522 | (+ (point-min) 4) (+ (point-min) 8)) 2523 | "RIDE")) 2524 | nil) 2525 | (t 2526 | (let* ((msg-len-string (buffer-substring-no-properties 2527 | (point-min) (+ (point-min) 4))) 2528 | (msg-len (dyalog-ride-u32 msg-len-string))) 2529 | (if (< len msg-len) 2530 | nil 2531 | (let* ((bstring (buffer-substring-no-properties 2532 | (+ (point-min) 8) 2533 | (+ (point-min) msg-len))) 2534 | (read-bytes (length bstring))) 2535 | (list (decode-coding-string bstring 'utf-8-unix bstring) 2536 | read-bytes)))))))) 2537 | 2538 | (defun dyalog-ride-receive (process output) 2539 | "Receive data from a Dyalog editor connection. 2540 | PROCESS is the socket receiving data and OUTPUT is the data received." 2541 | (with-current-buffer (process-buffer process) 2542 | (save-excursion 2543 | ;; Insert the text, advancing the process marker. 2544 | (message "Received %d bytes" (length output)) 2545 | (goto-char (process-mark process)) 2546 | (let ((coding-system-for-write 'no-conversion)) 2547 | (insert output)) 2548 | (set-marker (process-mark process) (point)) 2549 | (let ((done nil) 2550 | (msg nil)) 2551 | (while (not done) 2552 | (setq msg (dyalog-ride-unpack) 2553 | done (equal msg nil)) 2554 | (when msg 2555 | (condition-case error-var 2556 | (dyalog-ride-exec-command process (car msg)) 2557 | (error 2558 | (message "Error %s when executing handler for %s" error-var (car msg)) 2559 | ;; We need to set the current buffer again in case exec-command 2560 | ;; got an error while another buffer was current 2561 | (set-buffer (process-buffer process)))) 2562 | (let* ((from (point-min)) 2563 | (num-bytes (cadr msg)) 2564 | (to (byte-to-position 2565 | (+ from num-bytes 8)))) 2566 | (delete-region from to))))) 2567 | (set-marker (process-mark process) (point-max)) 2568 | (sit-for 0.001)))) 2569 | 2570 | (defun dyalog-ride-exec-command (process command) 2571 | "Handle COMMAND received via RIDE process PROCESS." 2572 | (cond ((string-match-p "SupportedProtocols=" command) 2573 | (dyalog-ride-handle-handshake process command)) 2574 | ((string-match-p "UsingProtocol=" command) 2575 | nil) 2576 | (t 2577 | (let* ((arr (json-read-from-string (decode-coding-string command 'utf-8))) 2578 | (cmd-name (aref arr 0)) 2579 | (args (aref arr 1))) 2580 | (message "Received command %s" cmd-name) 2581 | (pcase cmd-name 2582 | ("SetPromptType" 2583 | (dyalog-ride-set-prompt-cmd cmd-name args process)) 2584 | ;; We just ignore EchoInput for now. This breaks quote quad input 2585 | ;; and some other stuff, but that is rarely used anyway. 2586 | ;; ("EchoInput" 2587 | ;; (dyalog-ride-echo-input-cmd cmd-name args process)) 2588 | ("ReplyGetLog" 2589 | (dyalog-ride-log-get-cmd cmd-name args process)) 2590 | ("OpenWindow" 2591 | (dyalog-ride-open-window cmd-name args process)) 2592 | ("UpdateWindow" 2593 | (dyalog-ride-update-window args process)) 2594 | ("AppendSessionOutput" 2595 | (dyalog-ride-append-cmd cmd-name args process)) 2596 | ("FocusThread" 2597 | (dyalog-ride-focus-thread-cmd args process)) 2598 | ("SetHighlightLine" 2599 | (dyalog-ride-set-highlight-line args process)) 2600 | ("CloseWindow" 2601 | (dyalog-ride-close-window-cmd args process))))))) 2602 | 2603 | (defun dyalog-ride-set-prompt-cmd (_cmd args _process) 2604 | (let ((type (cdr (assoc 'type args)))) 2605 | (when (equal type 1) 2606 | (with-current-buffer dyalog-ride-session 2607 | (goto-char (point-max)) 2608 | (let ((has-prompt 2609 | (save-excursion 2610 | (forward-line 0) 2611 | (looking-at-p dyalog-prompt-regexp))) 2612 | (prefix (if (looking-at-p "$") 2613 | "" 2614 | "\n"))) 2615 | (when (not has-prompt) 2616 | (comint-output-filter (get-buffer-process (current-buffer)) 2617 | (concat prefix dyalog-prompt)))))))) 2618 | 2619 | (defun dyalog-ride-echo-input-cmd (_cmd args _process) 2620 | (let ((input (cdr (assoc 'input args)))) 2621 | (with-current-buffer dyalog-ride-session 2622 | (comint-output-filter (get-buffer-process (current-buffer)) input)))) 2623 | 2624 | (defun dyalog-ride-append-cmd (_cmd args _process) 2625 | (let ((output (cdr (assoc 'result args)))) 2626 | (with-current-buffer dyalog-ride-session 2627 | (comint-output-filter (get-buffer-process (current-buffer)) output)))) 2628 | 2629 | (defun dyalog-ride-focus-thread-cmd (args process) 2630 | (message "Received FocusThread with args %s" args) 2631 | (with-current-buffer dyalog-ride-session 2632 | (setq-local dyalog-ride-selected-thread (cdr (assoc 'tid args))))) 2633 | 2634 | (defvar dyalog-ride-windows 2635 | #s(hash-table test equal) 2636 | "Mapping from RIDE window ids to Emacs buffers") 2637 | 2638 | (defun dyalog-ride-open-window (_cmd args process) 2639 | (message "OpenWindow: %s" args) 2640 | (if (equal 1 (cdr (assoc 'debugger args))) 2641 | (dyalog-ride-open-debugger args process)) 2642 | (dyalog-ride-open-edit-window args process)) 2643 | 2644 | (defun dyalog-ride-update-window (args process) 2645 | (let* ((window-id (cdr (assoc 'token args))) 2646 | (debugger-mode (equal 1 (cdr (assoc 'debugger args)))) 2647 | (bufname (gethash window-id dyalog-ride-windows))) 2648 | (unless bufname 2649 | (error "Received UpdateWindow message for window %s, but no such window exists")) 2650 | (if debugger-mode 2651 | (dyalog-ride-open-debugger args process bufname) 2652 | (dyalog-ride-open-edit-window args process)))) 2653 | 2654 | (defun dyalog-ride-open-edit-window (args process) 2655 | (let ((buf (pop-to-buffer (cdr (assoc 'name args)))) 2656 | (text (cdr (assoc 'text args))) 2657 | (lineno (cdr (assoc 'offset args))) 2658 | (window-id (cdr (assoc 'token args)))) 2659 | (with-current-buffer buf 2660 | (puthash window-id buf dyalog-ride-windows) 2661 | (setq buffer-undo-list t) 2662 | (widen) 2663 | (let ((pos (point))) 2664 | (save-excursion 2665 | (delete-region (point-min) (point-max)) 2666 | (dotimes (i (length text)) 2667 | (insert (aref text i)) 2668 | (insert "\n"))) 2669 | (dyalog-mode) 2670 | (setq-local dyalog-ride-process process 2671 | dyalog-window-id window-id) 2672 | (if (fboundp 'font-lock-ensure) 2673 | (font-lock-ensure) 2674 | (font-lock-fontify-buffer)) 2675 | (if lineno 2676 | (forward-line (- lineno 1)) 2677 | (goto-char (min pos (point-max)))) 2678 | (setq buffer-undo-list nil) 2679 | (set-buffer-modified-p nil))))) 2680 | 2681 | (defun dyalog-ride-open-debugger (args process &optional bufname) 2682 | (let ((buf (or bufname (get-buffer-create (cdr (assoc 'name args))))) 2683 | (text (cdr (assoc 'text args))) 2684 | (lineno (cdr (assoc 'offset args))) 2685 | (window-id (cdr (assoc 'token args))) 2686 | (thread-id (cdr (assoc 'tid args))) 2687 | (hl-row (cdr (assoc 'currentRow args)))) 2688 | (message "Opening debug window for process %s" process) 2689 | (message "bufname: %s, buf: %s" bufname buf) 2690 | (with-current-buffer buf 2691 | (setq buffer-read-only nil) 2692 | (puthash window-id buf dyalog-ride-windows) 2693 | (setq buffer-undo-list t) 2694 | (widen) 2695 | (let ((pos (point))) 2696 | (save-excursion 2697 | (erase-buffer) 2698 | (dotimes (i (length text)) 2699 | (insert (aref text i)) 2700 | (insert "\n"))) 2701 | (dyalog-debugger-highlight-line hl-row) 2702 | (if (fboundp 'font-lock-ensure) 2703 | (font-lock-ensure) 2704 | (font-lock-fontify-buffer)) 2705 | (if (and lineno (not (= 0 lineno))) 2706 | (forward-line (- lineno 1)) 2707 | (goto-char (min pos (point-max)))) 2708 | (setq buffer-undo-list nil) 2709 | (set-buffer-modified-p nil)) 2710 | (dyalog-debugger-mode) 2711 | (setq-local dyalog-ride-process process 2712 | dyalog-window-id window-id 2713 | dyalog-thread-id thread-id)) 2714 | (when (not bufname) 2715 | (display-buffer buf '(display-buffer-at-bottom (window-height . 0.33)))))) 2716 | 2717 | (defun dyalog-ride-close-window-cmd (args _process) 2718 | (let* ((window-id (cdr (assoc 'win args))) 2719 | (buf (gethash window-id dyalog-ride-windows)) 2720 | (win (get-buffer-window buf))) 2721 | (when buf 2722 | (with-current-buffer buf 2723 | (when (and (eq major-mode 'dyalog-debugger-mode) 2724 | win) 2725 | (delete-window win)) 2726 | (kill-buffer buf))))) 2727 | 2728 | (defun dyalog-ride-set-highlight-line (args _process) 2729 | "Handle update highlited line command from Dyalog" 2730 | (let* ((window-id (cdr (assoc 'win args))) 2731 | (line (cdr (assoc 'line args))) 2732 | (buf (gethash window-id dyalog-ride-windows))) 2733 | (when buf 2734 | (with-current-buffer buf 2735 | (dyalog-debugger-highlight-line line))))) 2736 | 2737 | (defun dyalog-debugger-highlight-line (line) 2738 | "Indicate that LINE is the line about to be executed" 2739 | (let ((pos-marker (save-excursion 2740 | (goto-char (point-min)) 2741 | (forward-line line) 2742 | (point-marker)))) 2743 | (setq overlay-arrow-position pos-marker))) 2744 | 2745 | (defun dyalog-ride-current-thread (process) 2746 | (let ((session-buf (with-current-buffer (process-buffer process) 2747 | dyalog-ride-session))) 2748 | (with-current-buffer session-buf 2749 | dyalog-ride-selected-thread))) 2750 | 2751 | (defun dyalog-debugger-set-thread (thread-id) 2752 | "Select the thread with id THREAD-ID as the current thread. 2753 | This needs to be done before executing any debugger commands on that thread." 2754 | (let ((args `((tid . ,thread-id)))) 2755 | (dyalog-ride-send-cmd dyalog-ride-process "SetThread" args))) 2756 | 2757 | (defun dyalog-debugger-cmd (cmd) 2758 | "Send simple command CMD to RIDE debugger" 2759 | (let ((args `((win . ,dyalog-window-id))) 2760 | (selected-thread (dyalog-ride-current-thread dyalog-ride-process))) 2761 | (when (not (equal dyalog-thread-id selected-thread)) 2762 | (dyalog-debugger-set-thread dyalog-thread-id)) 2763 | (dyalog-ride-send-cmd dyalog-ride-process cmd args))) 2764 | 2765 | (defun dyalog-debugger-forward () 2766 | "Move current line in debugger forward without executing the current line" 2767 | (interactive) 2768 | (dyalog-debugger-cmd "TraceForward")) 2769 | 2770 | (defun dyalog-debugger-backward () 2771 | "Move current line in debugger backwards" 2772 | (interactive) 2773 | (dyalog-debugger-cmd "TraceBackward")) 2774 | 2775 | (defun dyalog-debugger-step-over () 2776 | "Execute the current line and then stop" 2777 | (interactive) 2778 | (dyalog-debugger-cmd "RunCurrentLine")) 2779 | 2780 | (defun dyalog-debugger-step-into () 2781 | "Step into the current line and then stop" 2782 | (interactive) 2783 | (dyalog-debugger-cmd "StepInto")) 2784 | 2785 | (defun dyalog-debugger-continue () 2786 | "Resume execution and close the debugger" 2787 | (interactive) 2788 | (dyalog-debugger-cmd "Continue")) 2789 | 2790 | (defun dyalog-debugger-cutback () 2791 | "Cut back the stack one level (exit the current function) and pause" 2792 | (interactive) 2793 | (dyalog-debugger-cmd "Cutback")) 2794 | 2795 | (defun dyalog-ride-log-get-cmd (_cmd args _process) 2796 | (let ((lines (cdr (assoc 'result args)))) 2797 | (with-current-buffer dyalog-ride-session 2798 | (goto-char (point-max)) 2799 | (dotimes (i (length lines)) 2800 | (let ((line (concat (aref lines i) "\n"))) 2801 | (comint-output-filter (get-buffer-process (current-buffer)) line)))))) 2802 | 2803 | (defun dyalog-ride-interrupt () 2804 | "Send a strong interrupt to the RIDE interpreter." 2805 | (interactive) 2806 | (message "Sending strong interrupt to Dyalog...") 2807 | (dyalog-ride-send-cmd dyalog-ride-process "StrongInterrupt" #s(hash-table))) 2808 | 2809 | (defun dyalog-ride-handle-handshake (process command) 2810 | "Respond to the RIDE handshake COMMAND." 2811 | (unless (string-match "SupportedProtocols=\\([0-9]+\\(?:,[0-9]+\\)*\\)" 2812 | command) 2813 | (error "Invalid handshake received")) 2814 | (let ((supported (string-to-number (match-string 1 command)))) 2815 | (when (not (= supported 2)) 2816 | (error "Only RIDE protocol v2 is supported")) 2817 | (dyalog-ride-send-handshake process))) 2818 | 2819 | (defun dyalog-ride-send-handshake (process) 2820 | "Send a handshake message to the RIDE interpreter at PROCESS." 2821 | (dyalog-ride-send-cmd process "SupportedProtocols=2") 2822 | (dyalog-ride-send-cmd process "UsingProtocol=2") 2823 | (dyalog-ride-send-cmd process "Identify" `((identity . 1))) 2824 | ;; I have no idea what the Connect message does, but Dyalog's 2825 | ;; RIDE sends it so we do too. 2826 | (dyalog-ride-send-cmd process "Connect" `((remoteId . 2))) 2827 | ;; We want Emacs to handle wrapping, not Dyalog 2828 | (dyalog-ride-send-cmd process "SetPW" `((pw . 32767)))) 2829 | 2830 | (defun dyalog-ride-send-cmd (process cmd &optional args) 2831 | "Send RIDE CMD to PROCESS. 2832 | If ARGS is nil, just send a string, otherwise send a JSON array 2833 | with CMD as the first element and ARGS as the second." 2834 | (let* ((payload (if args 2835 | (json-encode (list cmd args)) 2836 | cmd)) 2837 | (len (+ 8 (string-bytes payload))) 2838 | (u32 (dyalog-ride-string-from-u32 len)) 2839 | (header (concat u32 "RIDE")) 2840 | (msg (concat header payload))) 2841 | (message "Sending cmd %s" payload) 2842 | (process-send-string process msg))) 2843 | 2844 | 2845 | ;;; Custom protocol for communicating with Dyalog 2846 | 2847 | (defun dyalog-editor-edit-symbol-at-point () 2848 | "Edit the source for the symbol at point." 2849 | (interactive) 2850 | (let ((sym (symbol-at-point)) 2851 | (lineno nil)) 2852 | (when (looking-at "[A-Za-z∆_0-9]+\\[\\([0-9]+\\)\\]") 2853 | (setq lineno (string-to-number (match-string 1)))) 2854 | (dyalog-editor-edit (symbol-name sym) lineno))) 2855 | 2856 | (defun dyalog-toggle-local () 2857 | "Toggle localization for symbol at point." 2858 | (interactive) 2859 | (let* ((sym (symbol-at-point)) 2860 | (symname (symbol-name sym)) 2861 | (name (substring-no-properties symname)) 2862 | (regex (concat ";" name "\\_>")) 2863 | (info (dyalog-tradfn-info)) 2864 | (fname (nth 0 info)) 2865 | (end-of-header (nth 3 info))) 2866 | (unless (or (not sym) 2867 | (equal (length fname) 0) 2868 | (dyalog-in-comment-or-string) 2869 | (dyalog-in-keyword) 2870 | (dyalog-in-dfun)) 2871 | (save-excursion 2872 | (goto-char end-of-header) 2873 | (beginning-of-line) 2874 | (if (re-search-forward regex end-of-header t) 2875 | (progn 2876 | (goto-char (match-beginning 0)) 2877 | (delete-char (length (match-string 0))) 2878 | (message "Made %s non-local in function %s" name fname)) 2879 | (progn 2880 | (move-end-of-line nil) 2881 | (insert (concat ";" name)) 2882 | (message "Made %s local in function %s" name fname))))))) 2883 | 2884 | ;;; Online help 2885 | (defconst dyalog-symbol-help-names 2886 | (let ((h (make-hash-table :test 'equal))) 2887 | (dolist (e '(("&" . "Ampersand") 2888 | ("@" . "At") 2889 | ("]" ."Brackets") 2890 | ("⊖" . "Circle Bar") 2891 | ("○" . "Circle") 2892 | ("⌽" . "Circle Stile") 2893 | ("⍪" . "Comma Bar") 2894 | ("," . "Comma") 2895 | ("⊥" . "Decode Symbol") 2896 | ("¨" . "Dieresis") 2897 | ("⍣" . "DieresisStar") 2898 | ("⍨" . "Dieresis Tilde") 2899 | ("÷" . "Divide Sign") 2900 | ("⌹" . "Domino") 2901 | ("." . "Dot") 2902 | ("↓" . "Down Arrow") 2903 | ("⌊" . "Downstile") 2904 | ("⊤" . "Encode Symbol") 2905 | ("∊" . "Epsilon") 2906 | ("⍷" . "Epsilon Underbar") 2907 | ("=" . "Equal Sign") 2908 | ("≡" . "Equal Underbar") 2909 | ("≢" . "Equal Underbar Slash") 2910 | ("!" . "Exclamation Mark") 2911 | ("⍎" . "Execute Symbol") 2912 | ("⍒" . "Grade Down") 2913 | ("⍋" . "Grade Up") 2914 | ("≥" . "Greater Than Or Equal To Sign") 2915 | (">" . "Greater Than Sign") 2916 | ("⌶" . "IBeam") 2917 | ("⌷" . "Index Symbol") 2918 | ("⍳" . "Iota") 2919 | ("⍸" . "Iota Underbar") 2920 | ("⍤" . "Jot Diaresis") 2921 | ("∘" . "Jot") 2922 | ("⊂" . "Left Shoe") 2923 | ("⊆" . "Left Shoe Underbar") 2924 | ("⊣" . "Left Tack") 2925 | ("≤" . "Less Than Or Equal To Sign") 2926 | ("<" . "Less Than Sign") 2927 | ("⍟" . "Log") 2928 | ("∧" . "Logical And") 2929 | ("∨" . "Logical Or") 2930 | ("-" . "Minus Sign") 2931 | ("⍲" . "Nand Symbol") 2932 | ("⍱" . "Nor Symbol") 2933 | ("≠" . "Not Equal To") 2934 | ("+" . "Plus Sign") 2935 | ("⌸" . "Quad Equal") 2936 | ("?" . "Question Mark") 2937 | ("⍴" . "Rho") 2938 | ("→" . "Right Arrow") 2939 | ("⊃" . "Right Shoe") 2940 | ("⊢" . "Right Tack") 2941 | ("∩" . "Set Intersection") 2942 | ("∪" . "Set Union") 2943 | ("⌿" . "Slash Bar") 2944 | ("/" . "Slash") 2945 | ("⍀" . "Slope Bar") 2946 | ("\\" . "Slope") 2947 | ("*" . "Star") 2948 | ("⌺" . "Stencil") 2949 | ("|" . "Stile") 2950 | ("⍕" . "Thorn Symbol") 2951 | ("~" . "Tilde") 2952 | ("×" . "Times Sign") 2953 | ("⍉" . "Transpose") 2954 | ("↑" . "Up Arrow") 2955 | ("⌈" . "Upstile") 2956 | ("⍠" . "Variant") 2957 | ("⍬" . "Zilde Symbol"))) 2958 | (puthash (car e) (cdr e) h)) 2959 | (dolist (e '("" "#" "⍺" "⍵" "∇" "'" "⋄" "⍝" ":" ";" "¯")) 2960 | (puthash e "Special Symbols" h)) 2961 | h)) 2962 | 2963 | (defconst dyalog-help-objects 2964 | '("ActiveXContainer" "ActiveXControl" "Animation" "Bitmap" "BrowseBox" 2965 | "Button" "ButtonEdit" "Calendar" "Circle" "Clipboard" "ColorButton" 2966 | "Combo" "ComboEx" "CoolBand" "CoolBar" "Cursor" "DateTimePicker" "Edit" 2967 | "Ellipse" "FileBox" "Font" "Form" "Grid" "Group" "Icon" "Image" 2968 | "ImageList" "Label" "List" "ListView" "Locator" "MDIClient" "Marker" 2969 | "Menu" "MenuBar" "MenuItem" "Metafile" "MsgBox" "NetClient" 2970 | "NetControl" "NetType" "OCXClass" "OLEClient" "OLEServer" "Poly" 2971 | "Printer" "ProgressBar" "PropertyPage" "PropertySheet" "Rect" 2972 | "RichEdit" "Root" "SM" "Scroll" "Separator" "Spinner" "Splitter" 2973 | "Static" "StatusBar" "StatusField" "SubForm" "SysTrayItem" "TCPSocket" 2974 | "TabBar" "TabBtn" "TabButton" "TabControl" "Text" "Timer" "TipField" 2975 | "ToolBar" "ToolButton" "ToolControl" "TrackBar" "TreeView" "UpDown")) 2976 | 2977 | (defconst dyalog-help-properties 2978 | '("APLVersion" "Accelerator" "AcceptFiles" "Active" "Align" "AlignChar" 2979 | "AlphaBlend" "AlwaysShowBorder" "AlwaysShowSelection" "ArcMode" "Array" 2980 | "Attach" "AutoArrange" "AutoBrowse" "AutoConf" "AutoExpand" "AutoPlay" 2981 | "BCol" "BandBorders" "BaseClass" "Bits" "Border" "BrowseFor" "BtnPix" 2982 | "Btns" "ButtonsAcceptFocus" "CBits" "CMap" "CalendarCols" "Cancel" 2983 | "Caption" "CaseSensitive" "CellFonts" "CellHeights" "CellSelect" 2984 | "CellSet" "CellTypes" "CellWidths" "Changed" "CharFormat" "CharSet" 2985 | "CheckBoxes" "Checked" "ChildEdge" "ChildList" "CircleToday" "ClassID" 2986 | "ClassName" "ClipCells" "ColLineTypes" "ColSortImages" "ColTitle3D" 2987 | "ColTitleAlign" "ColTitleBCol" "ColTitleDepth" "ColTitleFCol" "ColTitles" 2988 | "Collate" "ColorMode" "ColumnWidth" "Container" "Coord" "Copies" "Cue" 2989 | "CurCell" "CurrentColor" "CurrentState" "CursorObj" "CustomColors" 2990 | "CustomFormat" "Data" "DateTime" "DblClickToggle" "Decimals" "Default" 2991 | "DefaultColors" "Depth" "DevCaps" "Directory" "Divider" "DockChildren" 2992 | "DockShowCaption" "Dockable" "Docked" "DragItems" "Dragable" "DrawMode" 2993 | "Duplex" "EdgeStyle" "EditImage" "EditImageIndent" "EditLabels" "Elevated" 2994 | "Encoding" "End" "EnterReadOnlyCells" "EvaluationDays" "Event" "EventList" 2995 | "ExportedFns" "ExportedVars" "FCol" "FStyle" "FieldType" "File" "FileMode" 2996 | "FillCol" "Filters" "FirstDay" "Fixed" "FixedOrder" "FlatSeparators" 2997 | "FontList" "FontObj" "FormatString" "Formats" "FullRowSelect" "GridBCol" 2998 | "GridFCol" "GridLineFCol" "GridLineWidth" "GridLines" "GripperMode" 2999 | "HAlign" "HScroll" "Handle" "HasApply" "HasButtons" "HasCheckBox" 3000 | "HasEdit" "HasHelp" "HasLines" "HasTicks" "HasToday" "Header" "HeaderImageIndex" 3001 | "HeaderImageList" "HelpButton" "HelpFile" "HighlightHeaders" "Hint" 3002 | "HintObj" "HotSpot" "HotTrack" "IconObj" "ImageCount" "ImageIndex" 3003 | "ImageListObj" "Indents" "Index" "Input" "InputMode" "InputModeKey" 3004 | "InputProperties" "InstanceMode" "Interval" "Italic" "ItemGroupMetrics" 3005 | "ItemGroups" "Items" "Justify" "KeepBits" "KeepOnClose" "LStyle" "LWidth" 3006 | "LastError" "LateBind" "LicenseKey" "Limits" "LocalAddr" "LocalAddrName" 3007 | "LocalPort" "LocalPortName" "Locale" "MDIActive" "MDIActiveObject" "MDIMenu" 3008 | "MapCols" "Mask" "MaskCol" "Masked" "MaxButton" "MaxDate" "MaxLength" "MaxSelCount" 3009 | "MetafileObj" "MethodList" "MinButton" "MinDate" "MonthDelta" "Moveable" 3010 | "MultiColumn" "MultiLine" "MultiSelect" "NewLine" "Note" "OKButton" 3011 | "OLEControls" "OLEServers" "OnTop" "Orientation" "OtherButton" "OverflowChar" 3012 | "PName" "PageActive" "PageActiveObject" "PageSize" "PageWidth" "PaperSize" 3013 | "PaperSizes" "PaperSource" "PaperSources" "ParaFormat" "Password" 3014 | "PathWordBreak" "Picture" "Points" "Popup" "Posn" "PrintList" "PrintRange" 3015 | "ProgressStyle" "PropList" "QueueEvents" "RTFText" "Radius" "RadiusMode" 3016 | "Range" "ReadOnly" "RealSize" "Redraw" "RemoteAddr" "RemoteAddrName" 3017 | "RemotePort" "RemotePortName" "ReportBCol" "ReportImageIndex" "ReportInfo" 3018 | "ResizeColTitles" "ResizeCols" "ResizeRowTitles" "ResizeRows" "Resolution" 3019 | "Resolutions" "Rotate" "RowHiddenDepth" "RowLineTypes" "RowTitleAlign" 3020 | "RowTitleBCol" "RowTitleDepth" "RowTitleFCol" "RowTitles" "RowTreeDepth" 3021 | "RowTreeImages" "RowTreeStyle" "Rows" "RunMode" "SIPMode" "SIPResize" 3022 | "ScrollOpposite" "SelDate" "SelImageIndex" "SelItems" "SelRange" "SelText" 3023 | "SelectionBorderWidth" "SelectionColor" "SelectionColorAlpha" 3024 | "ServerVersion" "ShowCaptions" "ShowCueWhenFocused" "ShowDropDown" "ShowInput" 3025 | "ShowSession" "ShowThumb" "SingleClickExpand" "Size" "Sizeable" 3026 | "SocketNumber" "SocketType" "SortItems" "SplitObj1" "SplitObj2" "Start" 3027 | "StartIn" "State" "Step" "Style" "SysMenu" "TabFocus" "TabIndex" 3028 | "TabJustify" "TabObj" "TabSize" "Target" "TargetState" "Text" "TextSize" 3029 | "Thumb" "ThumbRect" "TickAlign" "TickSpacing" "Tip" "TipObj" "TitleHeight" 3030 | "TitleWidth" "Today" "ToolboxBitmap" "TrackRect" "Translate" "Transparent" 3031 | "Type" "TypeLibFile" "TypeLibID" "TypeList" "Underline" "UndocksToRoot" 3032 | "VAlign" "VScroll" "ValidIfEmpty" "Value" "Values" "VariableHeight" "View" 3033 | "Visible" "WantsReturn" "WeekNumbers" "Weight" "WordFormat" "Wrap" "XRange" 3034 | "YRange" "Yield")) 3035 | 3036 | (defconst dyalog-help-method-or-event 3037 | '("Abort" "ActivateApp" "AddChildren" "AddCol" "AddComment" "AddItems" 3038 | "AddRow" "AmbientChanged" "AnimClose" "AnimOpen" "AnimPlay" "AnimStarted" 3039 | "AnimStop" "AnimStopped" "Animate" "BadValue" "BalloonHide" "BalloonShow" 3040 | "BalloonTimeout" "BalloonUserClick" "BeginEditLabel" "Browse" 3041 | "CalendarDblClick" "CalendarDown" "CalendarMove" "CalendarUp" "CancelToClose" 3042 | "CellChange" "CellChanged" "CellDblClick" "CellDown" "CellError" 3043 | "CellFromPoint" "CellMove" "CellOver" "CellUp" "Change" "ChooseFont" 3044 | "ClickComment" "ClipChange" "Close" "CloseUp" "ColChange" "ColSorted" 3045 | "ColorChange" "ColumnClick" "Configure" "ContextMenu" "Create" "DDE" 3046 | "DateTimeChange" "DateToIDN" "DelCol" "DelComment" "DelRow" "DeleteChildren" 3047 | "DeleteItems" "DeleteTypeLib" "Detach" "DisplayChange" "DockAccept" 3048 | "DockCancel" "DockEnd" "DockMove" "DockRequest" "DockStart" "DragDrop" 3049 | "DropDown" "DropFiles" "DropObjects" "DuplicateColumn" "DuplicateRow" 3050 | "DyalogCustomMessage1" "EndEditLabel" "EndSplit" "ExitApp" "ExitWindows" 3051 | "Expanding" "Expose" "FileBoxCancel" "FileBoxOK" "FileRead" "FileWrite" 3052 | "Flush" "FontCancel" "FontOK" "FrameContextMenu" "GesturePan" 3053 | "GesturePressAndTap" "GestureRotate" "GestureTwoFingerTap" "GestureZoom" 3054 | "GetBuildID" "GetCellRect" "GetCommandLine" "GetCommandLineArgs" 3055 | "GetComment" "GetDayStates" "GetEnvironment" "GetEventInfo" "GetFocus" 3056 | "GetFocusObj" "GetItemHandle" "GetItemPosition" "GetItemState" 3057 | "GetMethodInfo" "GetMinSize" "GetParentItem" "GetPropertyInfo" 3058 | "GetServiceState" "GetTextSize" "GetTipText" "GetTypeInfo" "GetVisibleRange" 3059 | "GotFocus" "GreetBitmap" "GridCopy" "GridCopyError" "GridCut" "GridDelete" 3060 | "GridDropSel" "GridKeyPress" "GridPaste" "GridPasteError" "GridSelect" 3061 | "HScroll" "HThumbDrag" "Help" "HideComment" "IDNToDate" "Idle" "IndexChanged" 3062 | "ItemDblClick" "ItemDown" "ItemUp" "KeyError" "KeyPress" "ListTypeLibs" 3063 | "Locator" "LockColumns" "LockRows" "LostFocus" "MDIActivate" "MDIArrange" 3064 | "MDICascade" "MDIDeactivate" "MDITile" "MakeGIF" "MakePNG" "MouseDblClick" 3065 | "MouseDown" "MouseEnter" "MouseLeave" "MouseMove" "MouseUp" "MouseWheel" 3066 | "MsgBtn1" "MsgBtn2" "MsgBtn3" "NameFromHandle" "NewPage" "OLEAddEventSink" 3067 | "OLEDeleteEventSink" "OLEListEventSinks" "OLEQueryInterface" "OLERegister" 3068 | "OLEUnregister" "PageActivate" "PageApply" "PageBack" "PageCancel" 3069 | "PageChanged" "PageDeactivate" "PageFinish" "PageHelp" "PageNext" "PreCreate" 3070 | "Print" "ProgressStep" "Protected" "RTFPrint" "RTFPrintSetup" "Retracting" 3071 | "RowChange" "RowSetVisibleDepth" "Scroll" "SelDateChange" "Select" 3072 | "ServiceNotification" "SessionPrint" "SetCellSet" "SetCellType" "SetColSize" 3073 | "SetEventInfo" "SetFinishText" "SetFnInfo" "SetItemImage" "SetItemPosition" 3074 | "SetItemState" "SetMethodInfo" "SetPropertyInfo" "SetRowSize" 3075 | "SetServiceState" "SetSpinnerText" "SetVarInfo" "SetWizard" "Setup" 3076 | "ShowBalloonTip" "ShowComment" "ShowHelp" "ShowItem" "ShowProperties" 3077 | "ShowSIP" "Spin" "Splitting" "StartSplit" "StateChange" "SysColorChange" 3078 | "TCPAccept" "TCPClose" "TCPConnect" "TCPError" "TCPGetHostID" "TCPGotAddr" 3079 | "TCPGotPort" "TCPReady" "TCPRecv" "TCPSend" "TCPSendPicture" "ThumbDrag" 3080 | "Timer" "Undo" "VScroll" "VThumbDrag" "Wait" "WinIniChange" "WorkspaceLoaded")) 3081 | 3082 | (defconst dyalog-help-root 3083 | "http://help.dyalog.com/17.1/Content/") 3084 | 3085 | (defconst dyalog-help-suffix 3086 | ".htm") 3087 | 3088 | (defconst dyalog-help-url-map 3089 | (let ((h (make-hash-table :test 'equal))) 3090 | (maphash (lambda (k v) 3091 | (puthash k (concat dyalog-help-root 3092 | "Language/Symbols/" 3093 | v dyalog-help-suffix) h)) 3094 | dyalog-symbol-help-names) 3095 | (dolist (e dyalog-help-objects) 3096 | (puthash (downcase e) (concat dyalog-help-root 3097 | "GUI/Objects/" 3098 | e dyalog-help-suffix) h)) 3099 | (dolist (e dyalog-help-properties) 3100 | (puthash (downcase e) (concat dyalog-help-root 3101 | "GUI/Properties/" 3102 | e dyalog-help-suffix) h)) 3103 | (dolist (e dyalog-help-method-or-event) 3104 | (puthash (downcase e) (concat dyalog-help-root 3105 | "GUI/MethodOrEvents/" 3106 | e dyalog-help-suffix) h)) 3107 | h)) 3108 | 3109 | (defun dyalog-help-symbol-at-point () 3110 | "Return the symbol relevant for online help at point." 3111 | (let* ((sym (symbol-at-point)) 3112 | (sym-name (when sym (symbol-name sym))) 3113 | (p (when (looking-at-p "\\s.\\|\\s(\\|\\s)") 3114 | (char-to-string (char-after)))) 3115 | (keyword (car (dyalog-current-keyword)))) 3116 | (or keyword sym-name p ""))) 3117 | 3118 | (defvar dyalog-help-for-symbol-function nil 3119 | "When non-nil, call this function to get an URL for help on a given symbol. 3120 | It receives a single string argument, the name of the symbol to 3121 | return an URL for, and should return an url with help for that 3122 | symbol, or nil if no help is available.") 3123 | 3124 | (defun dyalog-custom-help-for-symbol (sym-name) 3125 | "Return the result of calling `dyalog-help-for-symbol-function with SYM-NAME." 3126 | (when dyalog-help-for-symbol-function 3127 | (funcall dyalog-help-for-symbol-function sym-name))) 3128 | 3129 | (defun dyalog-help-for-symbol-at-point () 3130 | "Open the web page with documentation on the symbol at point. 3131 | This function uses `browse-url` to open the documentation web 3132 | page, so you can set `browse-url-function` to customize what 3133 | browser is used for Dyalog documentation." 3134 | (interactive) 3135 | (let* ((sym (dyalog-help-symbol-at-point)) 3136 | (default-url (gethash (downcase sym) dyalog-help-url-map)) 3137 | (custom-url (dyalog-custom-help-for-symbol sym)) 3138 | (url (or custom-url default-url 3139 | (cond ((equal (aref sym 0) ?⎕) 3140 | (concat dyalog-help-root 3141 | "Language/System Functions/" 3142 | (downcase (substring sym 1)) 3143 | dyalog-help-suffix)) 3144 | ((equal (aref sym 0) ?:) 3145 | (concat dyalog-help-root 3146 | "Language/Control Structures/" 3147 | (downcase (substring sym 1)) 3148 | dyalog-help-suffix)))))) 3149 | (when url 3150 | (browse-url url t)))) 3151 | 3152 | (eval-after-load "which-func" 3153 | '(when (listp which-func-modes) 3154 | (add-to-list 'which-func-modes 'dyalog-mode))) 3155 | 3156 | ;;;###autoload 3157 | (define-derived-mode dyalog-mode prog-mode "Dyalog" 3158 | "Major mode for editing Dyalog APL code. 3159 | 3160 | \\{dyalog-mode-map}" 3161 | :group 'dyalog 3162 | :syntax-table dyalog-mode-syntax-table 3163 | (set (make-local-variable 'syntax-propertize-function) 3164 | #'dyalog-syntax-propertize-function) 3165 | (set (make-local-variable 'parse-sexp-ignore-comments) t) 3166 | (set (make-local-variable 'parse-sexp-lookup-properties) t) 3167 | (set (make-local-variable 'beginning-of-defun-function) 3168 | 'dyalog-beginning-of-defun) 3169 | (set (make-local-variable 'end-of-defun-function) 'dyalog-end-of-defun) 3170 | ;; Comments 3171 | (set (make-local-variable 'comment-start) "⍝ ") 3172 | (set (make-local-variable 'comment-start-skip) "⍝+\\s-*") 3173 | (set (make-local-variable 'comment-use-syntax) t) 3174 | (set (make-local-variable 'comment-auto-fill-only-comments) t) 3175 | (set (make-local-variable 'font-lock-defaults) '(dyalog-font-lock-keywords)) 3176 | ;; Dyalog always indents with spaces 3177 | (set (make-local-variable 'indent-tabs-mode) nil) 3178 | (set (make-local-variable 'indent-line-function) 'dyalog-indent-line) 3179 | (set (make-local-variable 'indent-region-function) 'dyalog-indent-region) 3180 | (set (make-local-variable 'dyalog-buffer-type) (dyalog-guess-buffer-type)) 3181 | ;; Misc 3182 | (set (make-local-variable 'require-final-newline) nil) 3183 | ;; Socket connection 3184 | (set (make-local-variable 'dyalog-connection) nil) 3185 | ;; Imenu and which-func-mode 3186 | (set (make-local-variable 'imenu-create-index-function) 3187 | #'dyalog-imenu-create-index) 3188 | (add-hook 'which-func-functions 'dyalog-current-defun nil 'make-it-local) 3189 | ;; Hooks 3190 | (add-hook 'before-save-hook 3191 | 'dyalog-fix-whitespace-before-save nil 'make-it-local)) 3192 | 3193 | ;;;###autoload 3194 | (define-derived-mode dyalog-array-mode fundamental-mode "DyalogArr" 3195 | "Major mode for editing Dyalog APL arrays. 3196 | 3197 | \\{dyalog-array-mode-map\\}" 3198 | :syntax-table dyalog-array-mode-syntax-table 3199 | (set (make-local-variable 'require-final-newline) nil) 3200 | (set (make-local-variable 'dyalog-connection) nil)) 3201 | 3202 | ;;;###autoload 3203 | (add-to-list 'auto-mode-alist '("\\.dyalog$" . dyalog-mode)) 3204 | 3205 | 3206 | (provide 'dyalog-mode) 3207 | 3208 | ;;; dyalog-mode.el ends here 3209 | -------------------------------------------------------------------------------- /melpa_recipe.txt: -------------------------------------------------------------------------------- 1 | (dyalog-mode 2 | :fetcher github 3 | :repo "harsman/dyalog-mode" 4 | :files (:defaults "Emacs.apl")) 5 | --------------------------------------------------------------------------------