From 9f6e3f5a997f484548bd03e7e7573c38a95c8d09 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 May 2012 23:39:05 +0200 Subject: Have string ports honor `%default-port-conversion-strategy'. * libguile/strports.c (scm_mkstrport): Remove initialization of `pt->ilseq_handler'. * module/ice-9/pretty-print.scm (truncated-print)[ellipsis]: Set %DEFAULT-PORT-CONVERSION-STRATEGY to 'error. * test-suite/tests/ports.test ("string ports")["%default-port-conversion-strategy is honored"]: New test. ["wrong encoding"]: Rename to... ["wrong encoding, error"]: ... this. Explicitly set %DEFAULT-PORT-CONVERSION-STRATEGY to 'error. Return #f when no exception is raised. --- module/ice-9/pretty-print.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index bf45eed42..5c23cb009 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -320,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword argument." (let ((e "…")) (catch 'encoding-error (lambda () - (with-output-to-string - (lambda () - (display e)))) + (with-fluids ((%default-port-conversion-strategy 'error)) + (with-output-to-string + (lambda () + (display e))))) (lambda (key . args) "...")))) -- cgit v1.2.3 From 0a3ac81a1c1017d3c71e9eac8f0dd3407563632b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 8 Jun 2012 12:42:08 +0200 Subject: Update (ice-9 match) from Chibi-Scheme. Fixes . * module/ice-9/match.upstream.scm: Update. --- module/ice-9/match.scm | 4 ++-- module/ice-9/match.upstream.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index 4b078c69f..7fd191a11 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011, 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 @@ -52,7 +52,7 @@ ;; `match' doesn't support clauses of the form `(pat => exp)'. ;; Unmodified public domain code by Alex Shinn retrieved from -;; the Chibi-Scheme repository, commit 876:528cdab3f818. +;; the Chibi-Scheme repository, commit 1206:acd808700e91. ;; ;; Note: Make sure to update `match.test.upstream' when updating this ;; file. diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm index 978655667..29f9dbe2e 100644 --- a/module/ice-9/match.upstream.scm +++ b/module/ice-9/match.upstream.scm @@ -210,6 +210,7 @@ ;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in ;; the pattern (thanks to Stefan Israelsson Tampe) ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists @@ -479,7 +480,8 @@ (match-one v p . x)) ((_ v (p . q) g+s sk fk i) ;; match one and try the remaining on failure - (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i)))) + (match-one v p g+s sk (fk2) i))) )) ;; We match a pattern (p ...) by matching the pattern p in a loop on -- cgit v1.2.3 From 6b5e918e4f3cf011713e699c6af1c4e364bfae36 Mon Sep 17 00:00:00 2001 From: Sjoerd van Leent Date: Fri, 8 Jun 2012 21:21:08 -0400 Subject: Fix unbound variables and unbound values * module/language/ecmascript/base.scm: fix two wrong variable names and a wrong number of arguments in a function call. --- module/language/ecmascript/base.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm index b244bec01..6f5c65ba5 100644 --- a/module/language/ecmascript/base.scm +++ b/module/language/ecmascript/base.scm @@ -92,7 +92,7 @@ (pdel o (string->symbol p))) (define-method (has-property? (o ) p) - (if (hashq-get-handle (js-props o) v) + (if (hashq-get-handle (js-props o) p) #t (let ((proto (js-prototype o))) (if proto @@ -176,9 +176,9 @@ ((boolean? x) (if x 1 0)) ((null? x) 0) ((eq? x *undefined*) +nan.0) - ((is-a? x ) (object->number x)) + ((is-a? x ) (object->number x #t)) ((string? x) (string->number x)) - (else (throw 'TypeError o '->number)))) + (else (throw 'TypeError x '->number)))) (define (->integer x) (let ((n (->number x))) -- cgit v1.2.3 From f3b312a19d70293d7a3407fc4ef479183edd7cca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jun 2012 01:11:44 +0200 Subject: Fix cross-compilation of GOOPS-using code. Fixes . Reported by Bogdan A. Marinescu . * module/oop/goops/dispatch.scm (compute-dispatch-procedure)[comp]: Wrap `compile' call in (with-target %host-type ...). --- module/oop/goops/dispatch.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'module') diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index b12ab15fa..de5359f3c 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -25,6 +25,7 @@ #:use-module (oop goops) #:use-module (oop goops util) #:use-module (oop goops compile) + #:use-module (system base target) #:export (memoize-method!) #:no-backtrace) @@ -178,11 +179,15 @@ '()) (acons gf gf-sym '())))) (define (comp exp vals) - (let ((p ((@ (system base compile) compile) exp - #:env *dispatch-module* - #:opts '(#:partial-eval? #f #:cse? #f)))) - (apply p vals))) - + ;; When cross-compiling Guile itself, the native Guile must generate + ;; code for the host. + (with-target %host-type + (lambda () + (let ((p ((@ (system base compile) compile) exp + #:env *dispatch-module* + #:opts '(#:partial-eval? #f #:cse? #f)))) + (apply p vals))))) + ;; kick it. (scan)) -- cgit v1.2.3 From ecb48dccbac6b8fdd969f50a23351ef7f4b91ce5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jun 2012 15:49:42 +0200 Subject: Make SRFI-6 string ports Unicode-capable. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Partly addresses . Reported by Klaus Stehle . * module/srfi/srfi-6.scm (open-input-string, open-output-string): New procedures. * test-suite/tests/srfi-6.test ("open-input-string")["read-char, Unicode"]: New test. ("open-output-string")["λ"]: New test. --- module/srfi/srfi-6.scm | 18 ++++++++++++++---- test-suite/tests/srfi-6.test | 26 +++++++++++++++++++++----- 2 files changed, 35 insertions(+), 9 deletions(-) (limited to 'module') diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm index 098b586cc..7b8bcb114 100644 --- a/module/srfi/srfi-6.scm +++ b/module/srfi/srfi-6.scm @@ -1,6 +1,6 @@ ;;; srfi-6.scm --- Basic String Ports -;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2006, 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 @@ -23,10 +23,20 @@ ;;; Code: (define-module (srfi srfi-6) - #:re-export (open-input-string open-output-string get-output-string)) + #:replace (open-input-string open-output-string) + #:re-export (get-output-string)) -;; Currently, guile provides these functions by default, so no action -;; is needed, and this file is just a placeholder. +;; 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 . + +(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)) diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test index 68fc70dff..bd9167cca 100644 --- a/test-suite/tests/srfi-6.test +++ b/test-suite/tests/srfi-6.test @@ -1,6 +1,6 @@ ;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 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 @@ -37,13 +37,21 @@ (char=? #\y (read-char port)) (char=? #\z (read-char port)) (eof-object? (read-char port))))) - + + (pass-if "read-char, Unicode" + ;; String ports should always be Unicode-capable. + ;; See . + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((port (open-input-string "λμ"))) + (and (char=? #\λ (read-char port)) + (char=? #\μ (read-char port)))))) + (with-test-prefix "unread-char" (pass-if "one char" (let ((port (open-input-string ""))) - (unread-char #\x port) - (and (char=? #\x (read-char port)) + (unread-char #\x port) + (and (char=? #\x (read-char port)) (eof-object? (read-char port))))) (pass-if "after eof" @@ -75,7 +83,15 @@ (let ((port (open-output-string))) (display "xyz" port) (string=? "xyz" (get-output-string port)))) - + + (pass-if "λ" + ;; Writing to an output string should always work. + ;; See . + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((port (open-output-string))) + (display "λ" port) + (string=? "λ" (get-output-string port))))) + (pass-if "seek" (let ((port (open-output-string))) (display "abcdef" port) -- cgit v1.2.3 From 378daa5fa51f1d193f7236c2691acba59e9af539 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jun 2012 12:25:24 +0200 Subject: scandir: select? takes basenames, operates on (sub)dirs also * module/ice-9/ftw.scm (scandir): Run the select? procedure on all items, including subdirs and the `.' and `..' entries. Pass it the basename of the file in question instead of the full name. * test-suite/tests/ftw.test ("scandir"): Adapt expectation for the .test selector. Add test for a selector that rejects everything. --- module/ice-9/ftw.scm | 19 +++++++++++-------- test-suite/tests/ftw.test | 7 +++++-- 2 files changed, 16 insertions(+), 10 deletions(-) (limited to 'module') diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 96422b5e4..6c9db27ee 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -538,26 +538,29 @@ of file names is sorted according to ENTRY (file-system-fold enter? leaf down up skip error #f name stat) (lambda (files) diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index 805c779bf..33537d04b 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -310,14 +310,17 @@ (pass-if "test-suite" (let ((select? (cut string-suffix? ".test" <>))) (match (scandir (string-append %test-dir "/tests") select?) - (("." ".." "00-initial-env.test" (? select?) ...) + (("00-initial-env.test" (? select?) ...) #t)))) (pass-if "flat file" (not (scandir (string-append %test-dir "/Makefile.am")))) (pass-if "EACCES" - (not (scandir "/.does-not-exist.")))) + (not (scandir "/.does-not-exist."))) + + (pass-if "no select" + (null? (scandir %test-dir (lambda (_) #f))))) ;;; Local Variables: ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) -- cgit v1.2.3 From 4d1ae112792cb8faaa1f42b5c7332e9de05001ee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:25:34 +0200 Subject: cse: expressions evaluated for effect do not provide predicates * module/language/tree-il/cse.scm (cse): When trying to fold conditionals, only look at entries in the database that were added in test context. * test-suite/tests/cse.test ("cse"): Add a test case. --- module/language/tree-il/cse.scm | 4 ++-- test-suite/tests/cse.test | 17 ++++++++++++++++- 2 files changed, 18 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index ceef15f70..b8e722967 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -276,11 +276,11 @@ #f))) (_ (cond - ((find-dominating-expression exp effects #f db) + ((find-dominating-expression exp effects 'test db) ;; We have an EXP fact, so we infer #t. (log 'inferring exp #t) (make-const (tree-il-src exp) #t)) - ((find-dominating-expression (negate exp 'test) effects #f db) + ((find-dominating-expression (negate exp 'test) effects 'test db) ;; We have a (not EXP) fact, so we infer #f. (log 'inferring exp #f) (make-const (tree-il-src exp) #f)) diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index ee3128511..d01d31874 100644 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@ -271,4 +271,19 @@ (let ((x (car y))) (cons x (car y))) (let (x) (_) ((apply (primitive car) (toplevel y))) - (apply (primitive cons) (lexical x _) (lexical x _))))) + (apply (primitive cons) (lexical x _) (lexical x _)))) + + ;; Dominating expressions only provide predicates when evaluated in + ;; test context. + (pass-if-cse + (let ((t (car x))) + (if (car x) + 'one + 'two)) + ;; Actually this one should reduce in other ways, but this is the + ;; current reduction: + (begin + (apply (primitive car) (toplevel x)) + (if (apply (primitive car) (toplevel x)) + (const one) + (const two))))) -- cgit v1.2.3 From 5cfa385db721222069aa5a74421cbac6e6cee26a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:29:08 +0200 Subject: update version-etc copyright year * module/ice-9/command-line.scm (version-etc): Update copyright year to 2012. --- module/ice-9/command-line.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'module') diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 8aed74ec6..62a2c9e4f 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2011) + (copyright-year 2012) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) -- cgit v1.2.3 From 2874f66017b7bfae256e85af84689d00ecc418ab Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:30:39 +0200 Subject: add char->integer, number->string etc to interesting primitives * module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*effect-free-primitives*): Add string->number, number->string, integer->char, and char->integer to allow for constant folding and better effects analysis. --- module/language/tree-il/primitives.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'module') diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index dba31bdc8..a1c5adc71 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -54,6 +54,8 @@ char=? char>? + integer->char char->integer number->string string->number + acons cons cons* list vector @@ -154,6 +156,7 @@ pair? null? list? symbol? vector? struct? string? number? char? complex? real? rational? inf? nan? integer? exact? inexact? even? odd? char=? char>? + integer->char char->integer number->string string->number struct-vtable string-length ;; These all should get expanded out by expand-primitives!. -- cgit v1.2.3