add define-once

[bpt/guile.git] / module / ice-9 / boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 6da81a7..f706a71 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -334,12 +334,13 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; have booted.
 (define (module-name x)
   '(guile))
+(define (module-add! module sym var)
+  (hashq-set! (%get-pre-modules-obarray) sym var))
 (define (module-define! module sym val)
   (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
     (if v
         (variable-set! v val)
-        (hashq-set! (%get-pre-modules-obarray) sym
-                    (make-variable val)))))
+        (module-add! (current-module) sym (make-variable val)))))
 (define (module-ref module sym)
   (let ((v (module-variable module sym)))
     (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
@@ -472,6 +473,11 @@ If there is no handler at all, Guile prints an error and then exits."
        (with-syntax ((s (datum->syntax x (syntax-source x))))
          #''s)))))
 
+(define-syntax define-once
+  (syntax-rules ()
+    ((_ sym val)
+     (define sym
+       (if (module-locally-bound? (current-module) 'sym) sym val)))))
 
 \f
 
@@ -531,6 +537,29 @@ If there is no handler at all, Guile prints an error and then exits."
 ;;;
 
 (define (identity x) x)
+
+(define (compose proc . rest)
+  "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+  (if (null? rest)
+      proc
+      (let ((g (apply compose rest)))
+        (lambda args
+          (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+  "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+  (lambda args
+    (not (apply proc args))))
+
+(define (const value)
+  "Return a procedure that accepts any number of arguments and returns
+VALUE."
+  (lambda _
+    value))
+
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 
@@ -1941,10 +1970,16 @@ If there is no handler at all, Guile prints an error and then exits."
 ;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
 ;;
 (define (module-use-interfaces! module interfaces)
-  (set-module-uses! module
-                    (append (module-uses module) interfaces))
-  (hash-clear! (module-import-obarray module))
-  (module-modified module))
+  (let ((prev (filter (lambda (used)
+                        (and-map (lambda (iface)
+                                   (not (equal? (module-name used)
+                                                (module-name iface))))
+                                 interfaces))
+                      (module-uses module))))
+    (set-module-uses! module
+                      (append prev interfaces))
+    (hash-clear! (module-import-obarray module))
+    (module-modified module)))
 
 \f
 
@@ -2253,6 +2288,7 @@ If there is no handler at all, Guile prints an error and then exits."
   (try-module-autoload name version))
 
 (define (reload-module m)
+  "Revisit the source file corresponding to the module @var{m}."
   (let ((f (module-filename m)))
     (if f
         (save-module-excursion
@@ -2847,8 +2883,13 @@ module '(ice-9 q) '(make-q q-length))}."
        (and-map symbol? (syntax->datum #'(name name* ...)))
        (with-syntax (((quoted-arg ...)
                       (parse #'(arg ...) '() '() '() '() '()))
-                     (filename (assq-ref (or (syntax-source x) '())
-                                         'filename)))
+                     ;; Ideally the filename is either a string or #f;
+                     ;; this hack is to work around a case in which
+                     ;; port-filename returns a symbol (`socket') for
+                     ;; sockets.
+                     (filename (let ((f (assq-ref (or (syntax-source x) '())
+                                                  'filename)))
+                                 (and (string? f) f))))
          #'(eval-when (eval load compile expand)
              (let ((m (define-module* '(name name* ...)
                         #:filename filename quoted-arg ...)))
@@ -3321,8 +3362,10 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; FIXME:
 (module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
 
+;; Set filename to #f to prevent reload.
 (define-module (guile-user)
-  #:autoload (system base compile) (compile))
+  #:autoload (system base compile) (compile compile-file)
+  #:filename #f)
 
 ;; Remain in the `(guile)' module at compilation-time so that the
 ;; `-Wunused-toplevel' warning works as expected.