LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/system/repl/common.scm

@@ -0,0 +1,263 @@
+;;; Repl common routines
+
+;; Copyright (C) 2001, 2008-2016, 2019  Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl common)
+  #:use-module (system base syntax)
+  #:use-module (system base compile)
+  #:use-module (system base language)
+  #:use-module (system base message)
+  #:use-module (system vm program)
+  #:use-module (system vm loader)
+  #:autoload (language tree-il optimize) (optimize)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 history)
+  #:export (<repl> make-repl repl-language repl-options
+            repl-tm-stats repl-gc-stats repl-debug
+            repl-welcome repl-prompt
+            repl-read repl-compile repl-prepare-eval-thunk repl-eval
+            repl-expand repl-optimize
+            repl-parse repl-print repl-option-ref repl-option-set!
+            repl-default-option-set! repl-default-prompt-set!
+            puts ->string user-error
+            *warranty* *copying* *version*))
+
+(define *version*
+  (format #f "GNU Guile ~A
+Copyright (C) 1995-2019 Free Software Foundation, Inc.
+
+Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
+This program is free software, and you are welcome to redistribute it
+under certain conditions; type `,show c' for details." (version)))
+
+(define *copying*
+"Guile is free software: you can redistribute it and/or modify
+it under the terms of the GNU Lesser General Public License as
+published by the Free Software Foundation, either version 3 of
+the License, or (at your option) any later version.
+
+Guile is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this program. If not, see
+<http://www.gnu.org/licenses/lgpl.html>.")
+
+(define *warranty*
+"Guile is distributed WITHOUT ANY WARRANTY. The following
+sections from the GNU General Public License, version 3, should
+make that clear.
+
+  15. Disclaimer of Warranty.
+
+  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY
+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. Limitation of Liability.
+
+  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
+
+  17. Interpretation of Sections 15 and 16.
+
+  If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
+
+
+;;;
+;;; Repl type
+;;;
+
+(define-record/keywords <repl>
+  language options tm-stats gc-stats debug)
+
+(define repl-default-options
+  (copy-tree
+   `((compile-options ,%auto-compilation-options #f)
+     (trace #f #f)
+     (interp #f #f)
+     (prompt #f ,(lambda (prompt)
+                   (cond
+                    ((not prompt) #f)
+                    ((string? prompt) (lambda (repl) prompt))
+                    ((thunk? prompt) (lambda (repl) (prompt)))
+                    ((procedure? prompt) prompt)
+                    (else (error "Invalid prompt" prompt)))))
+     (print #f ,(lambda (print)
+                  (cond
+                   ((not print) #f)
+                   ((procedure? print) print)
+                   (else (error "Invalid print procedure" print)))))
+     (value-history
+      ,(value-history-enabled?)
+      ,(lambda (x)
+         (if x (enable-value-history!) (disable-value-history!))
+         (->bool x)))
+     (on-error
+      debug
+      ,(let ((vals '(debug backtrace report pass)))
+         (lambda (x)
+           (if (memq x vals)
+               x
+               (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
+
+(define %make-repl make-repl)
+(define* (make-repl lang #:optional debug)
+  (%make-repl #:language (if (language? lang)
+                             lang
+                             (lookup-language lang))
+              #:options (copy-tree repl-default-options)
+              #:tm-stats (times)
+              #:gc-stats (gc-stats)
+              #:debug debug))
+
+(define (repl-welcome repl)
+  (display *version*)
+  (newline)
+  (newline)
+  (display "Enter `,help' for help.\n"))
+
+(define (repl-prompt repl)
+  (cond
+   ((repl-option-ref repl 'prompt)
+    => (lambda (prompt) (prompt repl)))
+   (else
+    (format #f "~A@~A~A> " (language-name (repl-language repl))
+            (module-name (current-module))
+            (let ((level (length (cond
+                                  ((fluid-ref *repl-stack*) => cdr)
+                                  (else '())))))
+              (if (zero? level) "" (format #f " [~a]" level)))))))
+
+(define (repl-read repl)
+  (let ((reader (language-reader (repl-language repl))))
+    (reader (current-input-port) (current-module))))
+
+(define (repl-compile-options repl)
+  (repl-option-ref repl 'compile-options))
+
+(define (repl-compile repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (compile form #:from from #:to 'bytecode #:opts opts
+             #:env (current-module))))
+
+(define (repl-expand repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (decompile (compile form #:from from #:to 'tree-il #:opts opts
+                        #:env (current-module))
+               #:from 'tree-il #:to from)))
+
+(define (repl-optimize repl form)
+  (let ((from (repl-language repl))
+        (opts (repl-compile-options repl)))
+    (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+                                  #:env (current-module))
+                         (current-module)
+                         opts)
+               #:from 'tree-il #:to from)))
+
+(define (repl-parse repl form)
+  (let ((parser (language-parser (repl-language repl))))
+    (if parser (parser form) form)))
+
+(define (repl-prepare-eval-thunk repl form)
+  (let* ((eval (language-evaluator (repl-language repl))))
+    (if (and eval
+             (or (null? (language-compilers (repl-language repl)))
+                 (repl-option-ref repl 'interp)))
+        (lambda () (eval form (current-module)))
+        (load-thunk-from-memory (repl-compile repl form)))))
+
+(define (repl-eval repl form)
+  (let ((thunk (repl-prepare-eval-thunk repl form)))
+    (% (thunk))))
+
+(define (repl-print repl val)
+  (if (not (eq? val *unspecified*))
+      (begin
+        (run-hook before-print-hook val)
+        (cond
+         ((repl-option-ref repl 'print)
+          => (lambda (print) (print repl val)))
+         (else
+          ;; The result of an evaluation is representable in scheme, and
+          ;; should be printed with the generic printer, `write'. The
+          ;; language-printer is something else: it prints expressions of
+          ;; a given language, not the result of evaluation.
+          (write val)
+          (newline))))))
+
+(define (repl-option-ref repl key)
+  (cadr (or (assq key (repl-options repl))
+            (error "unknown repl option" key))))
+
+(define (repl-option-set! repl key val)
+  (let ((spec (or (assq key (repl-options repl))
+                  (error "unknown repl option" key))))
+    (set-car! (cdr spec)
+              (if (procedure? (caddr spec))
+                  ((caddr spec) val)
+                  val))))
+
+(define (repl-default-option-set! key val)
+  (let ((spec (or (assq key repl-default-options)
+                  (error "unknown repl option" key))))
+    (set-car! (cdr spec)
+              (if (procedure? (caddr spec))
+                  ((caddr spec) val)
+                  val))))
+
+(define (repl-default-prompt-set! prompt)
+  (repl-default-option-set! 'prompt prompt))
+
+
+;;;
+;;; Utilities
+;;;
+
+(define (puts x) (display x) (newline))
+
+(define (->string x)
+  (object->string x display))
+
+(define (user-error msg . args)
+  (throw 'user-error #f msg args #f))

data/share/guile/2.2/system/repl/coop-server.scm

@@ -0,0 +1,200 @@
+;;; Cooperative REPL server
+
+;; Copyright (C) 2014, 2016 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl coop-server)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 q)
+  #:use-module (srfi srfi-9)
+  #:export (spawn-coop-repl-server
+            poll-coop-repl-server))
+
+;; Hack to import private bindings from (system repl repl).
+(define-syntax-rule (import-private module sym ...)
+  (begin
+    (define sym (@@ module sym))
+    ...))
+(import-private (system repl repl) start-repl* prompting-meta-read)
+(import-private (system repl server)
+                run-server* add-open-socket! close-socket!
+                make-tcp-server-socket guard-against-http-request)
+
+(define-record-type <coop-repl-server>
+  (%make-coop-repl-server mutex queue)
+  coop-repl-server?
+  (mutex coop-repl-server-mutex)
+  (queue coop-repl-server-queue))
+
+(define (make-coop-repl-server)
+  (%make-coop-repl-server (make-mutex) (make-q)))
+
+(define (coop-repl-server-eval coop-server opcode . args)
+  "Queue a new instruction with the symbolic name OPCODE and an arbitrary
+number of arguments, to be processed the next time COOP-SERVER is polled."
+  (with-mutex (coop-repl-server-mutex coop-server)
+    (enq! (coop-repl-server-queue coop-server)
+          (cons opcode args))))
+
+(define-record-type <coop-repl>
+  (%make-coop-repl mutex condvar thunk cont)
+  coop-repl?
+  (mutex coop-repl-mutex)
+  (condvar coop-repl-condvar)  ; signaled when thunk becomes non-#f
+  (thunk coop-repl-read-thunk set-coop-repl-read-thunk!)
+  (cont coop-repl-cont set-coop-repl-cont!))
+
+(define (make-coop-repl)
+  (%make-coop-repl (make-mutex) (make-condition-variable) #f #f))
+
+(define (coop-repl-read coop-repl)
+  "Read an expression via the thunk stored in COOP-REPL."
+  (let ((thunk
+         (with-mutex (coop-repl-mutex coop-repl)
+           (unless (coop-repl-read-thunk coop-repl)
+             (wait-condition-variable (coop-repl-condvar coop-repl)
+                                      (coop-repl-mutex coop-repl)))
+           (let ((thunk (coop-repl-read-thunk coop-repl)))
+             (unless thunk
+               (error "coop-repl-read: condvar signaled, but thunk is #f!"))
+             (set-coop-repl-read-thunk! coop-repl #f)
+             thunk))))
+    (thunk)))
+
+(define (store-repl-cont cont coop-repl)
+  "Save the partial continuation CONT within COOP-REPL."
+  (set-coop-repl-cont! coop-repl
+                       (lambda (exp)
+                         (coop-repl-prompt
+                          (lambda () (cont exp))))))
+
+(define (coop-repl-prompt thunk)
+  "Apply THUNK within a prompt for cooperative REPLs."
+  (call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
+
+(define (make-coop-reader coop-repl)
+  "Return a new procedure for reading user input from COOP-REPL.  The
+generated procedure passes the responsibility of reading input to
+another thread and aborts the cooperative REPL prompt."
+  (lambda (repl)
+    (let ((read-thunk
+           ;; Need to preserve the REPL stack and current module across
+           ;; threads.
+           (let ((stack (fluid-ref *repl-stack*))
+                 (module (current-module)))
+             (lambda ()
+               (with-fluids ((*repl-stack* stack))
+                 (set-current-module module)
+                 (prompting-meta-read repl))))))
+      (with-mutex (coop-repl-mutex coop-repl)
+        (when (coop-repl-read-thunk coop-repl)
+          (error "coop-reader: read-thunk is not #f!"))
+        (set-coop-repl-read-thunk! coop-repl read-thunk)
+        (signal-condition-variable (coop-repl-condvar coop-repl))))
+    (abort-to-prompt 'coop-repl-prompt coop-repl)))
+
+(define (reader-loop coop-server coop-repl)
+  "Run an unbounded loop that reads an expression for COOP-REPL and
+stores the expression within COOP-SERVER for later evaluation."
+  (coop-repl-server-eval coop-server 'eval coop-repl
+                         (coop-repl-read coop-repl))
+  (reader-loop coop-server coop-repl))
+
+(define (poll-coop-repl-server coop-server)
+  "Poll the cooperative REPL server COOP-SERVER and apply a pending
+operation if there is one, such as evaluating an expression typed at the
+REPL prompt.  This procedure must be called from the same thread that
+called spawn-coop-repl-server."
+  (let ((op (with-mutex (coop-repl-server-mutex coop-server)
+              (let ((queue (coop-repl-server-queue coop-server)))
+                (and (not (q-empty? queue))
+                     (deq! queue))))))
+    (when op
+      (match op
+        (('new-repl client)
+         (start-repl-client coop-server client))
+        (('eval coop-repl exp)
+         ((coop-repl-cont coop-repl) exp))))
+    *unspecified*))
+
+(define (start-coop-repl coop-server)
+  "Start a new cooperative REPL process for COOP-SERVER."
+  ;; Calling stop-server-and-clients! from a REPL will cause an
+  ;; exception to be thrown when trying to read from the socket that has
+  ;; been closed, so we catch that here.
+  (false-if-exception
+   (let ((coop-repl (make-coop-repl)))
+     (make-thread reader-loop coop-server coop-repl)
+     (start-repl* (current-language) #f (make-coop-reader coop-repl)))))
+
+(define (run-coop-repl-server coop-server server-socket)
+  "Start the cooperative REPL server for COOP-SERVER using the socket
+SERVER-SOCKET."
+  (run-server* server-socket (make-coop-client-proc coop-server)))
+
+(define* (spawn-coop-repl-server
+          #:optional (server-socket (make-tcp-server-socket)))
+  "Create and return a new cooperative REPL server object, and spawn a
+new thread to listen for connections on SERVER-SOCKET.  Proper
+functioning of the REPL server requires that poll-coop-repl-server be
+called periodically on the returned server object."
+  (let ((coop-server (make-coop-repl-server)))
+    (make-thread run-coop-repl-server
+                 coop-server
+                 server-socket)
+    coop-server))
+
+(define (make-coop-client-proc coop-server)
+  "Return a new procedure that is used to schedule the creation of a new
+cooperative REPL for COOP-SERVER."
+  (lambda (client addr)
+    (coop-repl-server-eval coop-server 'new-repl client)))
+
+(define (start-repl-client coop-server client)
+  "Run a cooperative REPL for COOP-SERVER within a prompt.  All input
+and output is sent over the socket CLIENT."
+
+  ;; Add the client to the list of open sockets, with a 'force-close'
+  ;; procedure that closes the underlying file descriptor.  We do it
+  ;; this way because we cannot close the port itself safely from
+  ;; another thread.
+  (add-open-socket! client (lambda () (close-fdes (fileno client))))
+
+  (guard-against-http-request client)
+
+  (with-continuation-barrier
+   (lambda ()
+     (coop-repl-prompt
+      (lambda ()
+        (parameterize ((current-input-port client)
+                       (current-output-port client)
+                       (current-error-port client)
+                       (current-warning-port client))
+          (with-fluids ((*repl-stack* '()))
+            (save-module-excursion
+             (lambda ()
+               (start-coop-repl coop-server)))))
+
+        ;; This may fail if 'stop-server-and-clients!' is called,
+        ;; because the 'force-close' procedure above closes the
+        ;; underlying file descriptor instead of the port itself.
+        (false-if-exception
+         (close-socket! client)))))))

data/share/guile/2.2/system/repl/debug.scm

@@ -0,0 +1,210 @@
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl debug)
+  #:use-module (system base pmatch)
+  #:use-module (system base syntax)
+  #:use-module (system base language)
+  #:use-module (system vm vm)
+  #:use-module (system vm frame)
+  #:use-module (system vm debug)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 pretty-print)
+  #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+  #:use-module (system vm program)
+  #:export (<debug>
+            make-debug debug?
+            debug-frames debug-index debug-error-message
+            terminal-width
+            print-registers print-locals print-frame print-frames
+            stack->vector narrow-stack->vector
+            frame->stack-vector))
+
+;; TODO:
+;;
+;; eval expression in context of frame
+;; set local variable in frame
+;; step until greater source line
+;; watch expression
+;; set printing width
+;; disassemble the current function
+;; inspect any object
+
+;;;
+;;; Debugger
+;;;
+;;; The actual interaction loop of the debugger is run by the repl. This module
+;;; simply exports a data structure to hold the debugger state, along with its
+;;; accessors, and provides some helper functions.
+;;;
+
+(define-record <debug> frames index error-message)
+
+
+
+;; A fluid, because terminals are usually implicitly associated with
+;; threads.
+;;
+(define terminal-width
+  (let ((set-width (make-fluid)))
+    (case-lambda
+      (()
+       (or (fluid-ref set-width)
+           (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
+             (and (integer? w) (exact? w) (> w 0) w))
+           72))
+      ((w)
+       (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
+           (fluid-set! set-width w)
+           (error "Expected a column number (a positive integer)" w))))))
+
+
+
+
+(define (reverse-hashq h)
+  (let ((ret (make-hash-table)))
+    (hash-for-each
+     (lambda (k v)
+       (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+     h)
+    ret))
+
+(define* (print-registers frame #:optional (port (current-output-port))
+                          #:key (per-line-prefix "  "))
+  (define (print fmt val)
+    (display per-line-prefix port)
+    (run-hook before-print-hook val)
+    (format port fmt val))
+  
+  (format port "~aRegisters:~%" per-line-prefix)
+  (let ((ip (frame-instruction-pointer frame)))
+    (print "ip = #x~x" ip)
+    (let ((info (find-program-debug-info ip)))
+      (when info
+        (let ((addr (program-debug-info-addr info)))
+          (format port " (#x~x + ~d * 4)" addr (/ (- ip addr) 4)))))
+    (newline port))
+  (print "sp = ~a\n" (frame-stack-pointer frame))
+  (print "fp = ~a\n" (frame-address frame)))
+
+(define* (print-locals frame #:optional (port (current-output-port))
+                       #:key (width (terminal-width)) (per-line-prefix "  "))
+  (let ((bindings (frame-bindings frame)))
+    (cond
+     ((null? bindings)
+      (format port "~aNo local variables.~%" per-line-prefix))
+     (else
+      (format port "~aLocal variables:~%" per-line-prefix)
+      (for-each
+       (lambda (binding)
+         (let ((v (binding-ref binding)))
+           (display per-line-prefix port)
+           (run-hook before-print-hook v)
+           (format port "~a = ~v:@y\n" (binding-name binding) width v)))
+       (frame-bindings frame))))))
+
+(define* (print-frame frame #:optional (port (current-output-port))
+                      #:key index (width (terminal-width)) (full? #f)
+                      (last-source #f) next-source?)
+  (define (source:pretty-file source)
+    (if source
+        (or (source:file source) "current input")
+        "unknown file"))
+  (let* ((source (frame-source frame))
+         (file (source:pretty-file source))
+         (line (and=> source source:line-for-user))
+         (col (and=> source source:column)))
+    (if (and file (not (equal? file (source:pretty-file last-source))))
+        (format port "~&In ~a:~&" file))
+    (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%"
+            (if line (format #f "~a:~a" line col) "")
+            index index width
+            (frame-call-representation frame #:top-frame? (zero? index)))
+    (if full?
+        (print-locals frame #:width width
+                      #:per-line-prefix "     "))))
+
+(define* (print-frames frames
+                       #:optional (port (current-output-port))
+                       #:key (width (terminal-width)) (full? #f)
+                       (forward? #f) count)
+  (let* ((len (vector-length frames))
+         (lower-idx (if (or (not count) (positive? count))
+                        0
+                        (max 0 (+ len count))))
+         (upper-idx (if (and count (negative? count))
+                        (1- len)
+                        (1- (if count (min count len) len))))
+         (inc (if forward? 1 -1)))
+    (let lp ((i (if forward? lower-idx upper-idx))
+             (last-source #f))
+      (if (<= lower-idx i upper-idx)
+          (let* ((frame (vector-ref frames i)))
+            (print-frame frame port #:index i #:width width #:full? full?
+                         #:last-source last-source)
+            (lp (+ i inc)
+                (frame-source frame)))))))
+
+(define (stack->vector stack)
+  (let* ((len (stack-length stack))
+         (v (make-vector len)))
+    (if (positive? len)
+        (let lp ((i 0) (frame (stack-ref stack 0)))
+          (if (< i len)
+              (begin
+                (vector-set! v i frame)
+                (lp (1+ i) (frame-previous frame))))))
+    v))
+
+(define (narrow-stack->vector stack . args)
+  (let ((narrowed (apply make-stack (stack-ref stack 0) args)))
+    (if narrowed
+        (stack->vector narrowed)
+        #()))) ; ? Can be the case for a tail-call to `throw' tho
+
+(define (frame->stack-vector frame)
+  (let ((stack (make-stack frame)))
+    (match (fluid-ref %stacks)
+      ((stack-tag . prompt-tag)
+       (narrow-stack->vector
+        stack
+        ;; Take the stack from the given frame, cutting 0 frames.
+        0
+        ;; Narrow the end of the stack to the most recent start-stack.
+        prompt-tag
+        ;; And one more frame, because %start-stack invoking the
+        ;; start-stack thunk has its own frame too.
+        0 (and prompt-tag 1)))
+      (_
+       ;; Otherwise take the whole stack.
+       (stack->vector stack)))))
+
+;; (define (debug)
+;;   (run-debugger
+;;    (narrow-stack->vector
+;;     (make-stack #t)
+;;     ;; Narrow the `make-stack' frame and the `debug' frame
+;;     2
+;;     ;; Narrow the end of the stack to the most recent start-stack.
+;;     (and (pair? (fluid-ref %stacks))
+;;          (cdr (fluid-ref %stacks))))))
+