diff options
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-18.scm | 26 | ||||
-rw-r--r-- | module/srfi/srfi-6.scm | 20 | ||||
-rw-r--r-- | module/srfi/srfi-9.scm | 61 |
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 |