;;; -*- 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
-;;;; 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}
;;;
a-cont
@result{} special-binding
@end lisp"
- (if (thunk? out)
- (in)
- (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
- (list out) #f))
+ ;; FIXME: Here we don't check that the out procedure is a thunk before
+ ;; calling the in-guard, as dynamic-wind is called as part of loading
+ ;; modules, but thunk? requires loading (system vm debug). This is in
+ ;; contrast to the open-coded version of dynamic-wind, which does
+ ;; currently insert an eager thunk? check (but often optimizes it
+ ;; out). Not sure what the right thing to do is here -- make thunk?
+ ;; callable before modules are loaded, live with this inconsistency,
+ ;; or remove the thunk? check from the compiler? Questions,
+ ;; questions.
+ #;
+ (unless (thunk? out)
+ (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
+ (list out) #f))
+ (in)
((@@ primitive wind) in out)
(call-with-values thunk
(lambda vals
(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")
((do "step" x y)
y)))
+(define-syntax define-values
+ (lambda (orig-form)
+ (syntax-case orig-form ()
+ ((_ () expr)
+ ;; XXX Work around the lack of hygienic top-level identifiers
+ (with-syntax (((dummy) (generate-temporaries '(dummy))))
+ #`(define dummy
+ (call-with-values (lambda () expr)
+ (lambda () #f)))))
+ ((_ (var) expr)
+ (identifier? #'var)
+ #`(define var
+ (call-with-values (lambda () expr)
+ (lambda (v) v))))
+ ((_ (var0 ... varn) expr)
+ (and-map identifier? #'(var0 ... varn))
+ ;; XXX Work around the lack of hygienic toplevel identifiers
+ (with-syntax (((dummy) (generate-temporaries '(dummy))))
+ #`(begin
+ ;; Avoid mutating the user-visible variables
+ (define dummy
+ (call-with-values (lambda () expr)
+ (lambda (var0 ... varn)
+ (list var0 ... varn))))
+ (define var0
+ (let ((v (car dummy)))
+ (set! dummy (cdr dummy))
+ v))
+ ...
+ (define varn
+ (let ((v (car dummy)))
+ (set! dummy #f) ; blackhole dummy
+ v)))))
+ ((_ var expr)
+ (identifier? #'var)
+ #'(define var
+ (call-with-values (lambda () expr)
+ list)))
+ ((_ (var0 ... . varn) expr)
+ (and-map identifier? #'(var0 ... varn))
+ ;; XXX Work around the lack of hygienic toplevel identifiers
+ (with-syntax (((dummy) (generate-temporaries '(dummy))))
+ #`(begin
+ ;; Avoid mutating the user-visible variables
+ (define dummy
+ (call-with-values (lambda () expr)
+ (lambda (var0 ... . varn)
+ (list var0 ... varn))))
+ (define var0
+ (let ((v (car dummy)))
+ (set! dummy (cdr dummy))
+ v))
+ ...
+ (define varn
+ (let ((v (car dummy)))
+ (set! dummy #f) ; blackhole dummy
+ v))))))))
+
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
(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) (move? #f))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l) #f)
- (begin
- (f (car hare))
- (for-each1 (cdr hare) (cdr tortoise) #f)))
- (begin
- (f (car hare))
- (for-each1 (cdr hare) tortoise #t)))
-
- (if (not (null? hare))
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
- (list l) #f)))))
-
- ((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 default-prompt-tag
+ ;; Redefined later to be a parameter.
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
- ((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 (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 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 (compile load eval)
- (set! %load-path (cons elt %load-path))))
+ (eval-when (expand load eval)
+ (set! %load-path (cons elt (delete elt %load-path)))))
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
(define (module-add! m v var)
(if (not (variable? var))
(error "Bad variable to module-add!" var))
+ (if (not (symbol? v))
+ (error "Bad symbol to module-add!" v))
(module-obarray-set! (module-obarray m) v var)
(module-modified m))
;;; {Autoloading modules}
;;;
+;;; XXX FIXME autoloads-in-progress and autoloads-done
+;;; are not handled in a thread-safe way.
+
(define autoloads-in-progress '())
;; This function is called from scm_load_scheme_module in
(interface options)
(interface)))
(define-syntax-rule (option-set! opt val)
- (eval-when (eval load compile expand)
+ (eval-when (expand load eval)
(options (append (options) (list 'opt val)))))))))
(define-option-interface
;; Return a list of expressions that evaluate to the appropriate
;; arguments for resolve-interface according to SPEC.
-(eval-when (compile)
+(eval-when (expand)
(if (memq 'prefix (read-options))
(error "boot-9 must be compiled with #:kw, not :kw")))
(filename (let ((f (assq-ref (or (syntax-source x) '())
'filename)))
(and (string? f) f))))
- #'(eval-when (eval load compile expand)
+ #'(eval-when (expand load eval)
(let ((m (define-module* '(name name* ...)
#:filename filename quoted-arg ...)))
(set-current-module m)
(syntax-case x ()
((_ spec ...)
(with-syntax (((quoted-args ...) (quotify #'(spec ...))))
- #'(eval-when (eval load compile expand)
+ #'(eval-when (expand load eval)
(process-use-modules (list quoted-args ...))
*unspecified*))))))
(syntax-rules ()
((_ (name . args) . body)
(begin
- (define name (lambda args . body))
+ (define (name . args) . body)
(export name)))
((_ name val)
(begin
names)))
(define-syntax-rule (export name ...)
- (eval-when (eval load compile expand)
+ (eval-when (expand load eval)
(call-with-deferred-observers
(lambda ()
(module-export! (current-module) '(name ...))))))
(define-syntax-rule (re-export name ...)
- (eval-when (eval load compile expand)
+ (eval-when (expand load eval)
(call-with-deferred-observers
(lambda ()
(module-re-export! (current-module) '(name ...))))))
(define-syntax-rule (export! name ...)
- (eval-when (eval load compile expand)
+ (eval-when (expand load eval)
(call-with-deferred-observers
(lambda ()
(module-replace! (current-module) '(name ...))))))
srfi-6 ;; string ports
srfi-13 ;; string library
srfi-14 ;; character sets
+ srfi-16 ;; case-lambda
srfi-23 ;; `error` procedure
+ srfi-30 ;; nested multi-line comments
srfi-39 ;; parameterize
+ srfi-46 ;; basic syntax-rules extensions
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
+ srfi-62 ;; s-expression comments
+ srfi-87 ;; => in case clauses
srfi-105 ;; curly infix expressions
))
(lambda (formals ...)
body ...))
args ...))
+ ((_ a (... ...))
+ (syntax-violation 'name "Wrong number of arguments" x))
(_
(identifier? x)
#'proc-name))))))))))