diff options
author | Andy Wingo <wingo@pobox.com> | 2011-12-13 10:20:44 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-12-13 10:20:44 +0100 |
commit | bfe35b90ff0c7f78335e70bdb26ea3466f6e98d9 (patch) | |
tree | f2bca0900186ee07ff354466c0894d8592b02d08 | |
parent | 04ec290f8b3e6bd6297fb10391ea7e885a55a786 (diff) | |
parent | ac16263bc191f6b1f05b49d0f291f7fd938da72c (diff) | |
download | guile-bfe35b90ff0c7f78335e70bdb26ea3466f6e98d9.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
configure.ac
-rw-r--r-- | configure.ac | 2 | ||||
-rw-r--r-- | libguile/gc-malloc.c | 4 | ||||
-rw-r--r-- | libguile/gc.c | 4 | ||||
-rw-r--r-- | libguile/ports.c | 5 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 40 | ||||
-rw-r--r-- | module/ice-9/session.scm | 27 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 45 | ||||
-rw-r--r-- | module/srfi/srfi-39.scm | 101 | ||||
-rw-r--r-- | test-suite/tests/parameters.test | 61 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 17 |
10 files changed, 199 insertions, 107 deletions
diff --git a/configure.ac b/configure.ac index 02ce7d05b..a32ff4b8a 100644 --- a/configure.ac +++ b/configure.ac @@ -1259,7 +1259,7 @@ save_LIBS="$LIBS" LIBS="$BDW_GC_LIBS $LIBS" CFLAGS="$BDW_GC_CFLAGS $CFLAGS" -AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor]) +AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes]) # Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not # declared, and has a different type (returning void instead of diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 39e82ef1e..fb844ff63 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -95,7 +95,11 @@ scm_realloc (void *mem, size_t size) return ptr; /* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */ +#ifdef HAVE_GC_GCOLLECT_AND_UNMAP GC_gcollect_and_unmap (); +#else + GC_gcollect (); +#endif SCM_SYSCALL (ptr = realloc (mem, size)); if (ptr) diff --git a/libguile/gc.c b/libguile/gc.c index 71e713383..0d271afce 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -200,7 +200,11 @@ GC_get_heap_usage_safe (GC_word *pheap_size, GC_word *pfree_bytes, { *pheap_size = GC_get_heap_size (); *pfree_bytes = GC_get_free_bytes (); +#ifdef HAVE_GC_GET_UNMAPPED_BYTES *punmapped_bytes = GC_get_unmapped_bytes (); +#else + *punmapped_bytes = 0; +#endif *pbytes_since_gc = GC_get_bytes_since_gc (); *ptotal_bytes = GC_get_total_bytes (); } diff --git a/libguile/ports.c b/libguile/ports.c index 9eb6d3b9c..c0e13f374 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2847,6 +2847,11 @@ scm_init_ports () (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK))); scm_conversion_strategy_init = 1; + /* These bindings are used when boot-9 turns `current-input-port' et + al into parameters. They are then removed from the guile module. */ + scm_c_define ("%current-input-port-fluid", cur_inport_fluid); + scm_c_define ("%current-output-port-fluid", cur_outport_fluid); + scm_c_define ("%current-error-port-fluid", cur_errport_fluid); } /* diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 3ae933aec..5395ed1f9 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -732,6 +732,9 @@ If there is no handler at all, Guile prints an error and then exits." (_ (default-printer))) args)) + (define (getaddrinfo-error-printer port key args default-printer) + (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args)))) + (set-exception-printer! 'goops-error scm-error-printer) (set-exception-printer! 'host-not-found scm-error-printer) (set-exception-printer! 'keyword-argument-error scm-error-printer) @@ -751,7 +754,9 @@ If there is no handler at all, Guile prints an error and then exits." (set-exception-printer! 'wrong-number-of-args scm-error-printer) (set-exception-printer! 'wrong-type-arg scm-error-printer) - (set-exception-printer! 'syntax-error syntax-error-printer)) + (set-exception-printer! 'syntax-error syntax-error-printer) + + (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer)) @@ -2876,6 +2881,36 @@ module '(ice-9 q) '(make-q q-length))}." ;;; +;;; Current ports as parameters. +;;; + +(let ((fluid->parameter + (lambda (fluid conv) + (make-struct <parameter> 0 + (case-lambda + (() (fluid-ref fluid)) + ((x) (let ((prev (fluid-ref fluid))) + (fluid-set! fluid (conv x)) + prev))) + fluid conv)))) + (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")) + + + +;;; ;;; Warnings. ;;; @@ -3611,8 +3646,9 @@ module '(ice-9 q) '(make-q q-length))}." srfi-4 ;; homogenous numeric vectors srfi-6 ;; open-input-string etc, in the guile core srfi-13 ;; string library - srfi-23 ;; `error` procedure srfi-14 ;; character sets + srfi-23 ;; `error` procedure + srfi-39 ;; parameterize srfi-55 ;; require-extension srfi-61 ;; general cond clause )) diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm index e895743e8..fbb03d254 100644 --- a/module/ice-9/session.scm +++ b/module/ice-9/session.scm @@ -17,16 +17,17 @@ (define-module (ice-9 session) - :use-module (ice-9 documentation) - :use-module (ice-9 regex) - :use-module (ice-9 rdelim) - :export (help - add-value-help-handler! remove-value-help-handler! - add-name-help-handler! remove-name-help-handler! - apropos apropos-internal apropos-fold apropos-fold-accessible - apropos-fold-exported apropos-fold-all source arity - procedure-arguments - module-commentary)) + #:use-module (ice-9 documentation) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:export (help + add-value-help-handler! remove-value-help-handler! + add-name-help-handler! remove-name-help-handler! + apropos-hook + apropos apropos-internal apropos-fold apropos-fold-accessible + apropos-fold-exported apropos-fold-all source arity + procedure-arguments + module-commentary)) @@ -284,8 +285,13 @@ where OPTIONSET is one of debug, read, eval, print ;;; Author: Roland Orre <orre@nada.kth.se> ;;; +;; Two arguments: the module, and the pattern, as a string. +;; +(define apropos-hook (make-hook 2)) + (define (apropos rgx . options) "Search for bindings: apropos regexp {options= 'full 'shadow 'value}" + (run-hook apropos-hook (current-module) rgx) (if (zero? (string-length rgx)) "Empty string not allowed" (let* ((match (make-regexp rgx)) @@ -354,6 +360,7 @@ Fourth arg FOLDER is one of (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE apropos-fold-exported ;fold over all exported bindings apropos-fold-all ;fold over all bindings" + (run-hook apropos-hook (current-module) rgx) (let ((match (make-regexp rgx)) (recorded (make-hash-table))) (let ((fold-module diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 85865717c..3c5aa664d 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -99,6 +99,47 @@ (or (proc (vlist-ref vlist i)) (lp (1+ i))))))) +(define (truncate-values x) + "Discard all but the first value of X." + (let loop ((x x)) + (match x + (($ <const>) x) + (($ <lexical-ref>) x) + (($ <void>) x) + (($ <lexical-ref>) x) + (($ <primitive-ref>) x) + (($ <module-ref>) x) + (($ <toplevel-ref>) x) + (($ <conditional> src condition subsequent alternate) + (make-conditional src condition (loop subsequent) (loop alternate))) + (($ <application> _ ($ <primitive-ref> _ 'values) (first _ ...)) + first) + (($ <application> _ ($ <primitive-ref> _ 'values) (val)) + val) + (($ <application> src + (and prim ($ <primitive-ref> _ (? singly-valued-primitive?))) + args) + (make-application src prim (map loop args))) + (($ <application> src proc args) + (make-application src proc (map loop args))) + (($ <sequence> src (exps ... last)) + (make-sequence src (append exps (list (loop last))))) + (($ <lambda>) x) + (($ <dynlet> src fluids vals body) + (make-dynlet src fluids vals (loop body))) + (($ <let> src names gensyms vals body) + (make-let src names gensyms vals (loop body))) + (($ <letrec> src in-order? names gensyms vals body) + (make-letrec src in-order? names gensyms vals (loop body))) + (($ <fix> src names gensyms vals body) + (make-fix src names gensyms vals body)) + (($ <let-values> src exp body) + (make-let-values src exp (loop body))) + (else + (make-application (tree-il-src x) + (make-primitive-ref #f 'values) + (list x)))))) + ;; Peval will do a one-pass analysis on the source program to determine ;; the set of assigned lexicals, and to identify unreferenced and ;; singly-referenced lexicals. @@ -278,8 +319,10 @@ (constant-value operand-constant-value set-operand-constant-value!)) (define* (make-operand var sym #:optional source visit) + ;; Bind SYM to VAR, with value SOURCE. ;; Bound operands are considered copyable until we prove otherwise. - (%make-operand var sym visit source 0 #f (and source #t) #f #f)) + (let ((source (if source (truncate-values source) source))) + (%make-operand var sym visit source 0 #f (and source #t) #f #f))) (define (make-bound-operands vars syms sources visit) (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index d1c46d028..0d540633d 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -35,104 +35,19 @@ ;;; Code: (define-module (srfi srfi-39) - #:use-module (srfi srfi-16) - - #:export (make-parameter) - #:export-syntax (parameterize) - ;; helper procedure not in srfi-39. #:export (with-parameters*) - #:replace (current-input-port current-output-port current-error-port)) - -;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. -;; -(cond-expand-provide (current-module) '(srfi-39)) - -(define make-parameter - (case-lambda - ((val) (make-parameter/helper val (lambda (x) x))) - ((val conv) (make-parameter/helper val conv)))) - -(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value -(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value - -(define (make-parameter/helper val conv) - (let ((fluid (make-fluid (conv val)))) - (case-lambda - (() - (fluid-ref fluid)) - ((new-value) - (cond - ((eq? new-value get-fluid-tag) fluid) - ((eq? new-value get-conv-tag) conv) - (else (fluid-set! fluid (conv new-value)))))))) - -(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...) - (with-parameters* (list ?param ...) - (list ?value ...) - (lambda () ?body ...))) + #:re-export (make-parameter + parameterize + current-input-port current-output-port current-error-port)) -(define current-input-port - (case-lambda - (() - ((@ (guile) current-input-port))) - ((new-value) - (set-current-input-port new-value)))) - -(define current-output-port - (case-lambda - (() - ((@ (guile) current-output-port))) - ((new-value) - (set-current-output-port new-value)))) - -(define current-error-port - (case-lambda - (() - ((@ (guile) current-error-port))) - ((new-value) - (set-current-error-port new-value)))) - -(define port-list - (list current-input-port current-output-port current-error-port)) - -;; There are no fluids behind current-input-port etc, so those parameter -;; objects are picked out of the list and handled separately with a -;; dynamic-wind to swap their values to and from a location (the "value" -;; variable in the swapper procedure "let"). -;; -;; current-input-port etc are already per-dynamic-root, so this arrangement -;; works the same as a fluid. Perhaps they could become fluids for ease of -;; implementation here. -;; -;; Notice the use of a param local variable for the swapper procedure. It -;; ensures any application changes to the PARAMS list won't affect the -;; winding. -;; (define (with-parameters* params values thunk) (let more ((params params) (values values) (fluids '()) ;; fluids from each of PARAMS - (convs '()) ;; VALUES with conversion proc applied - (swapper noop)) ;; wind/unwind procedure for ports handling + (convs '())) ;; VALUES with conversion proc applied (if (null? params) - (if (eq? noop swapper) - (with-fluids* fluids convs thunk) - (dynamic-wind - swapper - (lambda () - (with-fluids* fluids convs thunk)) - swapper)) - (if (memq (car params) port-list) - (more (cdr params) (cdr values) - fluids convs - (let ((param (car params)) - (value (car values)) - (prev-swapper swapper)) - (lambda () - (set! value (param value)) - (prev-swapper)))) - (more (cdr params) (cdr values) - (cons ((car params) get-fluid-tag) fluids) - (cons (((car params) get-conv-tag) (car values)) convs) - swapper))))) + (with-fluids* fluids convs thunk) + (more (cdr params) (cdr values) + (cons (parameter-fluid (car params)) fluids) + (cons ((parameter-converter (car params)) (car values)) convs))))) diff --git a/test-suite/tests/parameters.test b/test-suite/tests/parameters.test index 9d0a092ab..78b57c68d 100644 --- a/test-suite/tests/parameters.test +++ b/test-suite/tests/parameters.test @@ -67,3 +67,64 @@ (lambda () (parameterize ((inside? #t)) (raise 'some-exception))))))))) + +(let () + (define (test-ports param new-port new-port-2) + (let ((old-port (param))) + + (pass-if "new value" + (parameterize ((param new-port)) + (eq? (param) new-port))) + + (pass-if "set value" + (parameterize ((param old-port)) + (param new-port) + (eq? (param) new-port))) + + (pass-if "old restored" + (parameterize ((param new-port)) + #f) + (eq? (param) old-port)) + + (pass-if "throw exit" + (catch 'bail + (lambda () + (parameterize ((param new-port)) + (throw 'bail))) + (lambda args #f)) + (eq? (param) old-port)) + + (pass-if "call/cc re-enter" + (let ((cont #f) + (count 0) + (port #f) + (good #t)) + (parameterize ((param new-port)) + (call/cc (lambda (k) (set! cont k))) + (set! count (1+ count)) + (set! port (param)) + (if (= 1 count) (param new-port-2))) + (set! good (and good (eq? (param) old-port))) + (case count + ((1) + (set! good (and good (eq? port new-port))) + ;; re-entering should give new-port-2 left there last time + (cont)) + ((2) + (set! good (and good (eq? port new-port-2))))) + good)) + + (pass-if "original unchanged" + (eq? (param) old-port)))) + + (with-test-prefix "current-input-port" + (test-ports current-input-port + (open-input-string "xyz") (open-input-string "xyz"))) + + (with-test-prefix "current-output-port" + (test-ports current-output-port + (open-output-string) (open-output-string))) + + (with-test-prefix "current-error-port" + (test-ports current-error-port + (open-output-string) (open-output-string)))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 8d125f52b..4235c6d95 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -661,6 +661,23 @@ (+ a b)))) (const 3)) + (pass-if-peval resolve-primitives + ;; First order, multiple values. + (let ((x 1) (y 2)) + (values x y)) + (apply (primitive values) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + ;; First order, multiple values truncated. + (let ((x (values 1 'a)) (y 2)) + (values x y)) + (apply (primitive values) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + ;; First order, multiple values truncated. + (or (values 1 2) 3) + (const 1)) + (pass-if-peval ;; First order, coalesced, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) |