srfi-45.scm 3.5 KB

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