- (let* ((file-info (source-info-file-info info))
- (res (make-debug-source
- :from :file
- :created (file-info-write-date file-info)
- :compiled (source-info-start-time info)
- :source-root (file-info-source-root file-info)
- :start-positions (coerce-to-smallest-eltype
- (file-info-positions file-info))))
- (name (file-info-name file-info)))
- (etypecase name
- ((member :lisp)
- (setf (debug-source-from res) name)
- (setf (debug-source-name res)
- (coerce (file-info-forms file-info) 'simple-vector)))
- (pathname
- (let* ((untruename (file-info-untruename file-info))
- (dir (pathname-directory untruename)))
- (setf (debug-source-name res)
- #+sb-xc-host
- (let ((src (position "src" dir :test #'string= :from-end t)))
- (if src
- (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
- (subseq dir src) (pathname-name untruename))
- ;; FIXME: just output/stuff-groveled-from-headers.lisp
- (namestring untruename)))
- #-sb-xc-host
- (namestring
- (if (and dir (eq (first dir) :absolute))
- untruename
- name))))))
- (list res)))
+ (let ((file-info (get-toplevelish-file-info info)))
+ (make-debug-source
+ :compiled (source-info-start-time info)
+
+ :namestring (make-file-info-namestring
+ (if (pathnamep (file-info-name file-info))
+ (file-info-name file-info))
+ file-info)
+ :created (file-info-write-date file-info)
+ :source-root (file-info-source-root file-info)
+ :start-positions (coerce-to-smallest-eltype
+ (file-info-positions file-info))
+
+ :form (let ((direct-file-info (source-info-file-info info)))
+ (if (eq :lisp (file-info-name direct-file-info))
+ (elt (file-info-forms direct-file-info) 0)))
+ :function function)))