Commit e371c640 authored by Erick Gallesio's avatar Erick Gallesio

Added SRFI-45

parent d0aeb3bb
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 9-Dec-2007 16:59 (eg)
;; Last file update: 9-Dec-2007 21:33 (eg)
;;
;; ======================================================================
......@@ -393,6 +393,16 @@ described in this document (procedures
,(ref :mark "make-parameter") and
,(ref :mark "parameterize")).]))
;; ----------------------------------------------------------------------
;; SRFI 45 -- Primitives for Expressing Iterative Lazy Algorithms
;; ----------------------------------------------------------------------
(srfi-section 45
(p [,(quick-link-srfi 45) is fully supported. To use SRFI-45,
you need to insert the following expression])
(fontified-code [(require "srfi-45")])
(p [in your code or uses the ,(code "cond-expand") special form.]))
;; ----------------------------------------------------------------------
;; SRFI 48 -- Intermediate Format Strings
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 18-Aug-2004 12:43 (eg)
;;;; Last file update: 9-Dec-2007 16:57 (eg)
;;;; Last file update: 9-Dec-2007 21:34 (eg)
;;;;
(define srfi-address "http://srfi.schemers.org/srfi-~A/srfi-~A.html")
......@@ -54,6 +54,7 @@
(36 . "I/O Conditions")
(38 . "External representation of shared structures")
(39 . "Parameters objects")
(45 . "Optional positional and named parameters")
(48 . "Intermediate Format Strings")
(55 . "Require-extension")
(60 . "Integers as bits")
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 9-Dec-2007 16:56 (eg)
# Last file update: 9-Dec-2007 21:31 (eg)
SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d @LURCDIR@
......@@ -66,6 +66,7 @@ scheme_SRCS = STklos.init \
srfi-34.stk \
srfi-35.stk \
srfi-36.stk \
srfi-45.stk \
srfi-48.stk \
srfi-60.stk \
srfi-66.stk \
......@@ -103,6 +104,7 @@ scheme_OBJS = compfile.ostk \
srfi-34.ostk \
srfi-35.ostk \
srfi-36.ostk \
srfi-45.ostk \
srfi-48.ostk \
srfi-60.ostk \
srfi-66.ostk \
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 9-Dec-2007 16:56 (eg)
# Last file update: 9-Dec-2007 21:31 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
......@@ -258,6 +258,7 @@ scheme_SRCS = STklos.init \
srfi-34.stk \
srfi-35.stk \
srfi-36.stk \
srfi-45.stk \
srfi-48.stk \
srfi-60.stk \
srfi-66.stk \
......@@ -295,6 +296,7 @@ scheme_OBJS = compfile.ostk \
srfi-34.ostk \
srfi-35.ostk \
srfi-36.ostk \
srfi-45.ostk \
srfi-48.ostk \
srfi-60.ostk \
srfi-66.ostk \
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 30-Aug-1999 16:26 (eg)
;;;; Last file update: 9-Dec-2007 16:53 (eg)
;;;; Last file update: 9-Dec-2007 21:29 (eg)
;;;;
(define-module SRFI-0
......@@ -80,7 +80,7 @@
;; srfi-42 ; Eager Comprehensions
;; srfi-43 ; Vector library
;; srfi-44 ; Collections
;; srfi-45 ; primitives for lazy algorithms
(srfi-45 "srfi-45") ; primitives for lazy algorithms
;; srfi-46 ; Basic Syntax-rules Extensions
;; srfi-47 ; Array
srfi-48 ; Intermediate Format Strings
......
;;;;
;;;; srfi-45.stk -- Implementation of SRFI-45
;;;;
;;;; Copyright (C) André van Tonder (2003). 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.
;;;;
;;;; Creation date: 9-Dec-2007 21:15 (eg)
;;;; Last file update: 9-Dec-2007 21:28 (eg)
;;;;
;; Code adapted for STklos boxes
(define-syntax lazy
(syntax-rules ()
((lazy exp)
(make-box (cons 'lazy (lambda () exp))))))
(define (eager x)
(make-box (cons 'eager x)))
(define-syntax delay
(syntax-rules ()
((delay exp) (lazy (eager exp)))))
(define (force promise)
(let ((content (unbox promise)))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (unbox promise))) ; *
(if (not (eqv? (car content) 'eager)) ; *
(begin (set-car! content (car (unbox promise*)))
(set-cdr! content (cdr (unbox promise*)))
(box-set! promise* content)))
(force promise))))))
; (*) These two lines re-fetch and check the original promise in case
; the first line of the let* caused it to be forced. For an example
; where this happens, see reentrancy test 3 below.
This diff is collapsed.
This diff is collapsed.
/*
* box.c -- The box type
*
* Copyright 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
*
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program 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 General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
* Author: Erick Gallesio [eg@essi.fr]
* Creation date: 9-Dec-2007 18:04 (eg)
* Last file update: 9-Dec-2007 20:28 (eg)
*/
#include <stklos.h>
static void error_bad_box(SCM obj)
{
STk_error("bad box object ~S", obj);
}
/*
<doc EXT make-box
* (make-box obj)
*
* Returns a new box that contains |obj|. The box is mutable.
* @lisp
* (let ((x (make-box 10)))
* (list 10 x)) => (10 #&10)
* @end lisp
doc>
*/
DEFINE_PRIMITIVE("make-box", make_box, subr1, (SCM x))
{
SCM z;
NEWCELL(z, box);
BOX_VALUE(z) = x;
return z;
}
/*
<doc EXT make-constant-box
* (make-constant-box obj)
*
* Returns a new box that contains |obj|. The box is immutable.
doc>
*/
DEFINE_PRIMITIVE("make-constant-box", make_cbox, subr1, (SCM x))
{
SCM z;
NEWCELL(z, box);
BOX_VALUE(z) = x;
BOXED_INFO(z) |= BOX_CONST;
return z;
}
/*
<doc EXT box?
* (box? obj)
*
* Returns |#t| if |obj|is box, |#f| otherwise.
doc>
*/
DEFINE_PRIMITIVE("box?", boxp, subr1, (SCM x))
{
return MAKE_BOOLEAN(BOXP(x));
}
/*
<doc EXT box-mutable?
* (box-mutable? obj)
*
* Returns |#t| if |obj|is mutable box, |#f| otherwise.
doc>
*/
DEFINE_PRIMITIVE("box-mutable?", box_mutablep, subr1, (SCM x))
{
return MAKE_BOOLEAN(BOXP(x) && !(BOXED_INFO(x) & BOX_CONST));
}
/*
<doc EXT unbox
* (unbox box)
*
* Returns the content of |box|. For any |obj|, |(unbox (make-box obj))|
* returns |obj|.
doc>
*/
DEFINE_PRIMITIVE("unbox", unbox, subr1, (SCM x))
{
if (! BOXP(x)) error_bad_box(x);
return BOX_VALUE(x);
}
/*
<doc EXT box-set!
* (box-set! box x)
*
* Sets the content of |box| to |x|. The box must be mutable.
doc>
*/
DEFINE_PRIMITIVE("box-set!", box_set, subr2, (SCM x, SCM val))
{
if (!BOXP(x)) error_bad_box(x);
if (BOXED_INFO(x) & BOX_CONST) STk_error("box is not mutable ~S", x);
BOX_VALUE(x) = val;
return STk_void;
}
int STk_init_box(void)
{
ADD_PRIMITIVE(make_box);
ADD_PRIMITIVE(make_cbox);
ADD_PRIMITIVE(boxp);
ADD_PRIMITIVE(box_mutablep);
ADD_PRIMITIVE(unbox);
ADD_PRIMITIVE(box_set);
return TRUE;
}
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 3-May-2005 12:28 (eg)
;;;; Last file update: 1-Jun-2007 16:08 (eg)
;;;; Last file update: 9-Dec-2007 21:03 (eg)
;;;;
(load "./test.stk")
......@@ -37,6 +37,7 @@
(load "test-srfi.stk")
(load "test-md5.stk")
(load "test-base64.stk")
(load "test-box.stk")
(load "test-r5rs-pitfall.stk"))
......
;;;;
;;;; test-box.stk -- Tests on boxes
;;;;
;;;; Copyright © 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 9-Dec-2007 21:02 (eg)
;;;; Last file update: 9-Dec-2007 21:11 (eg)
;;;;
(require "test")
(test-section "Boxes")
(test "make-box"
(with-output-to-string (lambda () (write (make-box 10))))
"#&10")
(test "make-constant-box"
(with-output-to-string (lambda () (write (make-constant-box 10))))
"#&10")
(test "reader"
(eval-from-string "#&100")
(make-box 100))
(test "equal?.1"
(equal? 100 (make-box 100))
#f)
(test "equal?.2"
(equal? #&100 (make-box 100))
#t)
(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