Commit 719510df authored by Erick's avatar Erick

Added SRFI-74 support

parent 25661947
......@@ -91,7 +91,7 @@ State can be one of the following values
? 71 LET-syntax for multiple values
- 72 Simple hygienic macros
- 74 Octet-Addressed Binary Blocks
Y 74 Octet-Addressed Binary Blocks
? 78 Lightweight testing
N 86 MU and NU simulating VALUES & CALL-WITH-VALUES, ...
......@@ -107,4 +107,4 @@ State can be one of the following values
Y 98 An interface to access environment variables
? 99 ERR5RS Records
Implemented SRFIs: 40/70
Implemented SRFIs: 41/70
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 26-Sep-2008 08:10 (eg)
;; Last file update: 4-Apr-2010 20:05 (eg)
;;
;; ======================================================================
......@@ -503,6 +503,16 @@ following expression ])
(p [,(quick-link-srfi 70) is fully supported.]))
;; ----------------------------------------------------------------------
;; SRFI 74 -- Octet-Addressed Binary Blocks
;; ----------------------------------------------------------------------
(srfi-section 74
(p [,(quick-link-srfi 74) is fully supported. To use SRFI-74,
you need to insert the following expression])
(fontified-code [(require "srfi-74")])
(p [in your code or uses the ,(code "cond-expand") special form.]))
;; ----------------------------------------------------------------------
;; SRFI 88 -- Keyword objects
;; ----------------------------------------------------------------------
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 4-Jan-2010 12:08 (eg)
# Last file update: 4-Apr-2010 20:15 (eg)
SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d
......@@ -74,6 +74,7 @@ scheme_SRCS = STklos.init \
srfi-66.stk \
srfi-69.stk \
srfi-70.stk \
srfi-74.stk \
srfi-89.stk \
srfi-96.stk \
tar.stk \
......
......@@ -19,7 +19,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 4-Jan-2010 12:08 (eg)
# Last file update: 4-Apr-2010 20:15 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
......@@ -314,6 +314,7 @@ scheme_SRCS = STklos.init \
srfi-66.stk \
srfi-69.stk \
srfi-70.stk \
srfi-74.stk \
srfi-89.stk \
srfi-96.stk \
tar.stk \
......
;;;;
;;;; srfi-0.stk -- SRFI-0 aka cond-expand
;;;;
;;;; Copyright 1999-2008 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 1999-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 30-Aug-1999 16:26 (eg)
;;;; Last file update: 22-Sep-2008 14:22 (eg)
;;;; Last file update: 4-Apr-2010 19:59 (eg)
;;;;
(define-module SRFI-0
......@@ -109,7 +109,7 @@
;; srfi-71 ; LET-syntax for multiple values
;; srfi-72 ; Simple hygienic macros
;; srfi-73 ; ....... withdrawn
;; srfi-74 ; Octet-Addressed Binary Blocks
(srfi-74 "srfi-74") ; Octet-Addressed Binary Blocks
;; srfi-75 ; ....... withdrawn
;; srfi-76 ; ....... withdrawn
;; srfi-77 ; ....... withdrawn
......
;;;;
;;;; srfi-74.stk -- SRFI-74 implementation
;;;;
;;;; Copyright 2010 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;; Author: Michael Sperber
;;;; Modified by: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 2005
;;;; Last file update: 4-Apr-2010 19:55 (eg)
;;;;
;;;; This code is an adaptation of the reference implementation provided
;;;; with the SRFI document by Michael Sperber.
; Octet-addressed binary objects
; Copyright (C) Michael Sperber (2005). All Rights Reserved.
;
; Permission is hereby granted, free of charge, to any person
; obtaining a copy of this software and associated documentation files
; (the "Software"), to deal in the Software without restriction,
; including without limitation the rights to use, copy, modify, merge,
; publish, distribute, sublicense, and/or sell copies of the Software,
; and to permit persons to whom the Software is furnished to do so,
; subject to the following conditions:
;
; The above copyright notice and this permission notice shall be
; included in all copies or substantial portions of the Software.
;
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
; SOFTWARE.
; This uses SRFIs 23, 26, 60, and 66
(require "srfi-26")
(require "srfi-60")
(require "srfi-66")
(define-module SRFI-74
(export endianness blob? make-blob blob-length
blob-u8-ref blob-s8-ref
blob-u8-set! blob-s8-set!
blob-uint-ref blob-sint-ref
blob-uint-set! blob-sint-set!
blob-u16-ref blob-s16-ref blob-u16-native-ref
blob-s16-native-ref blob-u16-set! blob-s16-set!
blob-u16-native-set! blob-s16-native-set!
blob-u32-ref blob-s32-ref blob-u32-native-ref
blob-s32-native-ref blob-u32-set! blob-s32-set!
blob-u32-native-set! blob-s32-native-set!
blob-u64-ref blob-s64-ref blob-u64-native-ref
blob-s64-native-ref blob-u64-set! blob-s64-set!
blob-u64-native-set! blob-s64-native-set!
blob=? blob-copy! blob-copy blob->u8-list u8-list->blob
blob->uint-list blob->sint-list uint-list->
blob sint-list->blob)
(define *endianness/little* (list 'little))
(define *endianness/big* (list 'big))
(define *endianness/native*
(if (%big-endian?) *endianness/big* *endianness/little*))
(define-syntax endianness
(syntax-rules (little big native)
((endianness little) (in-module SRFI-74 *endianness/little*))
((endianness big) (in-module SRFI-74 *endianness/big*))
((endianness native) (in-module SRFI-74 *endianness/native*))))
(define blob? u8vector?)
(define (make-blob k)
(make-u8vector k 0))
(define (blob-length b)
(u8vector-length b))
(define (blob-u8-ref b k)
(u8vector-ref b k))
(define (blob-u8-set! b k octet)
(u8vector-set! b k octet))
(define (blob-s8-ref b k)
(u8->s8 (u8vector-ref b k)))
(define (u8->s8 octet)
(if (> octet 127)
(- octet 256)
octet))
(define (blob-s8-set! b k val)
(u8vector-set! b k (s8->u8 val)))
(define (s8->u8 val)
(if (negative? val)
(+ val 256)
val))
(define (index-iterate start count low-first?
unit proc)
(if low-first?
(let loop ((index 0)
(acc unit))
(if (>= index count)
acc
(loop (+ index 1)
(proc (+ start index) acc))))
(let loop ((index (- (+ start count) 1))
(acc unit))
(if (< index start)
acc
(loop (- index 1)
(proc index acc))))))
(define (blob-uint-ref size endness blob index)
(index-iterate index size
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))
(define (blob-sint-ref size endness blob index)
(let ((high-byte (u8vector-ref blob
(if (eq? endness (endianness big))
index
(- (+ index size) 1)))))
(if (> high-byte 127)
(- (+ 1
(index-iterate index size
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (- 255 (u8vector-ref blob index))
(arithmetic-shift acc 8))))))
(index-iterate index size
(eq? (endianness big) endness)
0
(lambda (index acc)
(+ (u8vector-ref blob index) (arithmetic-shift acc 8)))))))
(define (make-uint-ref size)
(cut blob-uint-ref size <> <> <>))
(define (make-sint-ref size)
(cut blob-sint-ref size <> <> <>))
(define (blob-uint-set! size endness blob index val)
(index-iterate index size (eq? (endianness little) endness)
val
(lambda (index acc)
(u8vector-set! blob index (remainder acc 256))
(quotient acc 256)))
(values))
(define (blob-sint-set! size endness blob index val)
(if (negative? val)
(index-iterate index size (eq? (endianness little) endness)
(- -1 val)
(lambda (index acc)
(u8vector-set! blob index (- 255 (remainder acc 256)))
(quotient acc 256)))
(index-iterate index size (eq? (endianness little) endness)
val
(lambda (index acc)
(u8vector-set! blob index (remainder acc 256))
(quotient acc 256))))
(values))
(define (make-uint-set! size)
(cut blob-uint-set! size <> <> <> <>))
(define (make-sint-set! size)
(cut blob-sint-set! size <> <> <> <>))
(define (make-ref/native base base-ref)
(lambda (blob index)
(ensure-aligned index base)
(base-ref (endianness native) blob index)))
(define (make-set!/native base base-set!)
(lambda (blob index val)
(ensure-aligned index base)
(base-set! (endianness native) blob index val)))
(define (ensure-aligned index base)
(if (not (zero? (remainder index base)))
(error "non-aligned blob access" index base)))
(define blob-u16-ref (make-uint-ref 2))
(define blob-u16-set! (make-uint-set! 2))
(define blob-s16-ref (make-sint-ref 2))
(define blob-s16-set! (make-sint-set! 2))
(define blob-u16-native-ref (make-ref/native 2 blob-u16-ref))
(define blob-u16-native-set! (make-set!/native 2 blob-u16-set!))
(define blob-s16-native-ref (make-ref/native 2 blob-s16-ref))
(define blob-s16-native-set! (make-set!/native 2 blob-s16-set!))
(define blob-u32-ref (make-uint-ref 4))
(define blob-u32-set! (make-uint-set! 4))
(define blob-s32-ref (make-sint-ref 4))
(define blob-s32-set! (make-sint-set! 4))
(define blob-u32-native-ref (make-ref/native 4 blob-u32-ref))
(define blob-u32-native-set! (make-set!/native 4 blob-u32-set!))
(define blob-s32-native-ref (make-ref/native 4 blob-s32-ref))
(define blob-s32-native-set! (make-set!/native 4 blob-s32-set!))
(define blob-u64-ref (make-uint-ref 8))
(define blob-u64-set! (make-uint-set! 8))
(define blob-s64-ref (make-sint-ref 8))
(define blob-s64-set! (make-sint-set! 8))
(define blob-u64-native-ref (make-ref/native 8 blob-u64-ref))
(define blob-u64-native-set! (make-set!/native 8 blob-u64-set!))
(define blob-s64-native-ref (make-ref/native 8 blob-s64-ref))
(define blob-s64-native-set! (make-set!/native 8 blob-s64-set!))
; Auxiliary stuff
(define (blob-copy! source source-start target target-start count)
(u8vector-copy! source source-start target target-start count))
(define (blob-copy b)
(u8vector-copy b))
(define (blob=? b1 b2)
(u8vector=? b1 b2))
(define (blob->u8-list b)
(u8vector->list b))
(define (blob->s8-list b)
(map u8->s8 (u8vector->list b)))
(define (u8-list->blob l)
(list->u8vector l))
(define (s8-list->blob l)
(list->u8vector (map s8->u8 l)))
(define (make-blob->int-list blob-ref)
(lambda (size endness b)
(let ((ref (cut blob-ref size endness b <>))
(length (blob-length b)))
(let loop ((i 0) (r '()))
(if (>= i length)
(reverse r)
(loop (+ i size)
(cons (ref i) r)))))))
(define blob->uint-list (make-blob->int-list blob-uint-ref))
(define blob->sint-list (make-blob->int-list blob-sint-ref))
(define (make-int-list->blob blob-set!)
(lambda (size endness l)
(let* ((blob (make-blob (* size (length l))))
(set! (cut blob-set! size endness blob <> <>)))
(let loop ((i 0) (l l))
(if (null? l)
blob
(begin
(set! i (car l))
(loop (+ i size) (cdr l))))))))
(define uint-list->blob (make-int-list->blob blob-uint-set!))
(define sint-list->blob (make-int-list->blob blob-sint-set!))
)
;; ----------------------------------------------------------------------
(select-module stklos)
(import SRFI-74)
(provide "srfi-74")
This diff is collapsed.
This diff is collapsed.
......@@ -2,7 +2,7 @@
*
* s y s t e m . c -- System relative primitives
*
* Copyright 1994-2009 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1994-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Permission to use, copy, modify, distribute,and license this
......@@ -16,7 +16,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 29-Mar-1994 10:57
* Last file update: 14-Jan-2009 11:26 (eg)
* Last file update: 4-Apr-2010 19:53 (eg)
*/
#include <unistd.h>
......@@ -1087,13 +1087,20 @@ DEFINE_PRIMITIVE("hostname", hostname, subr0, (void))
return STk_Cstring2string(buff);
}
/*
<doc EXT pause
* (pause)
*
doc>
*/
DEFINE_PRIMITIVE("pause", pause, subr0, (void))
{
pause();
return STk_void;
}
/*
......@@ -1117,6 +1124,14 @@ DEFINE_PRIMITIVE("%chmod", change_mode, subr2, (SCM file, SCM value))
}
DEFINE_PRIMITIVE("%big-endian?", big_endianp, subr0, (void))
{
int i = 1;
char *p = (char *)&i;
return MAKE_BOOLEAN(p[0] != 1);
}
int STk_init_system(void)
{
......@@ -1193,5 +1208,6 @@ int STk_init_system(void)
ADD_PRIMITIVE(posixify_filename);
ADD_PRIMITIVE(pause);
ADD_PRIMITIVE(big_endianp);
return TRUE;
}
;;;;
;;;; test-srfi.stk -- Test of various SRFIs
;;;;
;;;; Copyright © 2005 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;; Copyright 2005-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,13 +21,26 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 4-Aug-2005 10:34 (eg)
;;;; Last file update: 13-Sep-2005 17:32 (eg)
;;;; Last file update: 5-Apr-2010 00:29 (eg)
;;;;
(require "test")
(test-section "SRFIs")
;; ----------------------------------------------------------------------
;; SRFI 62 ...
;; ----------------------------------------------------------------------
(test-subsection "SRFI 62 - S-expression comments")
(test "srfi-62.1" 5 (+ 1 #;(* 2 3) 4))
(test "srfi-62.2" '(x z) (list 'x #;'y 'z))
(test "srfi-62.3" 12 (* 3 4 #;(+ 1 2)))
(test "srfi-62.4" 16 (#;sqrt abs -16))
(test "srfi-62.5" '(a e) (list 'a #;(list 'b #;c 'd) 'e))
(test "srfi-62.6" '(a . c) '(a . #;b c))
(test "srfi-62.7" '(a . b) '(a . b #;c))
;; ----------------------------------------------------------------------
;; SRFI 71 ...
......@@ -86,23 +99,157 @@
(test "number->string.1" "+inf.0" (number->string +inf.0))
(test "number->string.2" "-inf.0" (number->string -inf.0))
;; ----------------------------------------------------------------------
;; SRFI 62 ...
;; SRFI 74 ...
;; ----------------------------------------------------------------------
(test-subsection "SRFI 62 - S-expression comments")
(test "srfi-62.1" 5 (+ 1 #;(* 2 3) 4))
(test "srfi-62.2" '(x z) (list 'x #;'y 'z))
(test "srfi-62.3" 12 (* 3 4 #;(+ 1 2)))
(test "srfi-62.4" 16 (#;sqrt abs -16))
(test "srfi-62.5" '(a e) (list 'a #;(list 'b #;c 'd) 'e))
(test "srfi-62.6" '(a . c) '(a . #;b c))
(test "srfi-62.7" '(a . b) '(a . b #;c))
(test-subsection "SRFI 74 - BLOBs")
(require "srfi-74")
(define b1 (make-blob 16))
(test "blob-length" 16 (blob-length b1))
(blob-u8-set! b1 0 223)
(blob-s8-set! b1 1 123)
(blob-s8-set! b1 2 -123)
(blob-u8-set! b1 3 15)
(test "blob repr"
'(223 123 123 -123 133 15)
(list (blob-u8-ref b1 0)
(blob-s8-ref b1 1)
(blob-u8-ref b1 1)
(blob-s8-ref b1 2)
(blob-u8-ref b1 2)
(blob-u8-ref b1 3)))
(blob-uint-set! 16 (endianness little) b1 0 (- (expt 2 128) 3))
(test "blob-uint-ref.1"
(- (expt 2 128) 3)
(blob-uint-ref 16 (endianness little) b1 0))
(test "blob-uint-ref.2"
-3
(blob-sint-ref 16 (endianness little) b1 0))
(test "blob->u8-list"
'(253 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255)
(blob->u8-list b1))
(blob-uint-set! 16 (endianness big) b1 0 (- (expt 2 128) 3))
(test "blob-uint-ref.3"
(- (expt 2 128) 3)
(blob-uint-ref 16 (endianness big) b1 0))
(test "blob-sint-ref"
-3
(blob-sint-ref 16 (endianness big) b1 0))
(test "blob->u8-list"
'(255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 253)
(blob->u8-list b1))
(test "blob-u16-ref"
65023
(blob-u16-ref (endianness little) b1 14))
(test "blob-s16-ref"
-513
(blob-s16-ref (endianness little) b1 14))
(test "blob-u16-ref"
65533
(blob-u16-ref (endianness big) b1 14))
(test "blob-s16-ref"
-3
(blob-s16-ref (endianness big) b1 14))
(blob-u16-set! (endianness little) b1 0 12345)
(blob-u16-native-set! b1 0 12345)
(test "blob-u16-native-ref"
12345
(blob-u16-native-ref b1 0))
(test "blob-u32-ref"
4261412863
(blob-u32-ref (endianness little) b1 12))
(test "blob-s32-ref"
-33554433
(blob-s32-ref (endianness little) b1 12))
(test "blob-u32-ref"
4294967293
(blob-u32-ref (endianness big) b1 12))
(test "blob-s32-ref"
-3
(blob-s32-ref(endianness big) b1 12))
(blob-u32-set! (endianness little) b1 0 12345)
(blob-u32-native-set! b1 0 12345)
(test "blob-u32-native-ref"
12345
(blob-u32-native-ref b1 0))
(test "blob-u64-ref"
18302628885633695743
(blob-u64-ref (endianness little) b1 8))
(test "(blob-s64-ref (endianness little) b1 8)"
-144115188075855873
(blob-s64-ref (endianness little) b1 8))
(test "(blob-u64-ref (endianness big) b1 8)"
18446744073709551613
(blob-u64-ref (endianness big) b1 8))
(test "(blob-s64-ref (endianness big) b1 8)"
-3
(blob-s64-ref (endianness big) b1 8))
(blob-u64-set! (endianness little) b1 0 12345)
(blob-u64-native-set! b1 0 12345)
(test "(blob-u64-native-ref b1 0)"
12345
(blob-u64-native-ref b1 0))
(define b2 (u8-list->blob '(1 2 3 4 5 6 7 8)))
(define b3 (blob-copy b2))
(test "(blob=? b2 b3)"
#t
(blob=? b2 b3))
(test "(blob=? b1 b2)"
#f
(blob=? b1 b2))
(blob-copy! b3 0 b3 4 4)
(test "(blob->u8-list b3)"
'(1 2 3 4 1 2 3 4)
(blob->u8-list b3))
(blob-copy! b3 0 b3 2 6)
(test "(blob->u8-list b3)"
'(1 2 1 2 3 4 1 2)
(blob->u8-list b3))
(blob-copy! b3 2 b3 0 6)
(test "(blob->u8-list b3)"
'(1 2 3 4 1 2 1 2)
(blob->u8-list b3))
(test "(blob->uint-list 1 (endianness little) b3)"
'(1 2 3 4 1 2 1 2)
(blob->uint-list 1 (endianness little) b3))
(test "(blob->uint-list 2 (endianness little) b3)"
'(513 1027 513 513)
(blob->uint-list 2 (endianness little) b3))
(define b4 (u8-list->blob '(0 0 0 0 0 0 48 57 255 255 255 255 255 255 255 253)))
(test "(blob->sint-list 2 (endianness little) b4)"
'(0 0 0 14640 -1 -1 -1 -513)
(blob->sint-list 2 (endianness little) b4))
;; ----------------------------------------------------------------------
(test-section-end)
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment