Merge branch 'master' into core-updates

5 files changed, 113 insertions, 37 deletions

diff --git a/guix/inferior.scm b/guix/inferior.scm
index 6b685ece30..c9a5ee5129 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -66,6 +66,7 @@
             inferior-exception?
             inferior-exception-arguments
             inferior-exception-inferior
+            inferior-exception-stack
             read-repl-response
 
             inferior-packages
@@ -159,6 +160,15 @@ inferior."
      (letrec ((result (inferior 'pipe pipe close (cons 0 rest)
                                 (delay (%inferior-packages result))
                                 (delay (%inferior-package-table result)))))
+
+       ;; For protocol (0 1) and later, send the protocol version we support.
+       (match rest
+         ((n _ ...)
+          (when (>= n 1)
+            (send-inferior-request '(() repl-version 0 1 1) result)))
+         (_
+          #t))
+
        (inferior-eval '(use-modules (guix)) result)
        (inferior-eval '(use-modules (gnu)) result)
        (inferior-eval '(use-modules (ice-9 match)) result)
@@ -202,7 +212,8 @@ equivalent.  Return #f if the inferior could not be launched."
 (define-condition-type &inferior-exception &error
   inferior-exception?
   (arguments  inferior-exception-arguments)       ;key + arguments
-  (inferior   inferior-exception-inferior))       ;<inferior> | #f
+  (inferior   inferior-exception-inferior)        ;<inferior> | #f
+  (stack      inferior-exception-stack))          ;list of (FILE COLUMN LINE)
 
 (define* (read-repl-response port #:optional inferior)
   "Read a (guix repl) response from PORT and return it as a Scheme object.
@@ -217,10 +228,19 @@ Raise '&inferior-exception' when an exception is read from PORT."
   (match (read port)
     (('values objects ...)
      (apply values (map sexp->object objects)))
+    (('exception ('arguments key objects ...)
+                 ('stack frames ...))
+     ;; Protocol (0 1 1) and later.
+     (raise (condition (&inferior-exception
+                        (arguments (cons key (map sexp->object objects)))
+                        (inferior inferior)
+                        (stack frames)))))
     (('exception key objects ...)
+     ;; Protocol (0 0).
      (raise (condition (&inferior-exception
                         (arguments (cons key (map sexp->object objects)))
-                        (inferior inferior)))))))
+                        (inferior inferior)
+                        (stack '())))))))
 
 (define (read-inferior-response inferior)
   (read-repl-response (inferior-socket inferior)
diff --git a/guix/lint.scm b/guix/lint.scm
index 24fbf05202..40bddd0a41 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -317,6 +317,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as
             "python-pytest-cov" "python2-pytest-cov"
             "python-setuptools-scm" "python2-setuptools-scm"
             "python-sphinx" "python2-sphinx"
+            "scdoc"
             "swig"
             "qmake"
             "qttools"
diff --git a/guix/packages.scm b/guix/packages.scm
index d925e754a3..5c6d1a92d5 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -355,25 +355,24 @@ object."
      (catch 'system-error
        (lambda ()
          ;; In general we want to keep relative file names for modules.
-         (with-fluids ((%file-port-name-canonicalization 'relative))
-           (call-with-input-file (search-path %load-path file)
-             (lambda (port)
-               (goto port line column)
-               (match (read port)
-                 (('package inits ...)
-                  (let ((field (assoc field inits)))
-                    (match field
-                      ((_ value)
-                       ;; Put the `or' here, and not in the first argument of
-                       ;; `and=>', to work around a compiler bug in 2.0.5.
-                       (or (and=> (source-properties value)
-                                  source-properties->location)
-                           (and=> (source-properties field)
-                                  source-properties->location)))
-                      (_
-                       #f))))
-                 (_
-                  #f))))))
+         (call-with-input-file (search-path %load-path file)
+           (lambda (port)
+             (goto port line column)
+             (match (read port)
+               (('package inits ...)
+                (let ((field (assoc field inits)))
+                  (match field
+                    ((_ value)
+                     (let ((props (source-properties value)))
+                       (and props
+                            ;; Preserve the original file name, which may be a
+                            ;; relative file name.
+                            (let ((loc (source-properties->location props)))
+                              (set-field loc (location-file) file)))))
+                    (_
+                     #f))))
+               (_
+                #f)))))
        (lambda _
          #f)))
     (_ #f)))
diff --git a/guix/repl.scm b/guix/repl.scm
index 0f75f9cd0b..0ace5976cf 100644
--- a/guix/repl.scm
+++ b/guix/repl.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,6 +17,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix repl)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (send-repl-response
             machine-repl))
@@ -39,15 +41,53 @@
     (one-of symbol? string? keyword? pair? null? array?
             number? boolean? char?)))
 
-(define (send-repl-response exp output)
+(define repl-prompt
+  ;; Current REPL prompt or #f.
+  (make-parameter #f))
+
+(define (stack->frames stack)
+  "Return STACK's frames as a list."
+  (unfold (cute >= <> (stack-length stack))
+          (cut stack-ref stack <>)
+          1+
+          0))
+
+(define* (send-repl-response exp output
+                             #:key (version '(0 0)))
   "Write the response corresponding to the evaluation of EXP to PORT, an
-output port."
+output port.  VERSION is the client's protocol version we are targeting."
   (define (value->sexp value)
     (if (self-quoting? value)
         `(value ,value)
         `(non-self-quoting ,(object-address value)
                            ,(object->string value))))
 
+  (define (frame->sexp frame)
+    `(,(frame-procedure-name frame)
+      ,(match (frame-source frame)
+         ((_ (? string? file) (? integer? line) . (? integer? column))
+          (list file line column))
+         (_
+          '(#f #f #f)))))
+
+  (define (handle-exception key . args)
+    (define reply
+      (match version
+        ((0 1 (? positive?) _ ...)
+         ;; Protocol (0 1 1) and later.
+         (let ((stack (if (repl-prompt)
+                          (make-stack #t handle-exception (repl-prompt))
+                          (make-stack #t))))
+           `(exception (arguments ,key ,@(map value->sexp args))
+                       (stack ,@(map frame->sexp (stack->frames stack))))))
+        (_
+         ;; Protocol (0 0).
+         `(exception ,key ,@(map value->sexp args)))))
+
+    (write reply output)
+    (newline output)
+    (force-output output))
+
   (catch #t
     (lambda ()
       (let ((results (call-with-values
@@ -58,10 +98,8 @@ output port."
                output)
         (newline output)
         (force-output output)))
-    (lambda (key . args)
-      (write `(exception ,key ,@(map value->sexp args)))
-      (newline output)
-      (force-output output))))
+    (const #t)
+    handle-exception))
 
 (define* (machine-repl #:optional
                        (input (current-input-port))
@@ -72,13 +110,33 @@ The protocol of this REPL is meant to be machine-readable and provides proper
 support to represent multiple-value returns, exceptions, objects that lack a
 read syntax, and so on.  As such it is more convenient and robust than parsing
 Guile's REPL prompt."
-  (write `(repl-version 0 0) output)
-  (newline output)
-  (force-output output)
+  (define tag
+    (make-prompt-tag "repl-prompt"))
 
-  (let loop ()
-    (match (read input)
+  (define (loop exp version)
+    (match exp
       ((? eof-object?) #t)
       (exp
-       (send-repl-response exp output)
-       (loop)))))
+       (send-repl-response exp output
+                           #:version version)
+       (loop (read input) version))))
+
+  (write `(repl-version 0 1 1) output)
+  (newline output)
+  (force-output output)
+
+  ;; In protocol version (0 0), clients would not send their supported
+  ;; protocol version.  Thus, the code below checks for two case: (1) a (0 0)
+  ;; client that directly sends an expression to evaluate, and (2) a more
+  ;; recent client that sends (() repl-version ...).  This form is chosen to
+  ;; be unambiguously distinguishable from a regular Scheme expression.
+
+  (call-with-prompt tag
+    (lambda ()
+      (parameterize ((repl-prompt tag))
+        (match (read input)
+          ((() 'repl-version version ...)
+           (loop (read input) version))
+          (exp
+           (loop exp '(0 0))))))
+    (const #f)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 792c458850..bdddc11b7b 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -42,8 +42,6 @@
   #:autoload   (guix store roots) (gc-roots user-owned?)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
-  #:use-module ((guix build syscalls)
-                #:select (with-file-lock/no-wait))
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)