forked from slime/slime
/
scl.lisp
1728 lines (1488 loc) · 66.1 KB
/
scl.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
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
91
92
93
94
95
96
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
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
;;;
;;; Scieneer Common Lisp code for SLIME.
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(defpackage swank/scl
(:use cl swank/backend swank/source-path-parser swank/source-file-cache))
(in-package swank/scl)
;;; swank-mop
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
(documentation slot t))
;;;; TCP server
;;;
;;; SCL only supports the :spawn communication style.
;;;
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port &key backlog)
(let ((addr (resolve-hostname host)))
(ext:create-inet-listener port :stream :host addr :reuse-address t
:backlog (or backlog 5))))
(defimplementation local-addr (socket)
(nth-value 0 (ext::get-socket-host-and-port (socket-fd socket))))
(defimplementation local-port (socket)
(nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
(defimplementation close-socket (socket)
(ext:close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(let ((buffering (or buffering :full))
(fd (socket-fd socket)))
(loop
(let ((ready (sys:wait-until-fd-usable fd :input timeout)))
(unless ready
(error "Timeout accepting connection on socket: ~S~%" socket)))
(let ((new-fd (ignore-errors (ext:accept-tcp-connection fd))))
(when new-fd
(return (make-socket-io-stream new-fd external-format
(ecase buffering
((t) :full)
((nil) :none)
(:line :line)))))))))
(defimplementation set-stream-timeout (stream timeout)
(check-type timeout (or null real))
(if (fboundp 'ext::stream-timeout)
(setf (ext::stream-timeout stream) timeout)
(setf (slot-value (slot-value stream 'lisp::stream) 'lisp::timeout)
timeout)))
;;;;; Sockets
(defun socket-fd (socket)
"Return the file descriptor for the socket represented by 'socket."
(etypecase socket
(fixnum socket)
(stream (sys:fd-stream-fd socket))))
(defun resolve-hostname (hostname)
"Return the IP address of 'hostname as an integer (in host byte-order)."
(let ((hostent (ext:lookup-host-entry hostname)))
(car (ext:host-entry-addr-list hostent))))
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")
(:euc-jp "euc-jp" "euc-jp-unix")))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defun make-socket-io-stream (fd external-format buffering)
"Create a new input/output fd-stream for 'fd."
(cond ((not external-format)
(sys:make-fd-stream fd :input t :output t :buffering buffering
:element-type '(unsigned-byte 8)))
(t
(let* ((stream (sys:make-fd-stream fd :input t :output t
:element-type 'base-char
:buffering buffering
:external-format external-format)))
;; Ignore character conversion errors. Without this the
;; communication channel is prone to lockup if a character
;; conversion error occurs.
(setf (lisp::character-conversion-stream-input-error-value stream)
#\?)
(setf (lisp::character-conversion-stream-output-error-value stream)
#\?)
stream))))
;;;; Stream handling
(defimplementation gray-package-name ()
'#:ext)
;;;; Compilation Commands
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
(defvar *previous-context* nil
"Previous compiler error context.")
(defvar *buffer-name* nil
"The name of the Emacs buffer we are compiling from.
Nil if we aren't compiling from a buffer.")
(defvar *buffer-start-position* nil)
(defvar *buffer-substring* nil)
(defimplementation call-with-compilation-hooks (function)
(let ((*previous-compiler-condition* nil)
(*previous-context* nil)
(*print-readably* nil))
(handler-bind ((c::compiler-error #'handle-notification-condition)
(c::style-warning #'handle-notification-condition)
(c::warning #'handle-notification-condition))
(funcall function))))
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-compilation-hooks ()
(let ((*buffer-name* nil)
(ext:*ignore-extra-close-parentheses* nil))
(multiple-value-bind (output-file warnings-p failure-p)
(compile-file input-file
:output-file output-file
:external-format external-format)
(values output-file warnings-p
(or failure-p
(when load-p
;; Cache the latest source file for definition-finding.
(source-cache-get input-file
(file-write-date input-file))
(not (load output-file)))))))))
(defimplementation swank-compile-string (string &key buffer position filename
line column policy)
(declare (ignore filename line column policy))
(with-compilation-hooks ()
(let ((*buffer-name* buffer)
(*buffer-start-position* position)
(*buffer-substring* string))
(with-input-from-string (stream string)
(ext:compile-from-stream
stream
:source-info `(:emacs-buffer ,buffer
:emacs-buffer-offset ,position
:emacs-buffer-string ,string))))))
;;;;; Trapping notes
;;;
;;; We intercept conditions from the compiler and resignal them as
;;; `swank:compiler-condition's.
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning."
(unless (eq condition *previous-compiler-condition*)
(let ((context (c::find-error-context nil)))
(setq *previous-compiler-condition* condition)
(setq *previous-context* context)
(signal-compiler-condition condition context))))
(defun signal-compiler-condition (condition context)
(signal 'compiler-condition
:original-condition condition
:severity (severity-for-emacs condition)
:message (brief-compiler-message-for-emacs condition)
:source-context (compiler-error-context context)
:location (if (read-error-p condition)
(read-error-location condition)
(compiler-note-location context))))
(defun severity-for-emacs (condition)
"Return the severity of 'condition."
(etypecase condition
((satisfies read-error-p) :read-error)
(c::compiler-error :error)
(c::style-warning :note)
(c::warning :warning)))
(defun read-error-p (condition)
(eq (type-of condition) 'c::compiler-read-error))
(defun brief-compiler-message-for-emacs (condition)
"Briefly describe a compiler error for Emacs.
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
(princ-to-string condition))
(defun compiler-error-context (error-context)
"Describe a compiler error for Emacs including context information."
(declare (type (or c::compiler-error-context null) error-context))
(multiple-value-bind (enclosing source)
(if error-context
(values (c::compiler-error-context-enclosing-source error-context)
(c::compiler-error-context-source error-context)))
(if (and enclosing source)
(format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]"
enclosing source))))
(defun read-error-location (condition)
(let* ((finfo (car (c::source-info-current-file c::*source-info*)))
(file (c::file-info-name finfo))
(pos (c::compiler-read-error-position condition)))
(cond ((and (eq file :stream) *buffer-name*)
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position* pos)))
((and (pathnamep file) (not *buffer-name*))
(make-location (list :file (unix-truename file))
(list :position (1+ pos))))
(t (break)))))
(defun compiler-note-location (context)
"Derive the location of a complier message from its context.
Return a `location' record, or (:error <reason>) on failure."
(if (null context)
(note-error-location)
(let ((file (c::compiler-error-context-file-name context))
(source (c::compiler-error-context-original-source context))
(path
(reverse
(c::compiler-error-context-original-source-path context))))
(or (locate-compiler-note file source path)
(note-error-location)))))
(defun note-error-location ()
"Pseudo-location for notes that can't be located."
(list :error "No error location available."))
(defun locate-compiler-note (file source source-path)
(cond ((and (eq file :stream) *buffer-name*)
;; Compiling from a buffer
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-start-position*
(source-path-string-position
source-path *buffer-substring*))))
((and (pathnamep file) (null *buffer-name*))
;; Compiling from a file
(make-location (list :file (unix-truename file))
(list :position (1+ (source-path-file-position
source-path file)))))
((and (eq file :lisp) (stringp source))
;; No location known, but we have the source form.
;; XXX How is this case triggered? -luke (16/May/2004)
;; This can happen if the compiler needs to expand a macro
;; but the macro-expander is not yet compiled. Calling the
;; (interpreted) macro-expander triggers IR1 conversion of
;; the lambda expression for the expander and invokes the
;; compiler recursively.
(make-location (list :source-form source)
(list :position 1)))))
(defun unix-truename (pathname)
(ext:unix-namestring (truename pathname)))
;;; TODO
(defimplementation who-calls (name) nil)
(defimplementation who-references (name) nil)
(defimplementation who-binds (name) nil)
(defimplementation who-sets (name) nil)
(defimplementation who-specializes (symbol) nil)
(defimplementation who-macroexpands (name) nil)
;;;; Find callers and callees
;;;
;;; Find callers and callees by looking at the constant pool of
;;; compiled code objects. We assume every fdefn object in the
;;; constant pool corresponds to a call to that function. A better
;;; strategy would be to use the disassembler to find actual
;;; call-sites.
(declaim (inline map-code-constants))
(defun map-code-constants (code fn)
"Call 'fn for each constant in 'code's constant pool."
(check-type code kernel:code-component)
(loop for i from vm:code-constants-offset below (kernel:get-header-data code)
do (funcall fn (kernel:code-header-ref code i))))
(defun function-callees (function)
"Return 'function's callees as a list of functions."
(let ((callees '()))
(map-code-constants
(vm::find-code-object function)
(lambda (obj)
(when (kernel:fdefn-p obj)
(push (kernel:fdefn-function obj) callees))))
callees))
(declaim (ext:maybe-inline map-allocated-code-components))
(defun map-allocated-code-components (spaces fn)
"Call FN for each allocated code component in one of 'spaces. FN
receives the object as argument. 'spaces should be a list of the
symbols :dynamic, :static, or :read-only."
(dolist (space spaces)
(declare (inline vm::map-allocated-objects)
(optimize (ext:inhibit-warnings 3)))
(vm::map-allocated-objects
(lambda (obj header size)
(declare (type fixnum size) (ignore size))
(when (= vm:code-header-type header)
(funcall fn obj)))
space)))
(declaim (ext:maybe-inline map-caller-code-components))
(defun map-caller-code-components (function spaces fn)
"Call 'fn for each code component with a fdefn for 'function in its
constant pool."
(let ((function (coerce function 'function)))
(declare (inline map-allocated-code-components))
(map-allocated-code-components
spaces
(lambda (obj)
(map-code-constants
obj
(lambda (constant)
(when (and (kernel:fdefn-p constant)
(eq (kernel:fdefn-function constant)
function))
(funcall fn obj))))))))
(defun function-callers (function &optional (spaces '(:read-only :static
:dynamic)))
"Return 'function's callers. The result is a list of code-objects."
(let ((referrers '()))
(declare (inline map-caller-code-components))
(map-caller-code-components function spaces
(lambda (code) (push code referrers)))
referrers))
(defun debug-info-definitions (debug-info)
"Return the defintions for a debug-info. This should only be used
for code-object without entry points, i.e., byte compiled
code (are theree others?)"
;; This mess has only been tested with #'ext::skip-whitespace, a
;; byte-compiled caller of #'read-char .
(check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
(let ((name (c::debug-info-name debug-info))
(source (c::debug-info-source debug-info)))
(destructuring-bind (first) source
(ecase (c::debug-source-from first)
(:file
(list (list name
(make-location
(list :file (unix-truename (c::debug-source-name first)))
(list :function-name (string name))))))))))
(defun valid-function-name-p (name)
(or (symbolp name) (and (consp name)
(eq (car name) 'setf)
(symbolp (cadr name))
(not (cddr name)))))
(defun code-component-entry-points (code)
"Return a list ((name location) ...) of function definitons for
the code omponent 'code."
(let ((names '()))
(do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
((not f))
(let ((name (kernel:%function-name f)))
(when (valid-function-name-p name)
(push (list name (function-location f)) names))))
names))
(defimplementation list-callers (symbol)
"Return a list ((name location) ...) of callers."
(let ((components (function-callers symbol))
(xrefs '()))
(dolist (code components)
(let* ((entry (kernel:%code-entry-points code))
(defs (if entry
(code-component-entry-points code)
;; byte compiled stuff
(debug-info-definitions
(kernel:%code-debug-info code)))))
(setq xrefs (nconc defs xrefs))))
xrefs))
(defimplementation list-callees (symbol)
(let ((fns (function-callees symbol)))
(mapcar (lambda (fn)
(list (kernel:%function-name fn)
(function-location fn)))
fns)))
;;;; Resolving source locations
;;;
;;; Our mission here is to "resolve" references to code locations into
;;; actual file/buffer names and character positions. The references
;;; we work from come out of the compiler's statically-generated debug
;;; information, such as `code-location''s and `debug-source''s. For
;;; more details, see the "Debugger Programmer's Interface" section of
;;; the SCL manual.
;;;
;;; The first step is usually to find the corresponding "source-path"
;;; for the location. Once we have the source-path we can pull up the
;;; source file and `READ' our way through to the right position. The
;;; main source-code groveling work is done in
;;; `source-path-parser.lisp'.
(defvar *debug-definition-finding* nil
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
(defmacro safe-definition-finding (&body body)
"Execute 'body and return the source-location it returns.
If an error occurs and `*debug-definition-finding*' is false, then
return an error pseudo-location.
The second return value is 'nil if no error occurs, otherwise it is the
condition object."
`(flet ((body () ,@body))
(if *debug-definition-finding*
(body)
(handler-case (values (progn ,@body) nil)
(error (c) (values (list :error (princ-to-string c)) c))))))
(defun code-location-source-location (code-location)
"Safe wrapper around `code-location-from-source-location'."
(safe-definition-finding
(source-location-from-code-location code-location)))
(defun source-location-from-code-location (code-location)
"Return the source location for 'code-location."
(let ((debug-fun (di:code-location-debug-function code-location)))
(when (di::bogus-debug-function-p debug-fun)
;; Those lousy cheapskates! They've put in a bogus debug source
;; because the code was compiled at a low debug setting.
(error "Bogus debug function: ~A" debug-fun)))
(let* ((debug-source (di:code-location-debug-source code-location))
(from (di:debug-source-from debug-source))
(name (di:debug-source-name debug-source)))
(ecase from
(:file
(location-in-file name code-location debug-source))
(:stream
(location-in-stream code-location debug-source))
(:lisp
;; The location comes from a form passed to `compile'.
;; The best we can do is return the form itself for printing.
(make-location
(list :source-form (with-output-to-string (*standard-output*)
(debug::print-code-location-source-form
code-location 100 t)))
(list :position 1))))))
(defun location-in-file (filename code-location debug-source)
"Resolve the source location for 'code-location in 'filename."
(let* ((code-date (di:debug-source-created debug-source))
(source-code (get-source-code filename code-date)))
(with-input-from-string (s source-code)
(make-location (list :file (unix-truename filename))
(list :position (1+ (code-location-stream-position
code-location s)))
`(:snippet ,(read-snippet s))))))
(defun location-in-stream (code-location debug-source)
"Resolve the source location for a 'code-location from a stream.
This only succeeds if the code was compiled from an Emacs buffer."
(unless (debug-source-info-from-emacs-buffer-p debug-source)
(error "The code is compiled from a non-SLIME stream."))
(let* ((info (c::debug-source-info debug-source))
(string (getf info :emacs-buffer-string))
(position (code-location-string-offset
code-location
string)))
(make-location
(list :buffer (getf info :emacs-buffer))
(list :offset (getf info :emacs-buffer-offset) position)
(list :snippet (with-input-from-string (s string)
(file-position s position)
(read-snippet s))))))
;;;;; Function-name locations
;;;
(defun debug-info-function-name-location (debug-info)
"Return a function-name source-location for 'debug-info.
Function-name source-locations are a fallback for when precise
positions aren't available."
(with-struct (c::debug-info- (fname name) source) debug-info
(with-struct (c::debug-source- info from name) (car source)
(ecase from
(:file
(make-location (list :file (namestring (truename name)))
(list :function-name (string fname))))
(:stream
(assert (debug-source-info-from-emacs-buffer-p (car source)))
(make-location (list :buffer (getf info :emacs-buffer))
(list :function-name (string fname))))
(:lisp
(make-location (list :source-form (princ-to-string (aref name 0)))
(list :position 1)))))))
(defun debug-source-info-from-emacs-buffer-p (debug-source)
"Does the `info' slot of 'debug-source contain an Emacs buffer location?
This is true for functions that were compiled directly from buffers."
(info-from-emacs-buffer-p (c::debug-source-info debug-source)))
(defun info-from-emacs-buffer-p (info)
(and info
(consp info)
(eq :emacs-buffer (car info))))
;;;;; Groveling source-code for positions
(defun code-location-stream-position (code-location stream)
"Return the byte offset of 'code-location in 'stream. Extract the
toplevel-form-number and form-number from 'code-location and use that
to find the position of the corresponding form.
Finish with 'stream positioned at the start of the code location."
(let* ((location (debug::maybe-block-start-location code-location))
(tlf-offset (di:code-location-top-level-form-offset location))
(form-number (di:code-location-form-number location)))
(let ((pos (form-number-stream-position tlf-offset form-number stream)))
(file-position stream pos)
pos)))
(defun form-number-stream-position (tlf-number form-number stream)
"Return the starting character position of a form in 'stream.
'tlf-number is the top-level-form number.
'form-number is an index into a source-path table for the TLF."
(multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
(let* ((path-table (di:form-number-translations tlf 0))
(source-path
(if (<= (length path-table) form-number) ; source out of sync?
(list 0) ; should probably signal a condition
(reverse (cdr (aref path-table form-number))))))
(source-path-source-position source-path tlf position-map))))
(defun code-location-string-offset (code-location string)
"Return the byte offset of 'code-location in 'string.
See 'code-location-stream-position."
(with-input-from-string (s string)
(code-location-stream-position code-location s)))
;;;; Finding definitions
;;; There are a great many different types of definition for us to
;;; find. We search for definitions of every kind and return them in a
;;; list.
(defimplementation find-definitions (name)
(append (function-definitions name)
(setf-definitions name)
(variable-definitions name)
(class-definitions name)
(type-definitions name)
(compiler-macro-definitions name)
(source-transform-definitions name)
(function-info-definitions name)
(ir1-translator-definitions name)))
;;;;; Functions, macros, generic functions, methods
;;;
;;; We make extensive use of the compile-time debug information that
;;; SCL records, in particular "debug functions" and "code
;;; locations." Refer to the "Debugger Programmer's Interface" section
;;; of the SCL manual for more details.
(defun function-definitions (name)
"Return definitions for 'name in the \"function namespace\", i.e.,
regular functions, generic functions, methods and macros.
'name can any valid function name (e.g, (setf car))."
(let ((macro? (and (symbolp name) (macro-function name)))
(special? (and (symbolp name) (special-operator-p name)))
(function? (and (valid-function-name-p name)
(ext:info :function :definition name)
(if (symbolp name) (fboundp name) t))))
(cond (macro?
(list `((defmacro ,name)
,(function-location (macro-function name)))))
(special?
(list `((:special-operator ,name)
(:error ,(format nil "Special operator: ~S" name)))))
(function?
(let ((function (fdefinition name)))
(if (genericp function)
(generic-function-definitions name function)
(list (list `(function ,name)
(function-location function)))))))))
;;;;;; Ordinary (non-generic/macro/special) functions
;;;
;;; First we test if FUNCTION is a closure created by defstruct, and
;;; if so extract the defstruct-description (`dd') from the closure
;;; and find the constructor for the struct. Defstruct creates a
;;; defun for the default constructor and we use that as an
;;; approximation to the source location of the defstruct.
;;;
;;; For an ordinary function we return the source location of the
;;; first code-location we find.
;;;
(defun function-location (function)
"Return the source location for FUNCTION."
(cond ((struct-closure-p function)
(struct-closure-location function))
((c::byte-function-or-closure-p function)
(byte-function-location function))
(t
(compiled-function-location function))))
(defun compiled-function-location (function)
"Return the location of a regular compiled function."
(multiple-value-bind (code-location error)
(safe-definition-finding (function-first-code-location function))
(cond (error (list :error (princ-to-string error)))
(t (code-location-source-location code-location)))))
(defun function-first-code-location (function)
"Return the first code-location we can find for 'function."
(and (function-has-debug-function-p function)
(di:debug-function-start-location
(di:function-debug-function function))))
(defun function-has-debug-function-p (function)
(di:function-debug-function function))
(defun function-code-object= (closure function)
(and (eq (vm::find-code-object closure)
(vm::find-code-object function))
(not (eq closure function))))
(defun byte-function-location (fn)
"Return the location of the byte-compiled function 'fn."
(etypecase fn
((or c::hairy-byte-function c::simple-byte-function)
(let* ((component (c::byte-function-component fn))
(debug-info (kernel:%code-debug-info component)))
(debug-info-function-name-location debug-info)))
(c::byte-closure
(byte-function-location (c::byte-closure-function fn)))))
;;; Here we deal with structure accessors. Note that `dd' is a
;;; "defstruct descriptor" structure in SCL. A `dd' describes a
;;; `defstruct''d structure.
(defun struct-closure-p (function)
"Is 'function a closure created by defstruct?"
(or (function-code-object= function #'kernel::structure-slot-accessor)
(function-code-object= function #'kernel::structure-slot-setter)
(function-code-object= function #'kernel::%defstruct)))
(defun struct-closure-location (function)
"Return the location of the structure that 'function belongs to."
(assert (struct-closure-p function))
(safe-definition-finding
(dd-location (struct-closure-dd function))))
(defun struct-closure-dd (function)
"Return the defstruct-definition (dd) of FUNCTION."
(assert (= (kernel:get-type function) vm:closure-header-type))
(flet ((find-layout (function)
(sys:find-if-in-closure
(lambda (x)
(let ((value (if (di::indirect-value-cell-p x)
(c:value-cell-ref x)
x)))
(when (kernel::layout-p value)
(return-from find-layout value))))
function)))
(kernel:layout-info (find-layout function))))
(defun dd-location (dd)
"Return the location of a `defstruct'."
;; Find the location in a constructor.
(function-location (struct-constructor dd)))
(defun struct-constructor (dd)
"Return a constructor function from a defstruct definition.
Signal an error if no constructor can be found."
(let ((constructor (or (kernel:dd-default-constructor dd)
(car (kernel::dd-constructors dd)))))
(when (or (null constructor)
(and (consp constructor) (null (car constructor))))
(error "Cannot find structure's constructor: ~S"
(kernel::dd-name dd)))
(coerce (if (consp constructor) (first constructor) constructor)
'function)))
;;;;;; Generic functions and methods
(defun generic-function-definitions (name function)
"Return the definitions of a generic function and its methods."
(cons (list `(defgeneric ,name) (gf-location function))
(gf-method-definitions function)))
(defun gf-location (gf)
"Return the location of the generic function GF."
(definition-source-location gf (clos:generic-function-name gf)))
(defun gf-method-definitions (gf)
"Return the locations of all methods of the generic function GF."
(mapcar #'method-definition (clos:generic-function-methods gf)))
(defun method-definition (method)
(list (method-dspec method)
(method-location method)))
(defun method-dspec (method)
"Return a human-readable \"definition specifier\" for METHOD."
(let* ((gf (clos:method-generic-function method))
(name (clos:generic-function-name gf))
(specializers (clos:method-specializers method))
(qualifiers (clos:method-qualifiers method)))
`(method ,name ,@qualifiers ,specializers
#+nil (clos::unparse-specializers specializers))))
;; XXX maybe special case setters/getters
(defun method-location (method)
(function-location (clos:method-function method)))
(defun genericp (fn)
(typep fn 'generic-function))
;;;;;; Types and classes
(defun type-definitions (name)
"Return `deftype' locations for type NAME."
(maybe-make-definition (ext:info :type :expander name) 'deftype name))
(defun maybe-make-definition (function kind name)
"If FUNCTION is non-nil then return its definition location."
(if function
(list (list `(,kind ,name) (function-location function)))))
(defun class-definitions (name)
"Return the definition locations for the class called NAME."
(if (symbolp name)
(let ((class (find-class name nil)))
(etypecase class
(null '())
(structure-class
(list (list `(defstruct ,name)
(dd-location (find-dd name)))))
(standard-class
(list (list `(defclass ,name)
(class-location (find-class name)))))
((or built-in-class
kernel:funcallable-structure-class)
(list (list `(kernel::define-type-class ,name)
`(:error
,(format nil "No source info for ~A" name)))))))))
(defun class-location (class)
"Return the `defclass' location for CLASS."
(definition-source-location class (class-name class)))
(defun find-dd (name)
"Find the defstruct-definition by the name of its structure-class."
(let ((layout (ext:info :type :compiler-layout name)))
(if layout
(kernel:layout-info layout))))
(defun condition-class-location (class)
(let ((name (class-name class)))
`(:error ,(format nil "No location info for condition: ~A" name))))
(defun make-name-in-file-location (file string)
(multiple-value-bind (filename c)
(ignore-errors
(unix-truename (merge-pathnames (make-pathname :type "lisp")
file)))
(cond (filename (make-location `(:file ,filename)
`(:function-name ,(string string))))
(t (list :error (princ-to-string c))))))
(defun definition-source-location (object name)
`(:error ,(format nil "No source info for: ~A" object)))
(defun setf-definitions (name)
(let ((function (or (ext:info :setf :inverse name)
(ext:info :setf :expander name))))
(if function
(list (list `(setf ,name)
(function-location (coerce function 'function)))))))
(defun variable-location (symbol)
`(:error ,(format nil "No source info for variable ~S" symbol)))
(defun variable-definitions (name)
(if (symbolp name)
(multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
(if recorded-p
(list (list `(variable ,kind ,name)
(variable-location name)))))))
(defun compiler-macro-definitions (symbol)
(maybe-make-definition (compiler-macro-function symbol)
'define-compiler-macro
symbol))
(defun source-transform-definitions (name)
(maybe-make-definition (ext:info :function :source-transform name)
'c:def-source-transform
name))
(defun function-info-definitions (name)
(let ((info (ext:info :function :info name)))
(if info
(append (loop for transform in (c::function-info-transforms info)
collect (list `(c:deftransform ,name
,(c::type-specifier
(c::transform-type transform)))
(function-location (c::transform-function
transform))))
(maybe-make-definition (c::function-info-derive-type info)
'c::derive-type name)
(maybe-make-definition (c::function-info-optimizer info)
'c::optimizer name)
(maybe-make-definition (c::function-info-ltn-annotate info)
'c::ltn-annotate name)
(maybe-make-definition (c::function-info-ir2-convert info)
'c::ir2-convert name)
(loop for template in (c::function-info-templates info)
collect (list `(c::vop ,(c::template-name template))
(function-location
(c::vop-info-generator-function
template))))))))
(defun ir1-translator-definitions (name)
(maybe-make-definition (ext:info :function :ir1-convert name)
'c:def-ir1-translator name))
;;;; Documentation.
(defimplementation describe-symbol-for-emacs (symbol)
(let ((result '()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(ext:info variable kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((genericp (fdefinition symbol)) :generic-function)
(t :function))
(doc 'function)))
(maybe-push
:setf (if (or (ext:info setf inverse symbol)
(ext:info setf expander symbol))
(doc 'setf)))
(maybe-push
:type (if (ext:info type kind symbol)
(doc 'type)))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
(maybe-push
:alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
(doc 'alien-type)))
(maybe-push
:alien-struct (if (ext:info alien-type struct symbol)
(doc nil)))
(maybe-push
:alien-union (if (ext:info alien-type union symbol)
(doc nil)))
(maybe-push
:alien-enum (if (ext:info alien-type enum symbol)
(doc nil)))
result)))
(defimplementation describe-definition (symbol namespace)
(describe (ecase namespace
(:variable
symbol)
((:function :generic-function)
(symbol-function symbol))
(:setf
(or (ext:info setf inverse symbol)
(ext:info setf expander symbol)))
(:type
(kernel:values-specifier-type symbol))
(:class
(find-class symbol))
(:alien-struct
(ext:info :alien-type :struct symbol))
(:alien-union
(ext:info :alien-type :union symbol))
(:alien-enum
(ext:info :alien-type :enum symbol))
(:alien-type
(ecase (ext:info :alien-type :kind symbol)
(:primitive
(let ((alien::*values-type-okay* t))
(funcall (ext:info :alien-type :translator symbol)
(list symbol))))
((:defined)
(ext:info :alien-type :definition symbol))
(:unknown :unknown))))))
;;;;; Argument lists
(defimplementation arglist (fun)
(multiple-value-bind (args winp)
(ext:function-arglist fun)
(if winp args :not-available)))
(defimplementation function-name (function)
(cond ((eval:interpreted-function-p function)
(eval:interpreted-function-name function))
((typep function 'generic-function)
(clos:generic-function-name function))
((c::byte-function-or-closure-p function)
(c::byte-function-name function))
(t (kernel:%function-name (kernel:%function-self function)))))
;;; A harder case: an approximate arglist is derived from available
;;; debugging information.
(defun debug-function-arglist (debug-function)
"Derive the argument list of DEBUG-FUNCTION from debug info."
(let ((args (di::debug-function-lambda-list debug-function))
(required '())
(optional '())
(rest '())
(key '()))
;; collect the names of debug-vars
(dolist (arg args)
(etypecase arg
(di::debug-variable
(push (di::debug-variable-symbol arg) required))
((member :deleted)
(push ':deleted required))
(cons
(ecase (car arg)
(:keyword
(push (second arg) key))
(:optional
(push (debug-variable-symbol-or-deleted (second arg)) optional))
(:rest
(push (debug-variable-symbol-or-deleted (second arg)) rest))))))
;; intersperse lambda keywords as needed
(append (nreverse required)
(if optional (cons '&optional (nreverse optional)))
(if rest (cons '&rest (nreverse rest)))
(if key (cons '&key (nreverse key))))))
(defun debug-variable-symbol-or-deleted (var)
(etypecase var
(di:debug-variable
(di::debug-variable-symbol var))
((member :deleted)
'#:deleted)))
(defun symbol-debug-function-arglist (fname)
"Return FNAME's debug-function-arglist and %function-arglist.
A utility for debugging DEBUG-FUNCTION-ARGLIST."
(let ((fn (fdefinition fname)))
(values (debug-function-arglist (di::function-debug-function fn))
(kernel:%function-arglist (kernel:%function-self fn)))))
;;;; Miscellaneous.
(defimplementation macroexpand-all (form &optional env)