;;; -*- 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}
+;;; {Language primitives}
;;;
-;; Define delimited continuation operators, and implement catch and throw in
-;; terms of them.
-
-(define make-prompt-tag
- (lambda* (#:optional (stem "prompt"))
- (gensym stem)))
-
-(define default-prompt-tag
- ;; not sure if we should expose this to the user as a fluid
- (let ((%default-prompt-tag (make-prompt-tag)))
- (lambda ()
- %default-prompt-tag)))
-
-(define (call-with-prompt tag thunk handler)
- (@prompt tag (thunk) handler))
-(define (abort-to-prompt tag . args)
- (@abort 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 ()
- (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-fluids ((%running-exception-handlers (cons pre running)))
- (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:
+;; These are are the procedural wrappers around the primitives of
+;; Guile's language: apply, call-with-current-continuation, etc.
+;;
+;; Usually, a call to a primitive is compiled specially. The compiler
+;; knows about all these kinds of expressions. But the primitives may
+;; be referenced not only as operators, but as values as well. These
+;; stub procedures are the "values" of apply, dynamic-wind, and other
+;; such primitives.
+;;
+(define apply
+ (case-lambda
+ ((fun args)
+ ((@@ primitive apply) fun args))
+ ((fun arg1 . args)
+ (letrec ((append* (lambda (tail)
+ (let ((tail (car tail))
+ (tail* (cdr tail)))
+ (if (null? tail*)
+ tail
+ (cons tail (append* tail*)))))))
+ (apply fun (cons arg1 (append* args)))))))
+(define (call-with-current-continuation proc)
+ ((@@ primitive call-with-current-continuation) proc))
+(define (call-with-values producer consumer)
+ ((@@ primitive call-with-values) producer consumer))
+(define (dynamic-wind in thunk out)
+ "All three arguments must be 0-argument procedures.
+Guard @var{in} is called, then @var{thunk}, then
+guard @var{out}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out} is called. If the continuation of
+the dynamic-wind is re-entered, @var{in} is called. Thus
+@var{in} and @var{out} may be called any number of
+times.
@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.
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+ ;; 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
+ ((@@ primitive unwind))
+ (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))))
-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-fluids
- ((%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-fluids ((%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}.
+\f
-@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+;;; {Low-Level Port Code}
+;;;
-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)))))
+;; These are used to request the proper mode to open files in.
+;;
+(define OPEN_READ "r")
+(define OPEN_WRITE "w")
+(define OPEN_BOTH "r+")
+(define *null-device* "/dev/null")
-\f
+;; NOTE: Later in this file, this is redefined to support keywords
+(define (open-input-file str)
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file str OPEN_READ))
-;;; {R4RS compliance}
-;;;
+;; NOTE: Later in this file, this is redefined to support keywords
+(define (open-output-file str)
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file str OPEN_WRITE))
-(primitive-load-path "ice-9/r4rs")
+(define (open-io-file str)
+ "Open file with name STR for both input and output."
+ (open-file str OPEN_BOTH))
\f
(define pk peek)
-;; Temporary definition; replaced later.
-(define current-warning-port current-error-port)
-
(define (warn . stuff)
- (with-output-to-port (current-warning-port)
- (lambda ()
- (newline)
- (display ";;; WARNING ")
- (display stuff)
- (newline)
- (car (last-pair stuff)))))
+ (newline (current-warning-port))
+ (display ";;; WARNING " (current-warning-port))
+ (display stuff (current-warning-port))
+ (newline (current-warning-port))
+ (car (last-pair stuff)))
\f
\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-syntax with-fluids
+ (lambda (stx)
+ (define (emit-with-fluids bindings body)
+ (syntax-case bindings ()
+ (()
+ body)
+ (((f v) . bindings)
+ #`(with-fluid* f v
+ (lambda ()
+ #,(emit-with-fluids #'bindings body))))))
+ (syntax-case stx ()
+ ((_ ((fluid val) ...) exp exp* ...)
+ (with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
+ ((val-tmp ...) (generate-temporaries #'(val ...))))
+ #`(let ((fluid-tmp fluid) ...)
+ (let ((val-tmp val) ...)
+ #,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
+ #'(begin exp exp* ...)))))))))
+
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()
(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
;;;
-;;; Enhanced file opening procedures
+;;; Extensible exception printing.
;;;
-(define* (open-input-file
- file #:key (binary #f) (encoding #f) (guess-encoding #f))
- "Takes a string naming an existing file and returns an input port
-capable of delivering characters from the file. If the file
-cannot be opened, an error is signalled."
- (open-file file (if binary "rb" "r")
- #:encoding encoding
- #:guess-encoding guess-encoding))
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
-(define* (open-output-file file #:key (binary #f) (encoding #f))
- "Takes a string naming an output file to be created and returns an
-output port capable of writing characters to a new file by that
-name. If the file cannot be opened, an error is signalled. If a
-file with the given name already exists, the effect is unspecified."
- (open-file file (if binary "wb" "w")
- #:encoding encoding))
-
-(define* (call-with-input-file
- file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
- "PROC should be a procedure of one argument, and FILE should be a
-string naming a file. The file must
-already exist. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-input-file file
- #:binary binary
- #:encoding encoding
- #:guess-encoding guess-encoding)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-input-port p)
- (apply values vals)))))
-
-(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
- "PROC should be a procedure of one argument, and FILE should be a
-string naming a file. The behaviour is unspecified if the file
-already exists. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-output-file file #:binary binary #:encoding encoding)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-output-port p)
- (apply values vals)))))
-
-(define* (with-input-from-file
- file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The file must already exist. The file is opened for
-input, an input port connected to it is made
-the default value returned by `current-input-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))
- #:binary binary
- #:encoding encoding
- #:guess-encoding guess-encoding))
-
-(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))
- #:binary binary
- #:encoding encoding))
-
-(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))
- #:binary binary
- #:encoding encoding))
-
-\f
-
-;;;
-;;; Extensible exception printing.
-;;;
-
-(define set-exception-printer! #f)
-;; There is already a definition of print-exception from backtrace.c
-;; that we will override.
-
-(let ((exception-printers '()))
- (define (print-location frame port)
- (let ((source (and=> frame frame-source)))
- ;; source := (addr . (filename . (line . column)))
- (if source
- (let ((filename (or (cadr source) "<unnamed port>"))
- (line (caddr source))
- (col (cdddr source)))
- (format port "~a:~a:~a: " filename (1+ line) col))
- (format port "ERROR: "))))
+(let ((exception-printers '()))
+ (define (print-location frame port)
+ (let ((source (and=> frame frame-source)))
+ ;; source := (addr . (filename . (line . column)))
+ (if source
+ (let ((filename (or (cadr source) "<unnamed port>"))
+ (line (caddr source))
+ (col (cdddr source)))
+ (format port "~a:~a:~a: " filename (1+ line) col))
+ (format port "ERROR: "))))
(set! set-exception-printer!
(lambda (key proc)
(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)
;; properties within the object itself.
(define (make-object-property)
- (define-syntax-rule (with-mutex lock exp)
- (dynamic-wind (lambda () (lock-mutex lock))
- (lambda () exp)
- (lambda () (unlock-mutex lock))))
- (let ((prop (make-weak-key-hash-table))
- (lock (make-mutex)))
+ ;; Weak tables are thread-safe.
+ (let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
- (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
- (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+ (lambda (obj) (hashq-ref prop obj))
+ (lambda (obj val) (hashq-set! prop obj val)))))
\f
\f
+;;; {IOTA functions: generating lists of numbers}
+;;;
+
+(define (iota n)
+ (let loop ((count (1- n)) (result '()))
+ (if (< count 0) result
+ (loop (1- count) (cons count result)))))
+
+\f
+
;;; {Structs}
;;;
#,@(let lp ((n 0))
(if (< n *max-static-argument-count*)
(cons (with-syntax (((formal ...) (make-formals n))
+ ((idx ...) (iota n))
(n n))
#'((n)
(lambda (formal ...)
- (make-struct rtd 0 formal ...))))
+ (let ((s (allocate-struct rtd n)))
+ (struct-set! s idx formal)
+ ...
+ s))))
(lp (1+ n)))
'()))
(else
(string->symbol type-name)))
rtd))
-(define (record-type-name obj)
- (if (record-type? obj)
- (struct-ref obj vtable-offset-user)
- (error 'not-a-record-type obj)))
+(define (record-type-name obj)
+ (if (record-type? obj)
+ (struct-ref obj vtable-offset-user)
+ (error 'not-a-record-type obj)))
+
+(define (record-type-fields obj)
+ (if (record-type? obj)
+ (struct-ref obj (+ 1 vtable-offset-user))
+ (error 'not-a-record-type obj)))
+
+(define* (record-constructor rtd #:optional field-names)
+ (if (not field-names)
+ (struct-ref rtd (+ 2 vtable-offset-user))
+ (primitive-eval
+ `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd)))))))
+
+(define (record-predicate rtd)
+ (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+
+(define (%record-type-error rtd obj) ;; private helper
+ (or (eq? rtd (record-type-descriptor obj))
+ (scm-error 'wrong-type-arg "%record-type-check"
+ "Wrong type record (want `~S'): ~S"
+ (list (record-type-name rtd) obj)
+ #f)))
+
+(define (record-accessor rtd field-name)
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (lambda (obj)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-ref obj pos)
+ (%record-type-error rtd obj)))))
+
+(define (record-modifier rtd field-name)
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (lambda (obj val)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-set! obj pos val)
+ (%record-type-error rtd obj)))))
+
+(define (record? obj)
+ (and (struct? obj) (record-type? (struct-vtable obj))))
+
+(define (record-type-descriptor obj)
+ (if (struct? obj)
+ (struct-vtable obj)
+ (error 'not-a-record obj)))
+
+(provide 'record)
+
+
+\f
+;;; {Parameters}
+;;;
+
+(define <parameter>
+ ;; Three fields: the procedure itself, the fluid, and the converter.
+ (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ "Make a new parameter.
+
+A parameter is a dynamically bound value, accessed through a procedure.
+To access the current value, apply the procedure with no arguments:
+
+ (define p (make-parameter 10))
+ (p) => 10
+
+To provide a new value for the parameter in a dynamic extent, use
+`parameterize':
+
+ (parameterize ((p 20))
+ (p)) => 20
+ (p) => 10
+
+The value outside of the dynamic extent of the body is unaffected. To
+update the current value, apply it to one argument:
+
+ (p 20) => 10
+ (p) => 20
+
+As you can see, the call that updates a parameter returns its previous
+value.
+
+All values for the parameter are first run through the CONV procedure,
+including INIT, the initial value. The default CONV procedure is the
+identity procedure. CONV is commonly used to ensure some set of
+invariants on the values that a parameter may have."
+ (let ((fluid (make-fluid (conv init))))
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv)))
+
+(define (parameter? x)
+ (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+ (if (parameter? p)
+ (struct-ref p 1)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+ (if (parameter? p)
+ (struct-ref p 2)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((param value) ...) body body* ...)
+ (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+ #'(let ((p param) ...)
+ (if (not (parameter? p))
+ (scm-error 'wrong-type-arg "parameterize"
+ "Not a parameter: ~S" (list p) #f))
+ ...
+ (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+ ...)
+ body body* ...)))))))
+
+(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
+ "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter. Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))
+
+\f
+
+;;; Once parameters have booted, define the default prompt tag as being
+;;; a parameter.
+;;;
+
+(set! default-prompt-tag (make-parameter (default-prompt-tag)))
+
+\f
+
+;;; Current ports as parameters.
+;;;
+
+(let ()
+ (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+ (begin
+ (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+ (lambda (x)
+ (if (predicate x) x
+ (error msg x)))))
+ (hashq-remove! (%get-pre-modules-obarray) 'fluid)))
+
+ (port-parameterize! current-input-port %current-input-port-fluid
+ input-port? "expected an input port")
+ (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
+
+;;; {Languages}
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
+\f
+
+;;; {High-Level Port Routines}
+;;;
+
+(define* (open-input-file
+ file #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file file (if binary "rb" "r")
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
+
+(define* (open-output-file file #:key (binary #f) (encoding #f))
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file file (if binary "wb" "w")
+ #:encoding encoding))
+
+(define* (call-with-input-file
+ file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-input-file file
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-input-port p)
+ (apply values vals)))))
+
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The behaviour is unspecified if the file
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-output-file file #:binary binary #:encoding encoding)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-output-port p)
+ (apply values vals)))))
+
+(define (with-input-from-port port thunk)
+ (parameterize ((current-input-port port))
+ (thunk)))
-(define (record-type-fields obj)
- (if (record-type? obj)
- (struct-ref obj (+ 1 vtable-offset-user))
- (error 'not-a-record-type obj)))
+(define (with-output-to-port port thunk)
+ (parameterize ((current-output-port port))
+ (thunk)))
-(define* (record-constructor rtd #:optional field-names)
- (if (not field-names)
- (struct-ref rtd (+ 2 vtable-offset-user))
- (primitive-eval
- `(lambda ,field-names
- (make-struct ',rtd 0 ,@(map (lambda (f)
- (if (memq f field-names)
- f
- #f))
- (record-type-fields rtd)))))))
-
-(define (record-predicate rtd)
- (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+(define (with-error-to-port port thunk)
+ (parameterize ((current-error-port port))
+ (thunk)))
-(define (%record-type-error rtd obj) ;; private helper
- (or (eq? rtd (record-type-descriptor obj))
- (scm-error 'wrong-type-arg "%record-type-check"
- "Wrong type record (want `~S'): ~S"
- (list (record-type-name rtd) obj)
- #f)))
+(define* (with-input-from-file
+ file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-file file
+ (lambda (p) (with-input-from-port p thunk))
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
-(define (record-accessor rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (lambda (obj)
- (if (eq? (struct-vtable obj) rtd)
- (struct-ref obj pos)
- (%record-type-error rtd obj)))))
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-output-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (record-modifier rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (lambda (obj val)
- (if (eq? (struct-vtable obj) rtd)
- (struct-set! obj pos val)
- (%record-type-error rtd obj)))))
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-error-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (record? obj)
- (and (struct? obj) (record-type? (struct-vtable obj))))
+(define (call-with-input-string string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created
+input port from which @var{string}'s contents may be read. The value
+yielded by the @var{proc} is returned."
+ (proc (open-input-string string)))
-(define (record-type-descriptor obj)
- (if (struct? obj)
- (struct-vtable obj)
- (error 'not-a-record obj)))
+(define (with-input-from-string string thunk)
+ "THUNK must be a procedure of no arguments.
+The test of STRING is opened for
+input, an input port connected to it is made,
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed.
+Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
-(provide 'record)
+(define (call-with-output-string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created output
+port. When the function returns, the string composed of the characters
+written into the port is returned."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (with-output-to-string thunk)
+ "Calls THUNK and returns its output as a string."
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ "Calls THUNK and returns its error output as a string."
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
\f
(lambda (str)
(->bool (stat str #f)))
(lambda (str)
- (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (let ((port (catch 'system-error (lambda () (open-input-file str))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
(eq? (stat:type (stat str)) 'directory))
(lambda (str)
(let ((port (catch 'system-error
- (lambda () (open-file (string-append str "/.")
- OPEN_READ))
+ (lambda ()
+ (open-input-file (string-append str "/.")))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
(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-record-type
(lambda (x)
(define (make-id scope . fragments)
- (datum->syntax #'scope
+ (datum->syntax scope
(apply symbol-append
(map (lambda (x)
(if (symbol? x) x (syntax->datum x)))
(cons #'f (field-list #'rest)))))
(define (constructor rtd type-name fields exp)
- (let ((ctor (make-id rtd type-name '-constructor))
- (args (field-list fields)))
+ (let* ((ctor (make-id rtd type-name '-constructor))
+ (args (field-list fields))
+ (n (length fields))
+ (slots (iota n)))
(predicate rtd type-name fields
#`(begin #,exp
(define #,ctor
(let ((rtd #,rtd))
(lambda #,args
- (make-struct rtd 0 #,@args))))
+ (let ((s (allocate-struct rtd #,n)))
+ #,@(map
+ (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ args slots)
+ s))))
(struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor)))))
;; initial uses list, or binding procedure.
;;
(define* (make-module #:optional (size 31) (uses '()) (binder #f))
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
(if (not (integer? size))
(error "Illegal size to make-module." size))
(if (not (and (list? uses)
(module-constructor (make-hash-table size)
uses binder #f macroexpand
#f #f #f
- (make-hash-table %default-import-size)
+ (make-hash-table)
'()
(make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f))
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-;; It used to be, however, that module names were also present in the
-;; value namespace. When we enable deprecated code, we preserve this
-;; legacy behavior.
-;;
-;; These shims are defined here instead of in deprecated.scm because we
-;; need their definitions before loading other modules.
-;;
-(begin-deprecated
- (define (module-ref-submodule module name)
- (or (hashq-ref (module-submodules module) name)
- (and (module-submodule-binder module)
- ((module-submodule-binder module) module name))
- (let ((var (module-local-variable module name)))
- (and var (variable-bound? var) (module? (variable-ref var))
- (begin
- (warn "module" module "not in submodules table")
- (variable-ref var))))))
-
- (define (module-define-submodule! module name submodule)
- (let ((var (module-local-variable module name)))
- (if (and var
- (or (not (variable-bound? var))
- (not (module? (variable-ref var)))))
- (warn "defining module" module ": not overriding local definition" var)
- (module-define! module name submodule)))
- (hashq-set! (module-submodules module) name submodule)))
-
\f
;;; {Module-based Loading}
(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
\f
-;;; {Parameters}
-;;;
-
-(define <parameter>
- ;; Three fields: the procedure itself, the fluid, and the converter.
- (make-struct <applicable-struct-vtable> 0 'pwprpr))
-(set-struct-vtable-name! <parameter> '<parameter>)
-
-(define* (make-parameter init #:optional (conv (lambda (x) x)))
- "Make a new parameter.
-
-A parameter is a dynamically bound value, accessed through a procedure.
-To access the current value, apply the procedure with no arguments:
-
- (define p (make-parameter 10))
- (p) => 10
-
-To provide a new value for the parameter in a dynamic extent, use
-`parameterize':
-
- (parameterize ((p 20))
- (p)) => 20
- (p) => 10
-
-The value outside of the dynamic extent of the body is unaffected. To
-update the current value, apply it to one argument:
-
- (p 20) => 10
- (p) => 20
-
-As you can see, the call that updates a parameter returns its previous
-value.
-
-All values for the parameter are first run through the CONV procedure,
-including INIT, the initial value. The default CONV procedure is the
-identity procedure. CONV is commonly used to ensure some set of
-invariants on the values that a parameter may have."
- (let ((fluid (make-fluid (conv init))))
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv)))
-
-(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
- "Make a parameter that wraps a fluid.
-
-The value of the parameter will be the same as the value of the fluid.
-If the parameter is rebound in some dynamic extent, perhaps via
-`parameterize', the new value will be run through the optional CONV
-procedure, as with any parameter. Note that unlike `make-parameter',
-CONV is not applied to the initial value."
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv))
-
-(define (parameter? x)
- (and (struct? x) (eq? (struct-vtable x) <parameter>)))
-
-(define (parameter-fluid p)
- (if (parameter? p)
- (struct-ref p 1)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define (parameter-converter p)
- (if (parameter? p)
- (struct-ref p 2)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define-syntax parameterize
- (lambda (x)
- (syntax-case x ()
- ((_ ((param value) ...) body body* ...)
- (with-syntax (((p ...) (generate-temporaries #'(param ...))))
- #'(let ((p param) ...)
- (if (not (parameter? p))
- (scm-error 'wrong-type-arg "parameterize"
- "Not a parameter: ~S" (list p) #f))
- ...
- (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
- ...)
- body body* ...)))))))
-
-\f
-;;;
-;;; Current ports as parameters.
-;;;
-
-(let ()
- (define-syntax-rule (port-parameterize! binding fluid predicate msg)
- (begin
- (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
- (lambda (x)
- (if (predicate x) x
- (error msg x)))))
- (module-remove! (current-module) 'fluid)))
-
- (port-parameterize! current-input-port %current-input-port-fluid
- input-port? "expected an input port")
- (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"))
-
-
-\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.
-;;;
-
-;; The language can be a symbolic name or a <language> object from
-;; (system base language).
-;;
-(define current-language (make-parameter 'scheme))
-
-
-\f
-
;;; {Running Repls}
;;;
\f
-;;; {IOTA functions: generating lists of numbers}
-;;;
-
-(define (iota n)
- (let loop ((count (1- n)) (result '()))
- (if (< count 0) result
- (loop (1- count) (cons count result)))))
-
-\f
-
;;; {While}
;;;
;;; with `continue' and `break'.
;; 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*))))))
-(define-syntax-rule (use-syntax spec ...)
- (begin
- (eval-when (eval load compile expand)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info."))
- (use-modules spec ...)))
-
(include-from-path "ice-9/r6rs-libraries")
(define-syntax-rule (define-private foo bar)
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 ...))))))
;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
+ guile-2.2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogeneous numeric vectors
- ;; We omit srfi-6 because the 'open-input-string' etc in Guile
- ;; core are not conformant with SRFI-6; they expose details
- ;; of the binary I/O model and may fail to support some characters.
+ 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
HCoop / bpt / guile.git / blobdiff