mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-23 04:50:28 +02:00
Implement R6RS bytevector read syntax.
* libguile/read.c (scm_read_bytevector): New function. (scm_read_sharp): Add `v' case for bytevectors. * test-suite/lib.scm (exception:read-error): New variable. * test-suite/tests/bytevectors.test ("Datum Syntax"): New test set.
This commit is contained in:
parent
55bf8cb7af
commit
0ba0b38489
3 changed files with 86 additions and 2 deletions
|
@ -1,4 +1,4 @@
|
||||||
/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008 Free Software
|
/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008, 2009 Free Software
|
||||||
* Foundation, Inc.
|
* Foundation, Inc.
|
||||||
*
|
*
|
||||||
* This library is free software; you can redistribute it and/or
|
* This library is free software; you can redistribute it and/or
|
||||||
|
@ -29,6 +29,7 @@
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
|
|
||||||
#include "libguile/_scm.h"
|
#include "libguile/_scm.h"
|
||||||
|
#include "libguile/bytevectors.h"
|
||||||
#include "libguile/chars.h"
|
#include "libguile/chars.h"
|
||||||
#include "libguile/eval.h"
|
#include "libguile/eval.h"
|
||||||
#include "libguile/unif.h"
|
#include "libguile/unif.h"
|
||||||
|
@ -882,6 +883,30 @@ scm_read_srfi4_vector (int chr, SCM port)
|
||||||
return scm_i_read_array (port, chr);
|
return scm_i_read_array (port, chr);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static SCM
|
||||||
|
scm_read_bytevector (int chr, SCM port)
|
||||||
|
{
|
||||||
|
chr = scm_getc (port);
|
||||||
|
if (chr != 'u')
|
||||||
|
goto syntax;
|
||||||
|
|
||||||
|
chr = scm_getc (port);
|
||||||
|
if (chr != '8')
|
||||||
|
goto syntax;
|
||||||
|
|
||||||
|
chr = scm_getc (port);
|
||||||
|
if (chr != '(')
|
||||||
|
goto syntax;
|
||||||
|
|
||||||
|
return scm_u8_list_to_bytevector (scm_read_sexp (chr, port));
|
||||||
|
|
||||||
|
syntax:
|
||||||
|
scm_i_input_error ("read_bytevector", port,
|
||||||
|
"invalid bytevector prefix",
|
||||||
|
SCM_MAKE_CHAR (chr));
|
||||||
|
return SCM_UNSPECIFIED;
|
||||||
|
}
|
||||||
|
|
||||||
static SCM
|
static SCM
|
||||||
scm_read_guile_bit_vector (int chr, SCM port)
|
scm_read_guile_bit_vector (int chr, SCM port)
|
||||||
{
|
{
|
||||||
|
@ -1050,6 +1075,8 @@ scm_read_sharp (int chr, SCM port)
|
||||||
case 'f':
|
case 'f':
|
||||||
/* This one may return either a boolean or an SRFI-4 vector. */
|
/* This one may return either a boolean or an SRFI-4 vector. */
|
||||||
return (scm_read_srfi4_vector (chr, port));
|
return (scm_read_srfi4_vector (chr, port));
|
||||||
|
case 'v':
|
||||||
|
return (scm_read_bytevector (chr, port));
|
||||||
case '*':
|
case '*':
|
||||||
return (scm_read_guile_bit_vector (chr, port));
|
return (scm_read_guile_bit_vector (chr, port));
|
||||||
case 't':
|
case 't':
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;;; test-suite/lib.scm --- generic support for testing
|
;;;; test-suite/lib.scm --- generic support for testing
|
||||||
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
|
;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; This program is free software; you can redistribute it and/or
|
;;;; This program is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
@ -32,6 +32,7 @@
|
||||||
exception:system-error
|
exception:system-error
|
||||||
exception:miscellaneous-error
|
exception:miscellaneous-error
|
||||||
exception:string-contains-nul
|
exception:string-contains-nul
|
||||||
|
exception:read-error
|
||||||
|
|
||||||
;; Reporting passes and failures.
|
;; Reporting passes and failures.
|
||||||
run-test
|
run-test
|
||||||
|
@ -265,6 +266,8 @@
|
||||||
(cons 'system-error ".*"))
|
(cons 'system-error ".*"))
|
||||||
(define exception:miscellaneous-error
|
(define exception:miscellaneous-error
|
||||||
(cons 'misc-error "^.*"))
|
(cons 'misc-error "^.*"))
|
||||||
|
(define exception:read-error
|
||||||
|
(cons 'read-error "^.*$"))
|
||||||
|
|
||||||
;; as per throw in scm_to_locale_stringn()
|
;; as per throw in scm_to_locale_stringn()
|
||||||
(define exception:string-contains-nul
|
(define exception:string-contains-nul
|
||||||
|
|
|
@ -530,6 +530,60 @@
|
||||||
4)))))))
|
4)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(with-test-prefix "Datum Syntax"
|
||||||
|
|
||||||
|
(pass-if "empty"
|
||||||
|
(equal? (with-input-from-string "#vu8()" read)
|
||||||
|
(make-bytevector 0)))
|
||||||
|
|
||||||
|
(pass-if "simple"
|
||||||
|
(equal? (with-input-from-string "#vu8(1 2 3 4 5)" read)
|
||||||
|
(u8-list->bytevector '(1 2 3 4 5))))
|
||||||
|
|
||||||
|
(pass-if ">127"
|
||||||
|
(equal? (with-input-from-string "#vu8(0 255 127 128)" read)
|
||||||
|
(u8-list->bytevector '(0 255 127 128))))
|
||||||
|
|
||||||
|
(pass-if "self-evaluating"
|
||||||
|
(equal? (eval (with-input-from-string "#vu8(1 2 3 4 5)" read)
|
||||||
|
(current-module))
|
||||||
|
(u8-list->bytevector '(1 2 3 4 5))))
|
||||||
|
|
||||||
|
(pass-if "quoted"
|
||||||
|
(equal? (eval (with-input-from-string "'#vu8(1 2 3 4 5)" read)
|
||||||
|
(current-module))
|
||||||
|
(u8-list->bytevector '(1 2 3 4 5))))
|
||||||
|
|
||||||
|
(pass-if "literal simple"
|
||||||
|
(equal? #vu8(1 2 3 4 5)
|
||||||
|
(u8-list->bytevector '(1 2 3 4 5))))
|
||||||
|
|
||||||
|
(pass-if "literal >127"
|
||||||
|
(equal? #vu8(0 255 127 128)
|
||||||
|
(u8-list->bytevector '(0 255 127 128))))
|
||||||
|
|
||||||
|
(pass-if "literal quoted"
|
||||||
|
(equal? '#vu8(1 2 3 4 5)
|
||||||
|
(u8-list->bytevector '(1 2 3 4 5))))
|
||||||
|
|
||||||
|
(pass-if-exception "incorrect prefix"
|
||||||
|
exception:read-error
|
||||||
|
(with-input-from-string "#vi8(1 2 3)" read))
|
||||||
|
|
||||||
|
(pass-if-exception "extraneous space"
|
||||||
|
exception:read-error
|
||||||
|
(with-input-from-string "#vu8 (1 2 3)" read))
|
||||||
|
|
||||||
|
(pass-if-exception "negative integers"
|
||||||
|
exception:wrong-type-arg
|
||||||
|
(with-input-from-string "#vu8(-1 -2 -3)" read))
|
||||||
|
|
||||||
|
(pass-if-exception "out-of-range integers"
|
||||||
|
exception:wrong-type-arg
|
||||||
|
(with-input-from-string "#vu8(0 256)" read)))
|
||||||
|
|
||||||
|
|
||||||
;;; Local Variables:
|
;;; Local Variables:
|
||||||
;;; coding: latin-1
|
;;; coding: latin-1
|
||||||
;;; mode: scheme
|
;;; mode: scheme
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue