diff options
Diffstat (limited to 'module/system')
-rw-r--r-- | module/system/base/compile.scm | 29 | ||||
-rw-r--r-- | module/system/foreign.scm | 15 | ||||
-rw-r--r-- | module/system/repl/command.scm | 48 | ||||
-rw-r--r-- | module/system/repl/common.scm | 9 | ||||
-rw-r--r-- | module/system/repl/debug.scm | 32 | ||||
-rw-r--r-- | module/system/repl/error-handling.scm | 71 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 85 | ||||
-rw-r--r-- | module/system/repl/server.scm | 3 |
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))) |