home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / guile / 1.6 / srfi / srfi-39.scm < prev    next >
Encoding:
Text File  |  2006-06-19  |  6.1 KB  |  165 lines
  1. ;;; srfi-39.scm --- Parameter objects
  2.  
  3. ;;     Copyright (C) 2004, 2005 Free Software Foundation, Inc.
  4. ;;
  5. ;; This program is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU General Public License as
  7. ;; published by the Free Software Foundation; either version 2, or
  8. ;; (at your option) any later version.
  9. ;;
  10. ;; This program is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; General Public License for more details.
  14. ;;
  15. ;; You should have received a copy of the GNU General Public License
  16. ;; along with this software; see the file COPYING.  If not, write to
  17. ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18. ;; Boston, MA 02110-1301 USA
  19. ;;
  20. ;; As a special exception, the Free Software Foundation gives permission
  21. ;; for additional uses of the text contained in its release of GUILE.
  22. ;;
  23. ;; The exception is that, if you link the GUILE library with other files
  24. ;; to produce an executable, this does not by itself cause the
  25. ;; resulting executable to be covered by the GNU General Public License.
  26. ;; Your use of that executable is in no way restricted on account of
  27. ;; linking the GUILE library code into it.
  28. ;;
  29. ;; This exception does not however invalidate any other reasons why
  30. ;; the executable file might be covered by the GNU General Public License.
  31. ;;
  32. ;; This exception applies only to the code released by the
  33. ;; Free Software Foundation under the name GUILE.  If you copy
  34. ;; code from other Free Software Foundation releases into a copy of
  35. ;; GUILE, as the General Public License permits, the exception does
  36. ;; not apply to the code that you add in this way.  To avoid misleading
  37. ;; anyone as to the status of such modified files, you must delete
  38. ;; this exception notice from them.
  39. ;;
  40. ;; If you write modifications of your own for GUILE, it is your choice
  41. ;; whether to permit this exception to apply to your modifications.
  42. ;; If you do not wish that, delete this exception notice.
  43.  
  44. ;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
  45. ;;; Date: 2004-05-05
  46.  
  47. ;;; Commentary:
  48.  
  49. ;; This is an implementation of SRFI-39 (Parameter objects).
  50. ;;
  51. ;; The implementation is based on Guile's fluid objects, and is, therefore,
  52. ;; thread-safe (parameters are thread-local).
  53. ;;
  54. ;; In addition to the forms defined in SRFI-39 (`make-parameter',
  55. ;; `parameterize'), a new procedure `with-parameters*' is provided.
  56. ;; This procedures is analogous to `with-fluids*' but taking as first
  57. ;; argument a list of parameter objects instead of a list of fluids.
  58. ;;
  59.  
  60. ;;; Code:
  61.  
  62. (define-module (srfi srfi-39)
  63.   #:use-module (ice-9 syncase)
  64.   #:use-module (srfi srfi-16)
  65.  
  66.   #:export (make-parameter)
  67.   #:export-syntax (parameterize)
  68.  
  69.   ;; helper procedure not in srfi-39.
  70.   #:export (with-parameters*))
  71.  
  72. ;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
  73. ;;
  74. (cond-expand-provide (current-module) '(srfi-39))
  75.  
  76. (define make-parameter
  77.   (case-lambda
  78.     ((val) (make-parameter/helper val (lambda (x) x)))
  79.     ((val conv) (make-parameter/helper val conv))))
  80.  
  81. (define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
  82. (define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
  83.  
  84. (define (make-parameter/helper val conv)
  85.   (let ((value (make-fluid))
  86.         (conv conv))
  87.     (begin
  88.       (fluid-set! value (conv val))
  89.       (lambda new-value
  90.         (cond
  91.          ((null? new-value) (fluid-ref value))
  92.          ((eq? (car new-value) get-fluid-tag) value)
  93.          ((eq? (car new-value) get-conv-tag) conv)
  94.          ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
  95.          (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
  96.  
  97. (define-syntax parameterize
  98.   (syntax-rules ()
  99.     ((_ ((?param ?value) ...) ?body ...)
  100.      (with-parameters* (list ?param ...)
  101.                        (list ?value ...)
  102.                        (lambda () ?body ...)))))
  103.  
  104. (define core:current-input-port current-input-port)
  105. (define-public (current-input-port . new-value)
  106.   (if (null? new-value)
  107.       (core:current-input-port)
  108.       (apply set-current-input-port new-value)))
  109.  
  110. (define core:current-output-port current-output-port)
  111. (define-public (current-output-port . new-value)
  112.   (if (null? new-value)
  113.       (core:current-output-port)
  114.       (apply set-current-output-port new-value)))
  115.  
  116. (define core:current-error-port current-error-port)
  117. (define-public (current-error-port . new-value)
  118.   (if (null? new-value)
  119.       (core:current-error-port)
  120.       (apply set-current-error-port new-value)))
  121.  
  122. (define port-list
  123.   (list current-input-port current-output-port current-error-port))
  124.  
  125. ;; There are no fluids behind current-input-port etc, so those parameter
  126. ;; objects are picked out of the list and handled separately with a
  127. ;; dynamic-wind to swap their values to and from a location (the "value"
  128. ;; variable in the swapper procedure "let").
  129. ;;
  130. ;; current-input-port etc are already per-dynamic-root, so this arrangement
  131. ;; works the same as a fluid.  Perhaps they could become fluids for ease of
  132. ;; implementation here.
  133. ;;
  134. ;; Notice the use of a param local variable for the swapper procedure.  It
  135. ;; ensures any application changes to the PARAMS list won't affect the
  136. ;; winding.
  137. ;;
  138. (define (with-parameters* params values thunk)
  139.   (let more ((params params)
  140.          (values values)
  141.          (fluids '())     ;; fluids from each of PARAMS
  142.          (convs  '())     ;; VALUES with conversion proc applied
  143.          (swapper noop))  ;; wind/unwind procedure for ports handling
  144.     (if (null? params)
  145.     (if (eq? noop swapper)
  146.         (with-fluids* fluids convs thunk)
  147.         (dynamic-wind
  148.         swapper
  149.         (lambda ()
  150.           (with-fluids* fluids convs thunk))
  151.         swapper))
  152.     (if (memq (car params) port-list)
  153.         (more (cdr params) (cdr values)
  154.           fluids convs
  155.           (let ((param (car params))
  156.             (value (car values))
  157.             (prev-swapper swapper))
  158.             (lambda ()
  159.               (set! value (param value))
  160.               (prev-swapper))))
  161.         (more (cdr params) (cdr values)
  162.           (cons ((car params) get-fluid-tag) fluids)
  163.           (cons (((car params) get-conv-tag) (car values)) convs)
  164.           swapper)))))
  165.