;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
- ;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
++;;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
(let ((str (string-concatenate (make-list 1000 "one line\n"))))
(benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
+ (let ((port (open-input-string str)))
- (sequence (read-line port) 1000)))))
+ (sequence (read-line port) 1000))))
+
+ (let ((str (large-string "Hello, world.\n")))
+ (benchmark "read-string" 200
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
++ (let ((port (open-input-string str)))
+ (read-string port)))))
#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H
- /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
-/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009,
++/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009, 2011
+ * 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 License
- /* Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-/* Copyright (C) 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
++/* Copyright (C) 2009-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 License
- /* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-/* Copyright (C) 2010-2014 Free Software Foundation, Inc.
++/* Copyright (C) 2010-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 License
int cmode;
long csize;
size_t ndrained;
- char *drained;
+ char *drained = NULL;
scm_t_port *pt;
- scm_t_port_internal *pti;
+ scm_t_ptob_descriptor *ptob;
port = SCM_COERCE_OUTPORT (port);
- /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
-/* Copyright (C) 1995-2001, 2006, 2008-2011,
- * 2014 Free Software Foundation, Inc.
++/* Copyright (C) 1995-2001, 2006, 2008-2011, 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 License
/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
- * 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
- * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011,
++ * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011, 2013
+ * 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 License
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
+ ice-9/peg/simplify-tree.scm \
+ ice-9/peg/codegen.scm \
+ ice-9/peg/cache.scm \
+ ice-9/peg/using-parsers.scm \
+ ice-9/peg/string-peg.scm \
+ ice-9/peg.scm \
ice-9/poe.scm \
ice-9/poll.scm \
+ ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
ice-9/rdelim.scm \
;;; TREE-IL -> GLIL compiler
- ;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
-;; 2014 Free Software Foundation, Inc.
++;; Copyright (C) 2001, 2008-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
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
- (nopt (if opt (length opt) 0))
+ (opt (or opt '()))
+ (rest (if rest (list rest) '()))
+ (nopt (length opt))
(key (source-expression proc)))
- (define (inlined-application)
- (cond
- ((= nargs (+ nreq nopt))
- (make-let src
- (append req
- (or opt '())
- (if rest (list rest) '()))
- gensyms
- (append orig-args
- (if rest
- (list (make-const #f '()))
- '()))
- body))
- ((> nargs (+ nreq nopt))
- (make-let src
- (append req
- (or opt '())
- (list rest))
- gensyms
- (append (take orig-args (+ nreq nopt))
- (list (make-application
- #f
- (make-primitive-ref #f 'list)
- (drop orig-args (+ nreq nopt)))))
- body))
- (else
- ;; Here we handle the case where nargs < nreq + nopt,
- ;; so the rest argument (if any) will be empty, and
- ;; there will be optional arguments that rely on their
- ;; default initializers.
- ;;
- ;; The default initializers of optional arguments
- ;; may refer to earlier arguments, so in the general
- ;; case we must expand into a series of nested let
- ;; expressions.
- ;;
- ;; In the generated code, the outermost let
- ;; expression will bind all arguments provided by
- ;; the application's argument list, as well as the
- ;; empty rest argument, if any. Each remaining
- ;; optional argument that relies on its default
- ;; initializer will be bound within an inner let.
- ;;
- ;; rest-gensyms, rest-vars and rest-inits will have
- ;; either 0 or 1 elements. They are oddly named, but
- ;; allow simpler code below.
- (let*-values
- (((non-rest-gensyms rest-gensyms)
- (split-at gensyms (+ nreq nopt)))
- ((provided-gensyms default-gensyms)
- (split-at non-rest-gensyms nargs))
- ((provided-vars default-vars)
- (split-at (append req opt) nargs))
- ((rest-vars)
- (if rest (list rest) '()))
- ((rest-inits)
- (if rest
- (list (make-const #f '()))
- '()))
- ((default-inits)
- (drop inits (- nargs nreq))))
- (make-let src
- (append provided-vars rest-vars)
- (append provided-gensyms rest-gensyms)
- (append orig-args rest-inits)
- (fold-right (lambda (var gensym init body)
- (make-let src
- (list var)
- (list gensym)
- (list init)
- body))
- body
- default-vars
- default-gensyms
- default-inits))))))
+ (define (singly-referenced-lambda? orig-proc)
+ (match orig-proc
+ (($ <lambda>) #t)
+ (($ <lexical-ref> _ _ sym)
+ (and (not (assigned-lexical? sym))
+ (= (lexical-refcount sym) 1)
+ (singly-referenced-lambda?
+ (operand-source (lookup sym)))))
+ (_ #f)))
+ (define (inlined-call)
+ (let ((req-vals (list-head orig-args nreq))
+ (opt-vals (let lp ((args (drop orig-args nreq))
+ (inits inits)
+ (out '()))
+ (match inits
+ (() (reverse out))
+ ((init . inits)
+ (match args
+ (()
+ (lp '() inits (cons init out)))
+ ((arg . args)
+ (lp args inits (cons arg out))))))))
+ (rest-vals (cond
+ ((> nargs (+ nreq nopt))
+ (list (make-primcall
+ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (rest (list (make-const #f '())))
+ (else '()))))
+ (if (>= nargs (+ nreq nopt))
+ (make-let src
+ (append req opt rest)
+ gensyms
+ (append req-vals opt-vals rest-vals)
+ body)
- ;; The required argument values are in the scope
- ;; of the optional argument initializers.
++ ;; The default initializers of optional arguments
++ ;; may refer to earlier arguments, so in the general
++ ;; case we must expand into a series of nested let
++ ;; expressions.
++ ;;
++ ;; In the generated code, the outermost let
++ ;; expression will bind all required arguments, as
++ ;; well as the empty rest argument, if any. Each
++ ;; optional argument will be bound within an inner
++ ;; let.
+ (make-let src
+ (append req rest)
+ (append (list-head gensyms nreq)
+ (last-pair gensyms))
+ (append req-vals rest-vals)
- (make-let src
- opt
- (list-head (drop gensyms nreq) nopt)
- opt-vals
- body)))))
++ (fold-right (lambda (var gensym val body)
++ (make-let src
++ (list var)
++ (list gensym)
++ (list val)
++ body))
++ body
++ opt
++ (list-head (drop gensyms nreq) nopt)
++ opt-vals)))))
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
- ;; Copyright 2005,2008,2009,2010,2011,2013 Free Software Foundation, Inc.
-;; Copyright 2005, 2008, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
++;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
--- /dev/null
- ;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
+;;;;
++;;;; Copyright (C) 2010-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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (tests cross-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm elf)
+ #:use-module (system base compile)
+ #:use-module (system base target))
+
+(define (test-triplet cpu vendor os)
+ (let ((triplet (string-append cpu "-" vendor "-" os)))
+ (pass-if (format #f "triplet ~a" triplet)
+ (with-target triplet
+ (lambda ()
+ (and (string=? (target-cpu) cpu)
+ (string=? (target-vendor) vendor)
+ (string=? (target-os) os)))))))
+
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-os)
+ (with-target %host-type target-os))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (with-target triplet
+ (lambda ()
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
+ (native-word-size)
+ word-size))
+ (bv (compile '(hello-world) #:to 'bytecode)))
+ (and=> (parse-elf bv)
+ (lambda (elf)
+ (and (equal? (elf-byte-order elf) endian)
+ (equal? (elf-word-size elf) word-size)))))))))
+
+(with-test-prefix "cross-compilation"
+
+ (test-triplet "i586" "pc" "gnu0.3")
+ (test-triplet "x86_64" "unknown" "linux-gnu")
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
++ (test-target "arm-unknown-linux-androideabi"
++ (endianness little) 4)
++ (test-target "armeb-unknown-linux-gnu"
++ (endianness big) 4)
++ (test-target "aarch64-linux-gnu"
++ (endianness little) 8)
++ (test-target "aarch64_be-linux-gnu"
++ (endianness big) 8)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'bytecode)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
--;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
++;;;; Copyright (C) 2006, 2007, 2009-2011, 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
(define-module (test-suite test-modules)
#:use-module (srfi srfi-1)
-- #:use-module ((ice-9 streams) ;; for test purposes
-- #:renamer (symbol-prefix-proc 's:))
++ #:use-module ((ice-9 streams) #:prefix s:) ; for test purposes
#:use-module (test-suite lib))
'(2 3))
(const 7))
- (apply (primitive list) (const ()) (const 4)))
+ (pass-if-peval
+ ;; Higher order with optional argument (default uses earlier argument).
+ ;; <http://bugs.gnu.org/17634>
+ ((lambda* (f x #:optional (y (+ 3 (car x))))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 12))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments
+ ;; (default uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 20))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (one caller-supplied value,
+ ;; one default that uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
+ (const 4))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (caller-supplied values).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
+ (const 21))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments (one
+ ;; caller-supplied value, one default that uses earlier optional
+ ;; argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
- (apply (primitive list) (const ()) (const 21)))
++ (primcall list (const ()) (const 4)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
- (let (r) (_) ((apply (primitive list) (const 8) (const 3)))
- (apply (primitive list) (lexical r _) (const 21))))
++ (primcall list (const ()) (const 21)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals and rest).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17
+ 8
+ 3)
++ (let (r) (_) ((primcall list (const 8) (const 3)))
++ (primcall list (lexical r _) (const 21))))
+
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
((lambda* (f x #:optional (y 0))
(string-set! text 0 #\a)
(string-set! text (- len 1) #\b)
(pass-if "output check"
- (string=? text result)))
+ (string=? text result)))
- (pass-if "encoding failure leads to exception"
- ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
- ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
- (catch 'encoding-error
- (lambda ()
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (let ((p (open-input-string "λ"))) ; raise an exception
- #f)))
- (lambda (key . rest)
- #t)
- (lambda (key . rest)
- ;; At this point, the port-table mutex used to be still held,
- ;; hence the deadlock. This situation would occur when trying
- ;; to print a backtrace, for instance.
- (input-port? (open-input-string "foo")))))
-
- (pass-if "%default-port-encoding is honored"
- (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
- (equal? (map (lambda (e)
- (with-fluids ((%default-port-encoding e))
- (call-with-output-string
- (lambda (p)
- (and (string=? e (port-encoding p))
- (display (port-encoding p) p))))))
- encodings)
- encodings)))
+ (pass-if "%default-port-encoding is ignored"
+ (let ((str "ĉu bone?"))
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "ĉu bone?"))))
(pass-if "%default-port-conversion-strategy is honored"
(let ((strategies '(error substitute escape)))
#:use-module ((rnrs io ports) #:select (open-bytevector-input-port))
#:use-module (test-suite lib))
-(with-fluids ((%default-port-encoding "UTF-8"))
-
- (with-test-prefix "read-line"
-
- (pass-if "one line"
- (let* ((s "hello, world")
- (p (open-input-string s)))
- (and (string=? s (read-line p))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, trim"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, concat"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo\n" "bar\n")
- (list (read-line p 'concat)
- (read-line p 'concat)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, peek"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo" #\newline "bar" #\newline)
- (list (read-line p 'peek) (read-char p)
- (read-line p 'peek) (read-char p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, split"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '(("foo" . #\newline)
- ("bar" . #\newline))
- (list (read-line p 'split)
- (read-line p 'split)))
- (eof-object? (read-line p)))))
-
- (pass-if "two Greek lines, trim"
- (let* ((s "λαμβδα\nμυ\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "decoding error"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
- (catch 'decoding-error
- (lambda ()
- (read-line p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should now point past the error.
- (string=? (read-line p) "BCD")
- (eof-object? (read-line p)))))))
-
- (pass-if "decoding error, substitute"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'substitute)
- (and (string=? (read-line p) "A?BCD")
- (eof-object? (read-line p))))))
+(with-test-prefix "read-line"
+
+ (pass-if "one line"
+ (let* ((s "hello, world")
+ (p (open-input-string s)))
+ (and (string=? s (read-line p))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, trim"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, concat"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo\n" "bar\n")
+ (list (read-line p 'concat)
+ (read-line p 'concat)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, peek"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo" #\newline "bar" #\newline)
+ (list (read-line p 'peek) (read-char p)
+ (read-line p 'peek) (read-char p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, split"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '(("foo" . #\newline)
+ ("bar" . #\newline))
+ (list (read-line p 'split)
+ (read-line p 'split)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two Greek lines, trim"
+ (let* ((s "λαμβδα\nμυ\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "decoding error"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'error)
+ (catch 'decoding-error
+ (lambda ()
+ (read-line p)
+ #f)
+ (lambda (key subr message err port)
+ (and (eq? port p)
+
+ ;; PORT should now point past the error.
+ (string=? (read-line p) "BCD")
+ (eof-object? (read-line p)))))))
+
+ (pass-if "decoding error, substitute"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'substitute)
+ (and (string=? (read-line p) "A?BCD")
+ (eof-object? (read-line p))))))
\f
- (with-test-prefix "read-delimited"
+(with-test-prefix "read-delimited"
- (pass-if "delimiter hit"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p))
- (string=? " world!" (read-delimited ",.;" p))
- (eof-object? (read-delimited ",.;" p)))))
+ (pass-if "delimiter hit"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p))
+ (string=? " world!" (read-delimited ",.;" p))
+ (eof-object? (read-delimited ",.;" p)))))
- (pass-if "delimiter hit, split"
- (equal? '("hello" . #\,)
- (read-delimited ",.;"
- (open-input-string "hello, world!")
- 'split)))
+ (pass-if "delimiter hit, split"
+ (equal? '("hello" . #\,)
+ (read-delimited ",.;"
+ (open-input-string "hello, world!")
+ 'split)))
- (pass-if "delimiter hit, concat"
- (equal? '"hello,"
- (read-delimited ",.;" (open-input-string "hello, world!")
- 'concat)))
+ (pass-if "delimiter hit, concat"
+ (equal? '"hello,"
+ (read-delimited ",.;" (open-input-string "hello, world!")
+ 'concat)))
- (pass-if "delimiter hit, peek"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p 'peek))
- (char=? #\, (peek-char p)))))
+ (pass-if "delimiter hit, peek"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p 'peek))
+ (char=? #\, (peek-char p)))))
- (pass-if "eof"
- (eof-object? (read-delimited "}{" (open-input-string "")))))
+ (pass-if "eof"
+ (eof-object? (read-delimited "}{" (open-input-string "")))))
\f
- (with-test-prefix "read-delimited!"
-
- (pass-if "delimiter hit"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p))
- (string=? (substring s 0 5) "hello")
- (= 7 (read-delimited! ",.;" s p))
- (string=? (substring s 0 7) " world!")
- (eof-object? (read-delimited! ",.;" s p)))))
-
- (pass-if "delimiter hit, start+end"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
- (string=? (substring s 10 15) "hello"))))
-
- (pass-if "delimiter hit, split"
- (let ((s (make-string 123)))
- (and (equal? '(5 . #\,)
- (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'split))
- (string=? (substring s 0 5) "hello"))))
-
- (pass-if "delimiter hit, concat"
- (let ((s (make-string 123)))
- (and (= 6 (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'concat))
- (string=? (substring s 0 6) "hello,"))))
-
- (pass-if "delimiter hit, peek"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'peek))
- (string=? (substring s 0 5) "hello")
- (char=? #\, (peek-char p)))))
-
- (pass-if "string too small"
- (let ((s (make-string 7)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")))
- (string=? s "hello, "))))
-
- (pass-if "string too small, start+end"
- (let ((s (make-string 123)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'trim
- 70 77))
- (string=? (substring s 70 77) "hello, "))))
-
- (pass-if "string too small, split"
- (let ((s (make-string 7)))
- (and (equal? '(7 . #f)
- (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'split))
- (string=? s "hello, "))))
-
- (pass-if "eof"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string ""))))
-
- (pass-if "eof, split"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string "")))))
-
- (with-test-prefix "read-string"
-
- (pass-if "short string"
- (let* ((s "hello, world!")
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "100 chars"
- (let* ((s (make-string 100 #\space))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "longer than 100 chars"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if-equal "longer than 100 chars, with limit"
- "hello, world!"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (read-string p 13))))
-
- (with-test-prefix "read-string!"
-
- (pass-if "buf smaller"
- (let* ((s "hello, world!")
- (len (1- (string-length s)))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 1)
- (string=? (substring buf 0 1) (substring s len)))))
-
- (pass-if "buf right size"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 0)
- (string=? buf (substring s 0 len)))))
-
- (pass-if "buf bigger"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string (1+ len) #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? (substring buf 0 len) s)
- (= (read-string! buf p) 0)
- (string=? (substring buf 0 len) s)
- (string=? (substring buf len) "."))))))
+(with-test-prefix "read-delimited!"
+
+ (pass-if "delimiter hit"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 5) "hello")
+ (= 7 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 7) " world!")
+ (eof-object? (read-delimited! ",.;" s p)))))
+
+ (pass-if "delimiter hit, start+end"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
+ (string=? (substring s 10 15) "hello"))))
+
+ (pass-if "delimiter hit, split"
+ (let ((s (make-string 123)))
+ (and (equal? '(5 . #\,)
+ (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? (substring s 0 5) "hello"))))
+
+ (pass-if "delimiter hit, concat"
+ (let ((s (make-string 123)))
+ (and (= 6 (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'concat))
+ (string=? (substring s 0 6) "hello,"))))
+
+ (pass-if "delimiter hit, peek"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'peek))
+ (string=? (substring s 0 5) "hello")
+ (char=? #\, (peek-char p)))))
+
+ (pass-if "string too small"
+ (let ((s (make-string 7)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")))
+ (string=? s "hello, "))))
+
+ (pass-if "string too small, start+end"
+ (let ((s (make-string 123)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'trim
+ 70 77))
+ (string=? (substring s 70 77) "hello, "))))
+
+ (pass-if "string too small, split"
+ (let ((s (make-string 7)))
+ (and (equal? '(7 . #f)
+ (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? s "hello, "))))
+
+ (pass-if "eof"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string ""))))
+
+ (pass-if "eof, split"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string "")))))
+
+(with-test-prefix "read-string"
+
+ (pass-if "short string"
+ (let* ((s "hello, world!")
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "100 chars"
+ (let* ((s (make-string 100 #\space))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "longer than 100 chars"
+ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
- (string=? (read-string p) "")))))
++ (string=? (read-string p) ""))))
++
++ (pass-if-equal "longer than 100 chars, with limit"
++ "hello, world!"
++ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
++ (p (open-input-string s)))
++ (read-string p 13))))
+
+(with-test-prefix "read-string!"
+
+ (pass-if "buf smaller"
+ (let* ((s "hello, world!")
+ (len (1- (string-length s)))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 1)
+ (string=? (substring buf 0 1) (substring s len)))))
+
+ (pass-if "buf right size"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 0)
+ (string=? buf (substring s 0 len)))))
+
+ (pass-if "buf bigger"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string (1+ len) #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? (substring buf 0 len) s)
+ (= (read-string! buf p) 0)
+ (string=? (substring buf 0 len) s)
+ (string=? (substring buf len) ".")))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
--;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
--;;;; 2014 Free Software Foundation, Inc.
++;;;; Copyright (C) 2009-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
(number? (string-contains (car w)
"expected 3, got 2")))))
- #:to 'assembly)))))
+ (pass-if "~p"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(((@ (ice-9 format) format) #f "thing~p" 2))
+ #:opts %opts-w-format
- #:to 'assembly)))))
++ #:to 'cps)))))
+
+ (pass-if "~p, too few arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~p")
+ #:opts %opts-w-format
- #:to 'assembly)))))
++ #:to 'cps)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 0")))))
+
+ (pass-if "~:p"
+ (null? (call-with-warnings
+ (lambda ()
+ (compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2))
+ #:opts %opts-w-format
- #:to 'assembly)))))
++ #:to 'cps)))))
+
+ (pass-if "~:@p, too many arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5)
+ #:opts %opts-w-format
- #:to 'assembly)))))
++ #:to 'cps)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 2")))))
+
+ (pass-if "~:@p, too few arguments"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '((@ (ice-9 format) format) #f "pupp~:@p")
+ #:opts %opts-w-format
++ #:to 'cps)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "expected 1, got 0")))))
+
(pass-if "~?"
(null? (call-with-warnings
(lambda ()
(let ((w (call-with-warnings
(lambda ()
(let ((in (open-input-string
-- "(use-modules ((ice-9 format)
-- #:renamer (symbol-prefix-proc 'i9-)))
++ "(use-modules ((ice-9 format) #:prefix i9-))
(i9-format #t \"yo! ~A\" 1 2)")))
(read-and-compile in
#:opts %opts-w-format
HCoop / bpt / guile.git / commitdiff