;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014 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
\f
-;;; {Error handling}
-;;;
-
-;; Define delimited continuation operators, and implement catch and throw in
-;; terms of them.
-
-(define make-prompt-tag
- (lambda* (#:optional (stem "prompt"))
- ;; The only property that prompt tags need have is uniqueness in the
- ;; sense of eq?. A one-element list will serve nicely.
- (list stem)))
-
-(define default-prompt-tag
- ;; Redefined later to be a parameter.
- (let ((%default-prompt-tag (make-prompt-tag)))
- (lambda ()
- %default-prompt-tag)))
-
-(define (call-with-prompt tag thunk handler)
- ((@@ primitive call-with-prompt) tag thunk handler))
-(define (abort-to-prompt tag . args)
- (abort-to-prompt* tag args))
-
-(define (with-fluid* fluid val thunk)
- "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
-@var{thunk} must be a procedure of no arguments."
- ((@@ primitive push-fluid) fluid val)
- (call-with-values thunk
- (lambda vals
- ((@@ primitive pop-fluid))
- (apply values vals))))
-
-;; Define catch and with-throw-handler, using some common helper routines and a
-;; shared fluid. Hide the helpers in a lexical contour.
-
-(define with-throw-handler #f)
-(let ()
- (define (default-exception-handler k . args)
- (cond
- ((eq? k 'quit)
- (primitive-exit (cond
- ((not (pair? args)) 0)
- ((integer? (car args)) (car args))
- ((not (car args)) 1)
- (else 0))))
- (else
- (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
- (primitive-exit 1))))
-
- (define %running-exception-handlers (make-fluid '()))
- (define %exception-handler (make-fluid default-exception-handler))
-
- (define (default-throw-handler prompt-tag catch-k)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args)))))
-
- (define (custom-throw-handler prompt-tag catch-k pre)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (let ((running (fluid-ref %running-exception-handlers)))
- (with-fluid* %running-exception-handlers (cons pre running)
- (lambda ()
- (if (not (memq pre running))
- (apply pre thrown-k args))
- ;; fall through
- (if prompt-tag
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args)))))
- (apply prev thrown-k args)))))
-
- (set! catch
- (lambda* (k thunk handler #:optional pre-unwind-handler)
- "Invoke @var{thunk} in the dynamic context of @var{handler} for
-exceptions matching @var{key}. If thunk throws to the symbol
-@var{key}, then @var{handler} is invoked this way:
-@lisp
- (handler key args ...)
-@end lisp
-
-@var{key} is a symbol or @code{#t}.
-
-@var{thunk} takes no arguments. If @var{thunk} returns
-normally, that is the return value of @code{catch}.
-
-Handler is invoked outside the scope of its own @code{catch}.
-If @var{handler} again throws to the same key, a new handler
-from further up the call chain is invoked.
-
-If the key is @code{#t}, then a throw to @emph{any} symbol will
-match this call to @code{catch}.
-
-If a @var{pre-unwind-handler} is given and @var{thunk} throws
-an exception that matches @var{key}, Guile calls the
-@var{pre-unwind-handler} before unwinding the dynamic state and
-invoking the main @var{handler}. @var{pre-unwind-handler} should
-be a procedure with the same signature as @var{handler}, that
-is @code{(lambda (key . args))}. It is typically used to save
-the stack at the point where the exception occurred, but can also
-query other parts of the dynamic state at that point, such as
-fluid values.
-
-A @var{pre-unwind-handler} can exit either normally or non-locally.
-If it exits normally, Guile unwinds the stack and dynamic context
-and then calls the normal (third argument) handler. If it exits
-non-locally, that exit determines the continuation."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "catch"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (let ((tag (make-prompt-tag "catch")))
- (call-with-prompt
- tag
- (lambda ()
- (with-fluid* %exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))
- thunk))
- (lambda (cont k . args)
- (apply handler k args))))))
-
- (set! with-throw-handler
- (lambda (k thunk pre-unwind-handler)
- "Add @var{handler} to the dynamic context as a throw handler
-for key @var{k}, then invoke @var{thunk}."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "with-throw-handler"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (with-fluid* %exception-handler
- (custom-throw-handler #f k pre-unwind-handler)
- thunk)))
-
- (set! throw
- (lambda (key . args)
- "Invoke the catch form matching @var{key}, passing @var{args} to the
-@var{handler}.
-
-@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
-
-If there is no handler at all, Guile prints an error and then exits."
- (if (not (symbol? key))
- ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
- "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
- (apply (fluid-ref %exception-handler) key args)))))
-
-
-\f
-
;;; {Language primitives}
;;;
(out)
(apply values vals))))
+(define (with-fluid* fluid val thunk)
+ "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
+@var{thunk} must be a procedure of no arguments."
+ ((@@ primitive push-fluid) fluid val)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive pop-fluid))
+ (apply values vals))))
+
\f
;;; {Low-Level Port Code}
(define pk peek)
-;; Temporary definition; replaced later.
-(define current-warning-port current-error-port)
-
(define (warn . stuff)
(newline (current-warning-port))
(display ";;; WARNING " (current-warning-port))
\f
-;;; Boot versions of `map' and `for-each', enough to get the expander
-;;; running.
+;;; {map and for-each}
;;;
+
(define map
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
(let map1 ((l l))
- (if (null? l)
- '()
- (cons (f (car l)) (map1 (cdr l))))))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list l2) #f))
+
(let map2 ((l1 l1) (l2 l2))
- (if (null? l1)
- '()
+ (if (pair? l1)
(cons (f (car l1) (car l2))
- (map2 (cdr l1) (cdr l2))))))
+ (map2 (cdr l1) (cdr l2)))
+ '())))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
- (if (null? l1)
- '()
+ (let ((len (length l1)))
+ (let mapn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (mapn (cdr rest))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+ (let mapn ((l1 l1) (rest rest))
+ (if (pair? l1)
(cons (apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (mapn (cdr l1) (map cdr rest)))
+ '())))))
+
+(define map-in-order map)
(define for-each
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
(let for-each1 ((l l))
- (if (pair? l)
+ (if (not (null? l))
(begin
(f (car l))
(for-each1 (cdr l))))))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
(let for-each2 ((l1 l1) (l2 l2))
- (if (pair? l1)
+ (if (not (null? l1))
(begin
(f (car l1) (car l2))
(for-each2 (cdr l1) (cdr l2))))))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
+ (let ((len (length l1)))
+ (let for-eachn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (for-eachn (cdr rest))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+
+ (let for-eachn ((l1 l1) (rest rest))
(if (pair? l1)
(begin
(apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (for-eachn (cdr l1) (map cdr rest))))))))
+
;; Temporary definition used in the include-from-path expansion;
;; replaced later.
(syntax-rules ()
((_) #t)
((_ x) x)
- ((_ x y ...) (if x (and y ...) #f))))
+ ;; Avoid ellipsis, which would lead to quadratic expansion time.
+ ((_ x . y) (if x (and . y) #f))))
(define-syntax or
(syntax-rules ()
((_) #f)
((_ x) x)
- ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+ ;; Avoid ellipsis, which would lead to quadratic expansion time.
+ ((_ x . y) (let ((t x)) (if t t (or . y))))))
(include-from-path "ice-9/quasisyntax")
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))
-;;; The real versions of `map' and `for-each', with cycle detection, and
-;;; that use reverse! instead of recursion in the case of `map'.
+
+\f
+
+;;; {Error handling}
;;;
-(define map
- (case-lambda
- ((f l)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
-
- ((f l1 l2)
- (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
- (cond
- ((pair? h1)
- (cond
- ((not (pair? h2))
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- ((not move?)
- (map2 (cdr h1) (cdr h2) t1 t2 #t
- (cons (f (car h1) (car h2)) out)))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l2) #f))
- (else
- (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
- (cons (f (car h1) (car h2)) out)))))
-
- ((and (null? h1) (null? h2))
- (reverse! out))
-
- ((null? h1)
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- (else
- (scm-error 'wrong-type-arg "map"
- "Not a list: ~S"
- (list l1) #f)))))
- ((f l1 . rest)
- (let ((len (length l1)))
- (let mapn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (mapn (cdr rest))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list (car rest)) #f)))))
- (let mapn ((l1 l1) (rest rest) (out '()))
- (if (null? l1)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest)
- (cons (apply f (car l1) (map car rest)) out)))))))
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
-(define map-in-order map)
+(define make-prompt-tag
+ (lambda* (#:optional (stem "prompt"))
+ ;; The only property that prompt tags need have is uniqueness in the
+ ;; sense of eq?. A one-element list will serve nicely.
+ (list stem)))
-(define for-each
- (case-lambda
- ((f l)
- (let for-each1 ((hare l) (tortoise l))
- (if (pair? hare)
- (begin
- (f (car hare))
- (let ((hare (cdr hare)))
- (if (pair? hare)
- (begin
- (when (eq? tortoise hare)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l) #f))
- (f (car hare))
- (for-each1 (cdr hare) (cdr tortoise))))))
- (if (not (null? hare))
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
- (list l) #f)))))
+(define default-prompt-tag
+ ;; Redefined later to be a parameter.
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
- ((f l1 l2)
- (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
- (cond
- ((and (pair? h1) (pair? h2))
- (cond
- ((not move?)
- (f (car h1) (car h2))
- (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l2) #f))
- (else
- (f (car h1) (car h2))
- (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
-
- ((if (null? h1)
- (or (null? h2) (pair? h2))
- (and (pair? h1) (null? h2)))
- (if #f #f))
-
- ((list? h1)
- (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
- (list h2) #f))
- (else
- (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
- (list h1) #f)))))
+(define (call-with-prompt tag thunk handler)
+ ((@@ primitive call-with-prompt) tag thunk handler))
+(define (abort-to-prompt tag . args)
+ (abort-to-prompt* tag args))
- ((f l1 . rest)
- (let ((len (length l1)))
- (let for-eachn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (for-eachn (cdr rest))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list (car rest)) #f)))))
-
- (let for-eachn ((l1 l1) (rest rest))
- (if (pair? l1)
- (begin
- (apply f (car l1) (map car rest))
- (for-eachn (cdr l1) (map cdr rest))))))))
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(define with-throw-handler #f)
+(let ((%eh (module-ref (current-module) '%exception-handler)))
+ (define (make-exception-handler catch-key prompt-tag pre-unwind)
+ (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
+ (define (exception-handler-prev handler) (vector-ref handler 0))
+ (define (exception-handler-catch-key handler) (vector-ref handler 1))
+ (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
+ (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
+
+ (define %running-pre-unwind (make-fluid '()))
+
+ (define (dispatch-exception handler key args)
+ (unless handler
+ (when (eq? key 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
+ (primitive-exit 1))
+
+ (let ((catch-key (exception-handler-catch-key handler))
+ (prev (exception-handler-prev handler)))
+ (if (or (eqv? catch-key #t) (eq? catch-key key))
+ (let ((prompt-tag (exception-handler-prompt-tag handler))
+ (pre-unwind (exception-handler-pre-unwind handler)))
+ (if pre-unwind
+ ;; Instead of using a "running" set, it would be a lot
+ ;; cleaner semantically to roll back the exception
+ ;; handler binding to the one that was in place when the
+ ;; pre-unwind handler was installed, and keep it like
+ ;; that for the rest of the dispatch. Unfortunately
+ ;; that is incompatible with existing semantics. We'll
+ ;; see if we can change that later on.
+ (let ((running (fluid-ref %running-pre-unwind)))
+ (with-fluid* %running-pre-unwind (cons handler running)
+ (lambda ()
+ (unless (memq handler running)
+ (apply pre-unwind key args))
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag key args)
+ (dispatch-exception prev key args)))))
+ (apply abort-to-prompt prompt-tag key args)))
+ (dispatch-exception prev key args))))
+
+ (define (throw key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (unless (symbol? key)
+ (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
+ (list 1 key) (list key)))
+ (dispatch-exception (fluid-ref %eh) key args))
+
+ (define* (catch k thunk handler #:optional pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (define (wrong-type-arg n val)
+ (scm-error 'wrong-type-arg "catch"
+ "Wrong type argument in position ~a: ~a"
+ (list n val) (list val)))
+ (unless (or (symbol? k) (eqv? k #t))
+ (wrong-type-arg 1 k))
+ (unless (procedure? handler)
+ (wrong-type-arg 3 handler))
+ (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
+ (wrong-type-arg 4 pre-unwind-handler))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
+ thunk))
+ (lambda (cont k . args)
+ (apply handler k args)))))
+
+ (define (with-throw-handler k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error 'wrong-type-arg "with-throw-handler"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
+ thunk))
+
+ (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
+ (define! 'catch catch)
+ (define! 'with-throw-handler with-throw-handler)
+ (define! 'throw throw))
\f
(set-exception-printer! 'no-data scm-error-printer)
(set-exception-printer! 'no-recovery scm-error-printer)
(set-exception-printer! 'null-pointer-error scm-error-printer)
+ (set-exception-printer! 'out-of-memory scm-error-printer)
(set-exception-printer! 'out-of-range scm-error-printer)
(set-exception-printer! 'program-error scm-error-printer)
(set-exception-printer! 'read-error scm-error-printer)
(port-parameterize! current-output-port %current-output-port-fluid
output-port? "expected an output port")
(port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-warning-port %current-warning-port-fluid
output-port? "expected an output port"))
\f
-;;; {Warnings}
-;;;
-
-(define current-warning-port
- (make-parameter (current-error-port)
- (lambda (x)
- (if (output-port? x)
- x
- (error "expected an output port" x)))))
-
-
-\f
-
;;; {Languages}
;;;
(or (char=? c #\/)
(char=? c #\\)))
- (define file-name-separator-string "\\")
+ (define file-name-separator-string "/")
(define (absolute-file-name? file-name)
(define (file-name-separator-at-index? idx)
(define-syntax-rule (add-to-load-path elt)
"Add ELT to Guile's load path, at compile-time and at run-time."
(eval-when (expand load eval)
- (set! %load-path (cons elt %load-path))))
+ (set! %load-path (cons elt (delete elt %load-path)))))
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
HCoop / bpt / guile.git / blobdiff