summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi')
-rw-r--r--module/srfi/srfi-18.scm26
-rw-r--r--module/srfi/srfi-6.scm20
-rw-r--r--module/srfi/srfi-9.scm61
3 files changed, 50 insertions, 57 deletions
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 4921a95d7..684a1254e 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -1,6 +1,6 @@
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010, 2012 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
@@ -145,15 +145,15 @@
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(hashq-set! thread-exception-handlers ct (cons handler hl))
- (apply (@ (srfi srfi-34) with-exception-handler)
- (list (lambda (obj)
- (hashq-set! thread-exception-handlers ct hl)
- (handler obj))
- (lambda ()
- (call-with-values thunk
- (lambda res
- (hashq-set! thread-exception-handlers ct hl)
- (apply values res))))))))
+ ((@ (srfi srfi-34) with-exception-handler)
+ (lambda (obj)
+ (hashq-set! thread-exception-handlers ct hl)
+ (handler obj))
+ (lambda ()
+ (call-with-values thunk
+ (lambda res
+ (hashq-set! thread-exception-handlers ct hl)
+ (apply values res)))))))
(define (current-exception-handler)
(car (current-handler-stack)))
@@ -277,7 +277,7 @@
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
- (let ((v (apply join-thread (cons thread args)))
+ (let ((v (apply join-thread thread args))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
@@ -320,12 +320,12 @@
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
- (lambda () (apply lock-mutex (cons mutex args)))
+ (lambda () (apply lock-mutex mutex args))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (mutex-unlock! mutex . args)
- (apply unlock-mutex (cons mutex args)))
+ (apply unlock-mutex mutex args))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm
index 7b8bcb114..e6f8b438a 100644
--- a/module/srfi/srfi-6.scm
+++ b/module/srfi/srfi-6.scm
@@ -1,6 +1,7 @@
;;; srfi-6.scm --- Basic String Ports
-;; Copyright (C) 2001, 2002, 2003, 2006, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2006, 2012,
+;; 2013 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
@@ -23,21 +24,6 @@
;;; Code:
(define-module (srfi srfi-6)
- #:replace (open-input-string open-output-string)
- #:re-export (get-output-string))
-
-;; SRFI-6 says nothing about encodings, and assumes that any character
-;; or string can be written to a string port. Thus, make all SRFI-6
-;; string ports Unicode capable. See <http://bugs.gnu.org/11197>.
-
-(define (open-input-string s)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-input-string) s)))
-
-(define (open-output-string)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-output-string))))
-
-(cond-expand-provide (current-module) '(srfi-6))
+ #:re-export (open-input-string open-output-string get-output-string))
;;; srfi-6.scm ends here
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 324fe9cee..355362af4 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -144,6 +144,7 @@
(display ">" p))
(define (throw-bad-struct s who)
+ #((definite-bailout? . #t))
(throw 'wrong-type-arg who
"Wrong type argument: ~S" (list s)
(list s)))
@@ -159,7 +160,8 @@
((_ type-name (getter-id ...) check? s (getter expr) ...)
(every identifier? #'(getter ...))
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
- (getter+exprs #'((getter expr) ...)))
+ (getter+exprs #'((getter expr) ...))
+ (nfields (length #'(getter-id ...))))
(define (lookup id default-expr)
(let ((results
(filter (lambda (g+e)
@@ -178,12 +180,16 @@
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
- #`(make-struct
- type-name 0
- #,@(map (lambda (getter index)
- (lookup getter #`(struct-ref s #,index)))
- #'(getter-id ...)
- (iota (length #'(getter-id ...)))))))
+ #`(let ((new (allocate-struct type-name #,nfields)))
+ #,@(map (lambda (getter index)
+ #`(struct-set!
+ new
+ #,index
+ #,(lookup getter
+ #`(struct-ref s #,index))))
+ #'(getter-id ...)
+ (iota nfields))
+ new)))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
@@ -207,26 +213,27 @@
((name getter setter) #'getter)))
field-specs))
- (define (constructor form type-name constructor-spec field-names)
+ (define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
- (let ((ctor-args (map (lambda (field)
- (let ((name (syntax->datum field)))
- (or (memq name field-names)
- (syntax-violation
- (syntax-case form ()
- ((macro . args)
- (syntax->datum #'macro)))
- "unknown field in constructor spec"
- form field))
- (cons name field)))
- #'(field ...))))
+ (let ((slots (map (lambda (field)
+ (or (list-index (lambda (x)
+ (free-identifier=? x field))
+ field-ids)
+ (syntax-violation
+ (syntax-case form ()
+ ((macro . args)
+ (syntax->datum #'macro)))
+ "unknown field in constructor spec"
+ form field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
- (make-struct #,type-name 0
- #,@(map (lambda (name)
- (assq-ref ctor-args name))
- field-names)))))))
+ (let ((s (allocate-struct #,type-name #,(length field-ids))))
+ #,@(map (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ #'(field ...) slots)
+ s))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)
@@ -270,8 +277,9 @@
(iota (length field-specs))))
(define (record-layout immutable? count)
- (let ((desc (if immutable? "pr" "pw")))
- (string-concatenate (make-list count desc))))
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
@@ -303,12 +311,11 @@
(field-count (length field-ids))
(immutable? (syntax->datum #'immutable?))
(layout (record-layout immutable? field-count))
- (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'form #'type-name #'constructor-spec field-names)
+ #,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-struct/no-tail