module/srfi/srfi-45.scm

   1 ;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
   2
   3 ;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
   4 ;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
   5
   6 ;; Permission is hereby granted, free of charge, to any person
   7 ;; obtaining a copy of this software and associated documentation
   8 ;; files (the "Software"), to deal in the Software without
   9 ;; restriction, including without limitation the rights to use, copy,
  10 ;; modify, merge, publish, distribute, sublicense, and/or sell copies
  11 ;; of the Software, and to permit persons to whom the Software is
  12 ;; furnished to do so, subject to the following conditions:
  13
  14 ;; The above copyright notice and this permission notice shall be
  15 ;; included in all copies or substantial portions of the Software.
  16
  17 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  18 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  19 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  20 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  21 ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
  22 ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  23 ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  24 ;; SOFTWARE.
  25
  26 ;;; Commentary:
  27
  28 ;; This is the code of the reference implementation of SRFI-45, modified
  29 ;; to use SRFI-9 and to add 'promise?' to the list of exports.
  30
  31 ;; This module is documented in the Guile Reference Manual.
  32
  33 ;;; Code:
  34
  35 (define-module (srfi srfi-45)
  36   #:export (delay
  37              lazy
  38              force
  39              eager
  40              promise?)
  41   #:replace (delay force promise?)
  42   #:use-module (srfi srfi-9)
  43   #:use-module (srfi srfi-9 gnu))
  44
  45 (cond-expand-provide (current-module) '(srfi-45))
  46
  47 (define-record-type promise (make-promise val) promise?
  48   (val promise-val promise-val-set!))
  49
  50 (define-record-type value (make-value tag proc) value?
  51   (tag value-tag value-tag-set!)
  52   (proc value-proc value-proc-set!))
  53
  54 (define-syntax-rule (lazy exp)
  55   (make-promise (make-value 'lazy (lambda () exp))))
  56
  57 (define (eager x)
  58   (make-promise (make-value 'eager x)))
  59
  60 (define-syntax-rule (delay exp)
  61   (lazy (eager exp)))
  62
  63 (define (force promise)
  64   (let ((content (promise-val promise)))
  65     (case (value-tag content)
  66       ((eager) (value-proc content))
  67       ((lazy)  (let* ((promise* ((value-proc content)))
  68                       (content  (promise-val promise)))        ; *
  69                  (if (not (eqv? (value-tag content) 'eager))   ; *
  70                      (begin (value-tag-set! content
  71                                             (value-tag (promise-val promise*)))
  72                             (value-proc-set! content
  73                                              (value-proc (promise-val promise*)))
  74                             (promise-val-set! promise* content)))
  75                  (force promise))))))
  76
  77 ;; (*) These two lines re-fetch and check the original promise in case
  78 ;;     the first line of the let* caused it to be forced.  For an example
  79 ;;     where this happens, see reentrancy test 3 below.
  80
  81 (define* (promise-visit promise #:key on-eager on-lazy)
  82   (define content (promise-val promise))
  83   (case (value-tag content)
  84     ((eager) (on-eager (value-proc content)))
  85     ((lazy)  (on-lazy (value-proc content)))))
  86
  87 (set-record-type-printer! promise
  88   (lambda (promise port)
  89     (promise-visit promise
  90       #:on-eager (lambda (value)
  91                    (format port "#<promise = ~s>" value))
  92       #:on-lazy  (lambda (proc)
  93                    (format port "#<promise => ~s>" proc)))))