summaryrefslogtreecommitdiff
path: root/module/system
diff options
context:
space:
mode:
Diffstat (limited to 'module/system')
-rw-r--r--module/system/base/compile.scm29
-rw-r--r--module/system/foreign.scm15
-rw-r--r--module/system/repl/command.scm48
-rw-r--r--module/system/repl/common.scm9
-rw-r--r--module/system/repl/debug.scm32
-rw-r--r--module/system/repl/error-handling.scm71
-rw-r--r--module/system/repl/repl.scm85
-rw-r--r--module/system/repl/server.scm3
8 files changed, 211 insertions, 81 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7d46713b2..1b6e73f32 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -68,16 +68,27 @@
x
(lookup-language x)))
-;; Throws an exception if `dir' is not writable. The double-stat is OK,
-;; as this is only used during compilation.
+;; Throws an exception if `dir' is not writable. The mkdir occurs
+;; before the check, so that we avoid races (possibly due to parallel
+;; compilation).
+;;
(define (ensure-writable-dir dir)
- (if (file-exists? dir)
- (if (access? dir W_OK)
- #t
- (error "directory not writable" dir))
- (begin
- (ensure-writable-dir (dirname dir))
- (mkdir dir))))
+ (catch 'system-error
+ (lambda ()
+ (mkdir dir))
+ (lambda (k subr fmt args rest)
+ (let ((errno (and (pair? rest) (car rest))))
+ (cond
+ ((eqv? errno EEXIST)
+ (let ((st (stat dir)))
+ (if (or (not (eq? (stat:type st) 'directory))
+ (not (access? dir W_OK)))
+ (error "directory not writable" dir))))
+ ((eqv? errno ENOENT)
+ (ensure-writable-dir (dirname dir))
+ (ensure-writable-dir dir))
+ (else
+ (throw k subr fmt args rest)))))))
;;; This function is among the trickiest I've ever written. I tried many
;;; variants. In the end, simple is best, of course.
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 781e79369..37f9b41ac 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -37,6 +37,8 @@
null-pointer?
pointer?
make-pointer
+ pointer->scm
+ scm->pointer
pointer-address
pointer->bytevector
@@ -190,9 +192,12 @@ which does the reverse. PRINT must name a user-defined object printer."
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- (let ((key+value (hash-create-handle! ptr->obj ptr #f)))
- (or (cdr key+value)
- (let ((o (%wrap ptr)))
- (set-cdr! key+value o)
- o))))))
+ ;; XXX: We can't use `hash-create-handle!' +
+ ;; `set-cdr!' here because the former would create a
+ ;; weak-cdr pair but the latter wouldn't register a
+ ;; disappearing link (see `scm_hash_fn_set_x'.)
+ (or (hash-ref ptr->obj ptr)
+ (let ((o (%wrap ptr)))
+ (hash-set! ptr->obj ptr o)
+ o)))))
(set-record-type-printer! type-name print)))))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index d4b3e4a77..109b533f8 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 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
@@ -465,7 +465,11 @@ Compile a file."
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
- (guile:disassemble (repl-eval repl (repl-parse repl form))))
+ (let ((obj (repl-eval repl (repl-parse repl form))))
+ (if (or (program? obj) (objcode? obj))
+ (guile:disassemble obj)
+ (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
+ obj))))
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
@@ -546,7 +550,7 @@ Trace execution."
(format #t "Nothing to debug.~%"))))))))
(define-stack-command (backtrace repl #:optional count
- #:key (width 72) full?)
+ #:key (width (terminal-width)) full?)
"backtrace [COUNT] [#:width W] [#:full? F]
Print a backtrace.
@@ -626,12 +630,12 @@ With an argument, select a frame by index, then show it."
Print the procedure for the selected frame."
(repl-print repl (frame-procedure cur)))
-(define-stack-command (locals repl)
+(define-stack-command (locals repl #:key (width (terminal-width)))
"locals
Show local variables.
Show locally-bound variables in the selected frame."
- (print-locals cur))
+ (print-locals cur #:width width))
(define-stack-command (error-message repl)
"error-message
@@ -811,6 +815,15 @@ Print registers.
Print the registers of the current frame."
(print-registers cur))
+(define-meta-command (width repl #:optional x)
+ "width [X]
+Set debug output width.
+
+Set the number of screen columns in the output from `backtrace' and
+`locals'."
+ (terminal-width x)
+ (format #t "Set screen width to ~a columns.~%" (terminal-width)))
+
;;;
@@ -858,30 +871,21 @@ Display statistics."
(display-diff-stat "GC times:" #t this-times last-times "times")
(newline))
;; Memory size
- (let ((this-cells (assq-ref this-gcs 'cells-allocated))
- (this-heap (assq-ref this-gcs 'cell-heap-size))
- (this-bytes (assq-ref this-gcs 'bytes-malloced))
- (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+ (let ((this-heap (assq-ref this-gcs 'heap-size))
+ (this-free (assq-ref this-gcs 'heap-free-size)))
(display-stat-title "Memory size:" "current" "limit")
- (display-stat "heap" #f this-cells this-heap "cells")
- (display-stat "malloc" #f this-bytes this-malloc "bytes")
+ (display-stat "heap" #f (- this-heap this-free) this-heap "bytes")
(newline))
;; Cells collected
- (let ((this-marked (assq-ref this-gcs 'cells-marked))
- (last-marked (assq-ref last-gcs 'cells-marked))
- (this-swept (assq-ref this-gcs 'cells-swept))
- (last-swept (assq-ref last-gcs 'cells-swept)))
- (display-stat-title "Cells collected:" "diff" "total")
- (display-diff-stat "marked" #f this-marked last-marked "cells")
- (display-diff-stat "swept" #f this-swept last-swept "cells")
+ (let ((this-alloc (assq-ref this-gcs 'heap-total-allocated))
+ (last-alloc (assq-ref last-gcs 'heap-total-allocated)))
+ (display-stat-title "Bytes allocated:" "diff" "total")
+ (display-diff-stat "allocated" #f this-alloc last-alloc "bytes")
(newline))
;; GC time taken
- (let ((this-mark (assq-ref this-gcs 'gc-mark-time-taken))
- (last-mark (assq-ref last-gcs 'gc-mark-time-taken))
- (this-total (assq-ref this-gcs 'gc-time-taken))
+ (let ((this-total (assq-ref this-gcs 'gc-time-taken))
(last-total (assq-ref last-gcs 'gc-time-taken)))
(display-stat-title "GC time taken:" "diff" "total")
- (display-time-stat "mark" this-mark last-mark)
(display-time-stat "total" this-total last-total)
(newline))
;; Process time spent
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 24a583ce6..a5267c616 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -121,7 +121,14 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
,(value-history-enabled?)
,(lambda (x)
(if x (enable-value-history!) (disable-value-history!))
- (->bool x))))))
+ (->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)
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 46ea6b4db..cf408063e 100644
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011 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
@@ -32,6 +32,7 @@
#:export (<debug>
make-debug debug?
debug-frames debug-index debug-error-message debug-for-trap?
+ terminal-width
print-registers print-locals print-frame print-frames frame->module
stack->vector narrow-stack->vector
frame->stack-vector))
@@ -58,6 +59,25 @@
+;; 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
@@ -79,7 +99,7 @@
(print "fp = #x~x\n" (frame-address frame)))
(define* (print-locals frame #:optional (port (current-output-port))
- #:key (width 72) (per-line-prefix " "))
+ #:key (width (terminal-width)) (per-line-prefix " "))
(let ((bindings (frame-bindings frame)))
(cond
((null? bindings)
@@ -99,8 +119,8 @@
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
- #:key index (width 72) (full? #f) (last-source #f)
- next-source?)
+ #: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")
@@ -120,8 +140,8 @@
(define* (print-frames frames
#:optional (port (current-output-port))
- #:key (width 72) (full? #f) (forward? #f) count
- for-trap?)
+ #:key (width (terminal-width)) (full? #f)
+ (forward? #f) count for-trap?)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index d41dea643..c6c64cc73 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -122,27 +122,56 @@
(case on-error
((debug)
(lambda (key . args)
- (let* ((tag (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks))))
- (stack (narrow-stack->vector
- (make-stack #t)
- ;; Cut three frames from the top of the stack:
- ;; make-stack, this one, and the throw handler.
- 3
- ;; Narrow the end of the stack to the most recent
- ;; start-stack.
- tag
- ;; And one more frame, because %start-stack invoking
- ;; the start-stack thunk has its own frame too.
- 0 (and tag 1)))
- (error-msg (error-string stack key args))
- (debug (make-debug stack 0 error-msg #f)))
- (with-saved-ports
- (lambda ()
- (format #t "~a~%" error-msg)
- (format #t "Entering a new prompt. ")
- (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
- ((@ (system repl repl) start-repl) #:debug debug))))))
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (stack (narrow-stack->vector
+ (make-stack #t)
+ ;; Cut three frames from the top of the stack:
+ ;; make-stack, this one, and the throw handler.
+ 3
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ tag
+ ;; And one more frame, because %start-stack invoking
+ ;; the start-stack thunk has its own frame too.
+ 0 (and tag 1)))
+ (error-msg (error-string stack key args))
+ (debug (make-debug stack 0 error-msg #f)))
+ (with-saved-ports
+ (lambda ()
+ (format #t "~a~%" error-msg)
+ (format #t "Entering a new prompt. ")
+ (format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
+ ((@ (system repl repl) start-repl) #:debug debug)))))))
+ ((report)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (begin
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
+ ((backtrace)
+ (lambda (key . args)
+ (if (not (memq key pass-keys))
+ (let* ((tag (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ (frames (narrow-stack->vector
+ (make-stack #t)
+ ;; Narrow as above, for the debugging case.
+ 3 tag 0 (and tag 1))))
+ (with-saved-ports
+ (lambda ()
+ (print-frames frames)
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
+ (if #f #f)))))
((pass)
(lambda (key . args)
;; fall through to rethrow
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 6eb29be91..5bab7780e 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -32,6 +32,48 @@
#:export (start-repl run-repl))
+;;;
+;;; Comments
+;;;
+;;; (You don't want a comment to force a continuation line.)
+;;;
+
+(define (read-scheme-line-comment port)
+ (let lp ()
+ (let ((ch (read-char port)))
+ (or (eof-object? ch)
+ (eqv? ch #\newline)
+ (lp)))))
+
+(define (read-scheme-datum-comment port)
+ (read port))
+
+;; ch is a peeked char
+(define (read-comment lang port ch)
+ (and (eq? (language-name lang) 'scheme)
+ (case ch
+ ((#\;)
+ (read-char port)
+ (read-scheme-line-comment port)
+ #t)
+ ((#\#)
+ (read-char port)
+ (case (peek-char port)
+ ((#\;)
+ (read-char port)
+ (read-scheme-datum-comment port)
+ #t)
+ ;; Not doing R6RS block comments because of the possibility
+ ;; of read-hash extensions. Lame excuse. Not doing scsh
+ ;; block comments either, because I don't feel like handling
+ ;; #!r6rs.
+ (else
+ (unread-char #\# port)
+ #f)))
+ (else
+ #f))))
+
+
;;;
;;; Meta commands
@@ -39,11 +81,11 @@
(define meta-command-token (cons 'meta 'command))
-(define (meta-reader read env)
+(define (meta-reader lang env)
(lambda* (#:optional (port (current-input-port)))
(with-input-from-port port
(lambda ()
- (let ((ch (next-char #t)))
+ (let ((ch (flush-leading-whitespace)))
(cond ((eof-object? ch)
;; EOF objects are not buffered. It's quite possible
;; to peek an EOF then read something else. It's
@@ -52,8 +94,17 @@
((eqv? ch #\,)
(read-char port)
meta-command-token)
- (else (read port env))))))))
+ ((read-comment lang port ch)
+ *unspecified*)
+ (else ((language-reader lang) port env))))))))
+(define (flush-all-input)
+ (if (and (char-ready?)
+ (not (eof-object? (peek-char))))
+ (begin
+ (read-char)
+ (flush-all-input))))
+
;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
;; to be able to re-use the existing readline machinery.
@@ -63,8 +114,7 @@
(catch #t
(lambda ()
(repl-reader (lambda () (repl-prompt repl))
- (meta-reader (language-reader (repl-language repl))
- (current-module))))
+ (meta-reader (repl-language repl) (current-module))))
(lambda (key . args)
(case key
((quit)
@@ -72,6 +122,7 @@
(else
(format (current-output-port) "While reading expression:\n")
(print-exception (current-output-port) #f key args)
+ (flush-all-input)
*unspecified*)))))
@@ -108,7 +159,7 @@
(let prompt-loop ()
(let ((exp (prompting-meta-read repl)))
(cond
- ((eqv? exp *unspecified*)) ; read error, pass
+ ((eqv? exp *unspecified*)) ; read error or comment, pass
((eq? exp meta-command-token)
(catch #t
(lambda ()
@@ -139,8 +190,10 @@
(abort-on-error "parsing expression"
(repl-parse repl exp))))))
(run-hook before-eval-hook exp)
- (with-error-handling
- (with-stack-and-prompt thunk)))
+ (call-with-error-handling
+ (lambda ()
+ (with-stack-and-prompt thunk))
+ #:on-error (repl-option-ref repl 'on-error)))
(lambda (k) (values))))
(lambda l
(for-each (lambda (v)
@@ -148,19 +201,19 @@
l))))
(lambda (k . args)
(abort args))))
+ #:on-error (repl-option-ref repl 'on-error)
#:trap-handler 'disabled)))
- (next-char #f) ;; consume trailing whitespace
+ (flush-to-newline) ;; consume trailing whitespace
(prompt-loop))))
(lambda (k status)
status)))
-(define (next-char wait)
- (if (or wait (char-ready?))
- (let ((ch (peek-char)))
- (cond ((eof-object? ch) ch)
- ((char-whitespace? ch) (read-char) (next-char wait))
- (else ch)))
- #f))
+;; Returns first non-whitespace char.
+(define (flush-leading-whitespace)
+ (let ((ch (peek-char)))
+ (cond ((eof-object? ch) ch)
+ ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
+ (else ch))))
(define (flush-to-newline)
(if (char-ready?)
diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm
index 132ea81aa..ec9067745 100644
--- a/module/system/repl/server.scm
+++ b/module/system/repl/server.scm
@@ -1,6 +1,6 @@
;;; Repl server
-;; Copyright (C) 2003, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2003, 2010, 2011 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
@@ -103,6 +103,7 @@
(sleep 1)
(accept-new-client))))))
+ (sigaction SIGPIPE SIG_IGN)
(add-open-socket! server-socket)
(listen server-socket 5)
(let lp ((client (accept-new-client)))