LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/ice-9/sandbox.scm

@@ -0,0 +1,1399 @@
+;;; Sandboxed evaluation of Scheme code
+
+;;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+;;; 
+;;; Code:
+
+(define-module (ice-9 sandbox)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module ((ice-9 threads) #:select (current-thread))
+  #:use-module (system vm vm)
+  #:export (call-with-time-limit
+            call-with-allocation-limit
+            call-with-time-and-allocation-limits
+
+            eval-in-sandbox
+            make-sandbox-module
+
+            alist-bindings
+            array-bindings
+            bit-bindings
+            bitvector-bindings
+            char-bindings
+            char-set-bindings
+            clock-bindings
+            core-bindings
+            error-bindings
+            fluid-bindings
+            hash-bindings
+            iteration-bindings
+            keyword-bindings
+            list-bindings
+            macro-bindings
+            nil-bindings
+            number-bindings
+            pair-bindings
+            predicate-bindings
+            procedure-bindings
+            promise-bindings
+            prompt-bindings
+            regexp-bindings
+            sort-bindings
+            srfi-4-bindings
+            string-bindings
+            symbol-bindings
+            unspecified-bindings
+            variable-bindings
+            vector-bindings
+            version-bindings
+
+            mutating-alist-bindings
+            mutating-array-bindings
+            mutating-bitvector-bindings
+            mutating-fluid-bindings
+            mutating-hash-bindings
+            mutating-list-bindings
+            mutating-pair-bindings
+            mutating-sort-bindings
+            mutating-srfi-4-bindings
+            mutating-string-bindings
+            mutating-variable-bindings
+            mutating-vector-bindings
+
+            all-pure-bindings
+            all-pure-and-impure-bindings))
+
+
+(define (call-with-time-limit limit thunk limit-reached)
+  "Call @var{thunk}, but cancel it if @var{limit} seconds of wall-clock
+time have elapsed.  If the computation is cancelled, call
+@var{limit-reached} in tail position.  @var{thunk} must not disable
+interrupts or prevent an abort via a @code{dynamic-wind} unwind
+handler."
+  ;; FIXME: use separate thread instead of sigalrm.  If rounded limit is
+  ;; <= 0, make it 1 usec to signal immediately.
+  (let ((limit-usecs (max (inexact->exact (round (* limit 1e6))) 1))
+        (prev-sigalarm-handler #f)
+        (tag (make-prompt-tag)))
+    (call-with-prompt tag
+      (lambda ()
+        (dynamic-wind
+          (lambda ()
+            (set! prev-sigalarm-handler
+              (sigaction SIGALRM (lambda (sig)
+                                   ;; If signal handling is delayed
+                                   ;; until after prompt, no worries;
+                                   ;; the success path won the race.
+                                   (false-if-exception
+                                    (abort-to-prompt tag)))))
+            (setitimer ITIMER_REAL 0 0 0 limit-usecs))
+          thunk
+          (lambda ()
+            (setitimer ITIMER_REAL 0 0 0 0)
+            (match prev-sigalarm-handler
+              ((handler . flags)
+               (sigaction SIGALRM handler flags))))))
+      (lambda (k)
+        (limit-reached)))))
+
+(define (call-with-allocation-limit limit thunk limit-reached)
+  "Call @var{thunk}, but cancel it if @var{limit} bytes have been
+allocated.  If the computation is cancelled, call @var{limit-reached} in
+tail position.  @var{thunk} must not disable interrupts or prevent an
+abort via a @code{dynamic-wind} unwind handler.
+
+This limit applies to both stack and heap allocation.  The computation
+will not be aborted before @var{limit} bytes have been allocated, but
+for the heap allocation limit, the check may be postponed until the next
+garbage collection.
+
+Note that as a current shortcoming, the heap size limit applies to all
+threads; concurrent allocation by other unrelated threads counts towards
+the allocation limit."
+  (define (bytes-allocated) (assq-ref (gc-stats) 'heap-total-allocated))
+  (let ((zero (bytes-allocated))
+        (tag (make-prompt-tag))
+        (thread (current-thread)))
+    (define (check-allocation)
+      (when (< limit (- (bytes-allocated) zero))
+        (system-async-mark (lambda ()
+                             (false-if-exception (abort-to-prompt tag)))
+                           thread)))
+    (call-with-prompt tag
+      (lambda ()
+        (dynamic-wind
+          (lambda ()
+            (add-hook! after-gc-hook check-allocation))
+          (lambda ()
+            (call-with-stack-overflow-handler
+             ;; The limit is in "words", which used to be 4 or 8 but now
+             ;; is always 8 bytes.
+             (max (floor/ limit 8) 1)
+             thunk
+             (lambda () (abort-to-prompt tag))))
+          (lambda ()
+            (remove-hook! after-gc-hook check-allocation))))
+      (lambda (k)
+        (limit-reached)))))
+
+(define (call-with-time-and-allocation-limits time-limit allocation-limit
+                                              thunk)
+  "Invoke @var{thunk} in a dynamic extent in which its execution is
+limited to @var{time-limit} seconds of wall-clock time, and its
+allocation to @var{allocation-limit} bytes.  @var{thunk} must not
+disable interrupts or prevent an abort via a @code{dynamic-wind} unwind
+handler.
+
+If successful, return all values produced by invoking @var{thunk}.  Any
+uncaught exception thrown by the thunk will propagate out.  If the time
+or allocation limit is exceeded, an exception will be thrown to the
+@code{limit-exceeded} key."
+  (call-with-time-limit
+   time-limit
+   (lambda ()
+     (call-with-allocation-limit
+      allocation-limit
+      thunk
+      (lambda ()
+        (scm-error 'limit-exceeded "with-resource-limits"
+                   "Allocation limit exceeded" '() #f))))
+   (lambda ()
+     (scm-error 'limit-exceeded "with-resource-limits"
+                "Time limit exceeded" '() #f))))
+
+(define (sever-module! m)
+  "Remove @var{m} from its container module."
+  (match (module-name m)
+    ((head ... tail)
+     (let ((parent (resolve-module head #f)))
+       (unless (eq? m (module-ref-submodule parent tail))
+         (error "can't sever module?"))
+       (hashq-remove! (module-submodules parent) tail)))))
+
+;; bindings := module-binding-list ...
+;; module-binding-list := interface-name import ...
+;; import := name | (exported-name . imported-name)
+;; name := symbol
+(define (make-sandbox-module bindings)
+  "Return a fresh module that only contains @var{bindings}.
+
+The @var{bindings} should be given as a list of import sets.  One import
+set is a list whose car names an interface, like @code{(ice-9 q)}, and
+whose cdr is a list of imports.  An import is either a bare symbol or a
+pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are
+both symbols and denote the name under which a binding is exported from
+the module, and the name under which to make the binding available,
+respectively."
+  (let ((m (make-fresh-user-module)))
+    (purify-module! m)
+    (module-use-interfaces! m
+                            (map (match-lambda
+                                   ((mod-name . bindings)
+                                    (resolve-interface mod-name
+                                                       #:select bindings)))
+                                 bindings))
+    m))
+
+(define* (eval-in-sandbox exp #:key
+                          (time-limit 0.1)
+                          (allocation-limit #e10e6)
+                          (bindings all-pure-bindings)
+                          (module (make-sandbox-module bindings))
+                          (sever-module? #t))
+  "Evaluate the Scheme expression @var{exp} within an isolated
+\"sandbox\".  Limit its execution to @var{time-limit} seconds of
+wall-clock time, and limit its allocation to @var{allocation-limit}
+bytes.
+
+The evaluation will occur in @var{module}, which defaults to the result
+of calling @code{make-sandbox-module} on @var{bindings}, which itself
+defaults to @code{all-pure-bindings}.  This is the core of the
+sandbox: creating a scope for the expression that is @dfn{safe}.
+
+A safe sandbox module has two characteristics.  Firstly, it will not
+allow the expression being evaluated to avoid being cancelled due to
+time or allocation limits.  This ensures that the expression terminates
+in a timely fashion.
+
+Secondly, a safe sandbox module will prevent the evaluation from
+receiving information from previous evaluations, or from affecting
+future evaluations.  All combinations of binding sets exported by
+@code{(ice-9 sandbox)} form safe sandbox modules.
+
+The @var{bindings} should be given as a list of import sets.  One import
+set is a list whose car names an interface, like @code{(ice-9 q)}, and
+whose cdr is a list of imports.  An import is either a bare symbol or a
+pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are
+both symbols and denote the name under which a binding is exported from
+the module, and the name under which to make the binding available,
+respectively.  Note that @var{bindings} is only used as an input to the
+default initializer for the @var{module} argument; if you pass
+@code{#:module}, @var{bindings} is unused.  If @var{sever-module?} is
+true (the default), the module will be unlinked from the global module
+tree after the evaluation returns, to allow @var{mod} to be
+garbage-collected.
+
+If successful, return all values produced by @var{exp}.  Any uncaught
+exception thrown by the expression will propagate out.  If the time or
+allocation limit is exceeded, an exception will be thrown to the
+@code{limit-exceeded} key."
+  (dynamic-wind
+    (lambda () #t)
+    (lambda ()
+      (call-with-time-and-allocation-limits
+       time-limit allocation-limit
+       (lambda ()
+         ;; Prevent the expression from forging syntax objects.  See "Syntax
+         ;; Transformer Helpers" in the manual.
+         (parameterize ((allow-legacy-syntax-objects? #f))
+           (eval exp module)))))
+    (lambda () (when sever-module? (sever-module! module)))))
+
+
+;; An evaluation-sandboxing facility is safe if:
+;;
+;;  (1) every evaluation will terminate in a timely manner
+;;
+;;  (2) no evaluation can affect future evaluations
+;;
+;; For (1), we impose a user-controllable time limit on the evaluation,
+;; in wall-clock time.  When that limit is reached, Guile schedules an
+;; asynchronous interrupt in the sandbox that aborts the computation.
+;; For this to work, the sandboxed evaluation must not disable
+;; interrupts, and it must not prevent timely aborts via malicious "out"
+;; guards in dynamic-wind thunks.
+;;
+;; The sandbox also has an allocation limit that uses a similar cancel
+;; mechanism, but this limit is less precise as it only runs at
+;; garbage-collection time.
+;;
+;; The sandbox sets the allocation limit as the stack limit as well.
+;;
+;; For (2), the only way an evaluation can affect future evaluations is
+;; if it causes a side-effect outside its sandbox.  That side effect
+;; could change the way the host or future sandboxed evaluations
+;; operate, or it could leak information to future evaluations.
+;;
+;; One means of information leakage would be the file system.  Although
+;; one can imagine "safe" ways to access a file system, in practice we
+;; just prevent all access to this and other operating system facilities
+;; by not exposing the Guile primitives that access the file system,
+;; connect to networking hosts, etc.  If we chose our set of bindings
+;; correctly and it is impossible to access host values other than those
+;; given to the evaluation, then we have succeeded in granting only a
+;; limited set of capabilities to the guest.
+;;
+;; To prevent information leakage we also limit other information about
+;; the host, like its hostname or the Guile build information.
+;;
+;; The guest must also not have the capability to mutate a location used
+;; by the host or by future sandboxed evaluations.  Either you expose no
+;; primitives to the evaluation that can mutate locations, or you expose
+;; no mutable locations.  In this sandbox we opt for a combination of
+;; the two, though the selection of bindings is up to the user.  "set!"
+;; is always excluded, as Guile doesn't have a nice way to prevent set!
+;; on imported bindings.  But variable-set! is included, as no set of
+;; bindings from this module includes a variable or a capability to a
+;; variable.  It's possible though to build sandbox modules with no
+;; mutating primitives.  As far as we know, all possible combinations of
+;; the binding sets listed below are safe.
+;;
+(define core-bindings
+  '(((guile)
+     and
+     begin
+     apply
+     call-with-values
+     values
+     case
+     case-lambda
+     case-lambda*
+     cond
+     define
+     define*
+     define-values
+     do
+     if
+     lambda
+     lambda*
+     let
+     let*
+     letrec
+     letrec*
+     or
+     quasiquote
+     quote
+     ;; Can't allow mutation to globals.
+     ;; set!
+     unless
+     unquote
+     unquote-splicing
+     when
+     while
+     λ)))
+
+(define macro-bindings
+  '(((guile)
+     bound-identifier=?
+     ;; Although these have "current" in their name, they are lexically
+     ;; scoped, not dynamically scoped.
+     current-filename
+     current-source-location
+     datum->syntax
+     define-macro
+     define-syntax
+     define-syntax-parameter
+     define-syntax-rule
+     defmacro
+     free-identifier=?
+     generate-temporaries
+     gensym
+     identifier-syntax
+     identifier?
+     let-syntax
+     letrec-syntax
+     macroexpand
+     macroexpanded?
+     quasisyntax
+     start-stack
+     syntax
+     syntax->datum
+     syntax-case
+     syntax-error
+     syntax-parameterize
+     syntax-rules
+     syntax-source
+     syntax-violation
+     unsyntax
+     unsyntax-splicing
+     with-ellipsis
+     with-syntax
+     make-variable-transformer)))
+
+(define iteration-bindings
+  '(((guile)
+     compose
+     for-each
+     identity
+     iota
+     map
+     map-in-order
+     const
+     noop)))
+
+(define clock-bindings
+  '(((guile)
+     get-internal-real-time
+     internal-time-units-per-second
+     sleep
+     usleep)))
+
+(define procedure-bindings
+  '(((guile)
+     procedure-documentation
+     procedure-minimum-arity
+     procedure-name
+     procedure?
+     thunk?)))
+
+(define version-bindings
+  '(((guile)
+     effective-version
+     major-version
+     micro-version
+     minor-version
+     version
+     version-matches?)))
+
+(define nil-bindings
+  '(((guile)
+     nil?)))
+
+(define unspecified-bindings
+  '(((guile)
+     unspecified?
+     *unspecified*)))
+
+(define predicate-bindings
+  '(((guile)
+     ->bool
+     and-map
+     and=>
+     boolean?
+     eq?
+     equal?
+     eqv?
+     negate
+     not
+     or-map)))
+
+;; The current ports (current-input-port et al) are dynamically scoped,
+;; which is a footgun from a sandboxing perspective.  It's too easy for
+;; a procedure that is the result of a sandboxed evaluation to be later
+;; invoked in a different context and thereby be implicitly granted
+;; capabilities to whatever port is then current.  This is compounded by
+;; the fact that most Scheme i/o primitives allow the port to be omitted
+;; and thereby default to whatever's current.  For now, sadly, we avoid
+;; exposing any i/o primitive to the sandbox.
+#;
+(define i/o-bindings
+  '(((guile)
+     display
+     eof-object?
+     force-output
+     format
+     make-soft-port
+     newline
+     read
+     simple-format
+     write
+     write-char)
+    ((ice-9 ports)
+     %make-void-port
+     char-ready?
+     ;; Note that these are mutable parameters.
+     current-error-port
+     current-input-port
+     current-output-port
+     current-warning-port
+     drain-input
+     eof-object?
+     file-position
+     force-output
+     ftell
+     input-port?
+     output-port?
+     peek-char
+     port-closed?
+     port-column
+     port-conversion-strategy
+     port-encoding
+     port-filename
+     port-line
+     port-mode
+     port?
+     read-char
+     the-eof-object
+     ;; We don't provide open-output-string because it needs
+     ;; get-output-string, and get-output-string provides a generic
+     ;; capability on any output string port.  For consistency then we
+     ;; don't provide open-input-string either; call-with-input-string
+     ;; is sufficient.
+     call-with-input-string
+     call-with-output-string
+     with-error-to-port
+     with-error-to-string
+     with-input-from-port
+     with-input-from-string
+     with-output-to-port
+     with-output-to-string)))
+
+;; If two evaluations are called with the same input port, unread-char
+;; and unread-string can use a port as a mutable channel to pass
+;; information from one to the other.
+#;
+(define mutating-i/o-bindings
+  '(((guile)
+     set-port-encoding!)
+    ((ice-9 ports)
+     close-input-port
+     close-output-port
+     close-port
+     file-set-position
+     seek
+     set-port-column!
+     set-port-conversion-strategy!
+     set-port-encoding!
+     set-port-filename!
+     set-port-line!
+     setvbuf
+     unread-char
+     unread-string)))
+
+(define error-bindings
+  '(((guile)
+     error
+     throw
+     with-throw-handler
+     catch
+     ;; false-if-exception can cause i/o if the #:warning arg is passed.
+     ;; false-if-exception
+
+     ;; See notes on i/o-bindings.
+     ;; peek
+     ;; pk
+     ;; print-exception
+     ;; warn
+     strerror
+     scm-error
+     )))
+
+;; FIXME: Currently we can't expose anything that works on the current
+;; module to the sandbox.  It could be that the sandboxed evaluation
+;; returns a procedure, and that procedure may later be invoked in a
+;; different context with a different current-module and it is unlikely
+;; that the later caller will consider themselves as granting a
+;; capability on whatever module is then current.  Likewise export (and
+;; by extension, define-public and the like) also operate on the current
+;; module.
+;;
+;; It could be that we could expose a statically scoped eval to the
+;; sandbox.
+#;
+(define eval-bindings
+  '(((guile)
+     current-module
+     module-name
+     module?
+     define-once
+     define-private
+     define-public
+     defined?
+     export
+     defmacro-public
+     ;; FIXME: single-arg eval?
+     eval
+     primitive-eval
+     eval-string
+     self-evaluating?
+     ;; Can we?
+     set-current-module)))
+
+(define sort-bindings
+  '(((guile)
+     sort
+     sorted?
+     stable-sort
+     sort-list)))
+
+;; These can only form part of a safe binding set if no mutable pair or
+;; vector is exposed to the sandbox.
+(define mutating-sort-bindings
+  '(((guile)
+     sort!
+     stable-sort!
+     sort-list!
+     restricted-vector-sort!)))
+
+(define regexp-bindings
+  '(((guile)
+     make-regexp
+     regexp-exec
+     regexp/basic
+     regexp/extended
+     regexp/icase
+     regexp/newline
+     regexp/notbol
+     regexp/noteol
+     regexp?)))
+
+(define alist-bindings
+  '(((guile)
+     acons
+     assoc
+     assoc-ref
+     assq
+     assq-ref
+     assv
+     assv-ref
+     sloppy-assoc
+     sloppy-assq
+     sloppy-assv)))
+
+;; These can only form part of a safe binding set if no mutable pair
+;; is exposed to the sandbox.  Unfortunately all charsets in Guile are
+;; mutable, currently, including the built-in charsets, so we can't
+;; expose these primitives.
+(define mutating-alist-bindings
+  '(((guile)
+     assoc-remove!
+     assoc-set!
+     assq-remove!
+     assq-set!
+     assv-remove!
+     assv-set!)))
+
+(define number-bindings
+  '(((guile)
+     *
+     +
+     -
+     /
+     1+
+     1-
+     <
+     <=
+     =
+     >
+     >=
+     abs
+     acos
+     acosh
+     angle
+     asin
+     asinh
+     atan
+     atanh
+     ceiling
+     ceiling-quotient
+     ceiling-remainder
+     ceiling/
+     centered-quotient
+     centered-remainder
+     centered/
+     complex?
+     cos
+     cosh
+     denominator
+     euclidean-quotient
+     euclidean-remainder
+     euclidean/
+     even?
+     exact->inexact
+     exact-integer-sqrt
+     exact-integer?
+     exact?
+     exp
+     expt
+     finite?
+     floor
+     floor-quotient
+     floor-remainder
+     floor/
+     gcd
+     imag-part
+     inf
+     inf?
+     integer-expt
+     integer-length
+     integer?
+     lcm
+     log
+     log10
+     magnitude
+     make-polar
+     make-rectangular
+     max
+     min
+     modulo
+     modulo-expt
+     most-negative-fixnum
+     most-positive-fixnum
+     nan
+     nan?
+     negative?
+     numerator
+     odd?
+     positive?
+     quotient
+     rational?
+     rationalize
+     real-part
+     real?
+     remainder
+     round
+     round-quotient
+     round-remainder
+     round/
+     sin
+     sinh
+     sqrt
+     tan
+     tanh
+     truncate
+     truncate-quotient
+     truncate-remainder
+     truncate/
+     zero?
+     number?
+     number->string
+     string->number)))
+
+(define char-set-bindings
+  '(((guile)
+     ->char-set
+     char-set
+     char-set->list
+     char-set->string
+     char-set-adjoin
+     char-set-any
+     char-set-complement
+     char-set-contains?
+     char-set-copy
+     char-set-count
+     char-set-cursor
+     char-set-cursor-next
+     char-set-delete
+     char-set-diff+intersection
+     char-set-difference
+     char-set-every
+     char-set-filter
+     char-set-fold
+     char-set-for-each
+     char-set-hash
+     char-set-intersection
+     char-set-map
+     char-set-ref
+     char-set-size
+     char-set-unfold
+     char-set-union
+     char-set-xor
+     char-set:ascii
+     char-set:blank
+     char-set:designated
+     char-set:digit
+     char-set:empty
+     char-set:full
+     char-set:graphic
+     char-set:hex-digit
+     char-set:iso-control
+     char-set:letter
+     char-set:letter+digit
+     char-set:lower-case
+     char-set:printing
+     char-set:punctuation
+     char-set:symbol
+     char-set:title-case
+     char-set:upper-case
+     char-set:whitespace
+     char-set<=
+     char-set=
+     char-set?
+     end-of-char-set?
+     list->char-set
+     string->char-set
+     ucs-range->char-set)))
+
+;; These can only form part of a safe binding set if no mutable char-set
+;; is exposed to the sandbox.  Unfortunately all charsets in Guile are
+;; mutable, currently, including the built-in charsets, so we can't
+;; expose these primitives.
+#;
+(define mutating-char-set-bindings
+  '(((guile)
+     char-set-adjoin!
+     char-set-complement!
+     char-set-delete!
+     char-set-diff+intersection!
+     char-set-difference!
+     char-set-filter!
+     char-set-intersection!
+     char-set-unfold!
+     char-set-union!
+     char-set-xor!
+     list->char-set!
+     string->char-set!
+     ucs-range->char-set!)))
+
+(define array-bindings
+  '(((guile)
+     array->list
+     array-cell-ref
+     array-contents
+     array-dimensions
+     array-equal?
+     array-for-each
+     array-in-bounds?
+     array-length
+     array-rank
+     array-ref
+     array-shape
+     array-slice
+     array-slice-for-each
+     array-slice-for-each-in-order
+     array-type
+     array-type-code
+     array?
+     list->array
+     list->typed-array
+     make-array
+     make-shared-array
+     make-typed-array
+     shared-array-increments
+     shared-array-offset
+     shared-array-root
+     transpose-array
+     typed-array?)))
+
+;; These can only form part of a safe binding set if no mutable vector,
+;; bitvector, bytevector, srfi-4 vector, or array is exposed to the
+;; sandbox.
+(define mutating-array-bindings
+  '(((guile)
+     array-cell-set!
+     array-copy!
+     array-copy-in-order!
+     array-fill!
+     array-index-map!
+     array-map!
+     array-map-in-order!
+     array-set!)))
+
+(define hash-bindings
+  '(((guile)
+     doubly-weak-hash-table?
+     hash
+     hash-count
+     hash-fold
+     hash-for-each
+     hash-for-each-handle
+     hash-get-handle
+     hash-map->list
+     hash-ref
+     hash-table?
+     hashq
+     hashq-get-handle
+     hashq-ref
+     hashv
+     hashv-get-handle
+     hashv-ref
+     hashx-get-handle
+     hashx-ref
+     make-doubly-weak-hash-table
+     make-hash-table
+     make-weak-key-hash-table
+     make-weak-value-hash-table
+     weak-key-hash-table?
+     weak-value-hash-table?)))
+
+;; These can only form part of a safe binding set if no hash table is
+;; exposed to the sandbox.
+(define mutating-hash-bindings
+  '(((guile)
+     hash-clear!
+     hash-create-handle!
+     hash-remove!
+     hash-set!
+     hashq-create-handle!
+     hashq-remove!
+     hashq-set!
+     hashv-create-handle!
+     hashv-remove!
+     hashv-set!
+     hashx-create-handle!
+     hashx-remove!
+     hashx-set!)))
+
+(define variable-bindings
+  '(((guile)
+     make-undefined-variable
+     make-variable
+     variable-bound?
+     variable-ref
+     variable?)))
+
+;; These can only form part of a safe binding set if no mutable variable
+;; is exposed to the sandbox; this applies particularly to variables
+;; that are module bindings.
+(define mutating-variable-bindings
+  '(((guile)
+     variable-set!
+     variable-unset!)))
+
+(define string-bindings
+  '(((guile)
+     absolute-file-name?
+     file-name-separator-string
+     file-name-separator?
+     in-vicinity
+     basename
+     dirname
+
+     list->string
+     make-string
+     object->string
+     reverse-list->string
+     string
+     string->list
+     string-any
+     string-any-c-code
+     string-append
+     string-append/shared
+     string-capitalize
+     string-ci<
+     string-ci<=
+     string-ci<=?
+     string-ci<>
+     string-ci<?
+     string-ci=
+     string-ci=?
+     string-ci>
+     string-ci>=
+     string-ci>=?
+     string-ci>?
+     string-compare
+     string-compare-ci
+     string-concatenate
+     string-concatenate-reverse
+     string-concatenate-reverse/shared
+     string-concatenate/shared
+     string-contains
+     string-contains-ci
+     string-copy
+     string-count
+     string-delete
+     string-downcase
+     string-drop
+     string-drop-right
+     string-every
+     string-every-c-code
+     string-filter
+     string-fold
+     string-fold-right
+     string-for-each
+     string-for-each-index
+     string-hash
+     string-hash-ci
+     string-index
+     string-index-right
+     string-join
+     string-length
+     string-map
+     string-normalize-nfc
+     string-normalize-nfd
+     string-normalize-nfkc
+     string-normalize-nfkd
+     string-null?
+     string-pad
+     string-pad-right
+     string-prefix-ci?
+     string-prefix-length
+     string-prefix-length-ci
+     string-prefix?
+     string-ref
+     string-replace
+     string-reverse
+     string-rindex
+     string-skip
+     string-skip-right
+     string-split
+     string-suffix-ci?
+     string-suffix-length
+     string-suffix-length-ci
+     string-suffix?
+     string-tabulate
+     string-take
+     string-take-right
+     string-titlecase
+     string-tokenize
+     string-trim
+     string-trim-both
+     string-trim-right
+     string-unfold
+     string-unfold-right
+     string-upcase
+     string-utf8-length
+     string<
+     string<=
+     string<=?
+     string<>
+     string<?
+     string=
+     string=?
+     string>
+     string>=
+     string>=?
+     string>?
+     string?
+     substring
+     substring/copy
+     substring/read-only
+     substring/shared
+     xsubstring)))
+
+;; These can only form part of a safe binding set if no mutable string
+;; is exposed to the sandbox.
+(define mutating-string-bindings
+  '(((guile)
+     string-capitalize!
+     string-copy!
+     string-downcase!
+     string-fill!
+     string-map!
+     string-reverse!
+     string-set!
+     string-titlecase!
+     string-upcase!
+     string-xcopy!
+     substring-fill!
+     substring-move!)))
+
+(define symbol-bindings
+  '(((guile)
+     string->symbol
+     string-ci->symbol
+     symbol->string
+     list->symbol
+     make-symbol
+     symbol
+     symbol-append
+     symbol-hash
+     symbol-interned?
+     symbol?)))
+
+(define keyword-bindings
+  '(((guile)
+     keyword?
+     keyword->symbol
+     symbol->keyword)))
+
+;; These can only form part of a safe binding set if no valid prompt tag
+;; is ever exposed to the sandbox, or can be constructed by the sandbox.
+(define prompt-bindings
+  '(((guile)
+     abort-to-prompt
+     abort-to-prompt*
+     call-with-prompt
+     make-prompt-tag)))
+
+(define bit-bindings
+  '(((guile)
+     ash
+     round-ash
+     logand
+     logcount
+     logior
+     lognot
+     logtest
+     logxor
+     logbit?)))
+
+(define bitvector-bindings
+  '(((guile)
+     bit-count
+     bit-count*
+     bit-extract
+     bit-position
+     bitvector
+     bitvector->list
+     bitvector-length
+     bitvector-ref
+     bitvector?
+     list->bitvector
+     make-bitvector)))
+
+;; These can only form part of a safe binding set if no mutable
+;; bitvector is exposed to the sandbox.
+(define mutating-bitvector-bindings
+  '(((guile)
+     bit-invert!
+     bit-set*!
+     bitvector-fill!
+     bitvector-set!)))
+
+(define fluid-bindings
+  '(((guile)
+     fluid-bound?
+     fluid-ref
+     ;; fluid-ref* could escape the sandbox and is not allowed.
+     fluid-thread-local?
+     fluid?
+     make-fluid
+     make-thread-local-fluid
+     make-unbound-fluid
+     with-fluid*
+     with-fluids
+     with-fluids*
+     make-parameter
+     parameter?
+     parameterize)))
+
+;; These can only form part of a safe binding set if no fluid is
+;; directly exposed to the sandbox.
+(define mutating-fluid-bindings
+  '(((guile)
+     fluid-set!
+     fluid-unset!
+     fluid->parameter)))
+
+(define char-bindings
+  '(((guile)
+     char-alphabetic?
+     char-ci<=?
+     char-ci<?
+     char-ci=?
+     char-ci>=?
+     char-ci>?
+     char-downcase
+     char-general-category
+     char-is-both?
+     char-lower-case?
+     char-numeric?
+     char-titlecase
+     char-upcase
+     char-upper-case?
+     char-whitespace?
+     char<=?
+     char<?
+     char=?
+     char>=?
+     char>?
+     char?
+     char->integer
+     integer->char)))
+
+(define list-bindings
+  '(((guile)
+     list
+     list-cdr-ref
+     list-copy
+     list-head
+     list-index
+     list-ref
+     list-tail
+     list?
+     null?
+     make-list
+     append
+     delete
+     delq
+     delv
+     filter
+     length
+     member
+     memq
+     memv
+     merge
+     reverse)))
+
+;; These can only form part of a safe binding set if no mutable
+;; pair is exposed to the sandbox.
+(define mutating-list-bindings
+  '(((guile)
+     list-cdr-set!
+     list-set!
+     append!
+     delete!
+     delete1!
+     delq!
+     delq1!
+     delv!
+     delv1!
+     filter!
+     merge!
+     reverse!)))
+
+(define pair-bindings
+  '(((guile)
+     last-pair
+     pair?
+     caaaar
+     caaadr
+     caaar
+     caadar
+     caaddr
+     caadr
+     caar
+     cadaar
+     cadadr
+     cadar
+     caddar
+     cadddr
+     caddr
+     cadr
+     car
+     cdaaar
+     cdaadr
+     cdaar
+     cdadar
+     cdaddr
+     cdadr
+     cdar
+     cddaar
+     cddadr
+     cddar
+     cdddar
+     cddddr
+     cdddr
+     cddr
+     cdr
+     cons
+     cons*)))
+
+;; These can only form part of a safe binding set if no mutable
+;; pair is exposed to the sandbox.
+(define mutating-pair-bindings
+  '(((guile)
+     set-car!
+     set-cdr!)))
+
+(define vector-bindings
+  '(((guile)
+     list->vector
+     make-vector
+     vector
+     vector->list
+     vector-copy
+     vector-length
+     vector-ref
+     vector?)))
+
+;; These can only form part of a safe binding set if no mutable
+;; vector is exposed to the sandbox.
+(define mutating-vector-bindings
+  '(((guile)
+     vector-fill!
+     vector-move-left!
+     vector-move-right!
+     vector-set!)))
+
+(define promise-bindings
+  '(((guile)
+     force
+     delay
+     make-promise
+     promise?)))
+
+(define srfi-4-bindings
+  '(((srfi srfi-4)
+     f32vector
+     f32vector->list
+     f32vector-length
+     f32vector-ref
+     f32vector?
+     f64vector
+     f64vector->list
+     f64vector-length
+     f64vector-ref
+     f64vector?
+     list->f32vector
+     list->f64vector
+     list->s16vector
+     list->s32vector
+     list->s64vector
+     list->s8vector
+     list->u16vector
+     list->u32vector
+     list->u64vector
+     list->u8vector
+     make-f32vector
+     make-f64vector
+     make-s16vector
+     make-s32vector
+     make-s64vector
+     make-s8vector
+     make-u16vector
+     make-u32vector
+     make-u64vector
+     make-u8vector
+     s16vector
+     s16vector->list
+     s16vector-length
+     s16vector-ref
+     s16vector?
+     s32vector
+     s32vector->list
+     s32vector-length
+     s32vector-ref
+     s32vector?
+     s64vector
+     s64vector->list
+     s64vector-length
+     s64vector-ref
+     s64vector?
+     s8vector
+     s8vector->list
+     s8vector-length
+     s8vector-ref
+     s8vector?
+     u16vector
+     u16vector->list
+     u16vector-length
+     u16vector-ref
+     u16vector?
+     u32vector
+     u32vector->list
+     u32vector-length
+     u32vector-ref
+     u32vector?
+     u64vector
+     u64vector->list
+     u64vector-length
+     u64vector-ref
+     u64vector?
+     u8vector
+     u8vector->list
+     u8vector-length
+     u8vector-ref
+     u8vector?)))
+
+;; These can only form part of a safe binding set if no mutable
+;; bytevector is exposed to the sandbox.
+(define mutating-srfi-4-bindings
+  '(((srfi srfi-4)
+     f32vector-set!
+     f64vector-set!
+     s16vector-set!
+     s32vector-set!
+     s64vector-set!
+     s8vector-set!
+     u16vector-set!
+     u32vector-set!
+     u64vector-set!
+     u8vector-set!)))
+
+(define all-pure-bindings
+  (append alist-bindings
+          array-bindings
+          bit-bindings
+          bitvector-bindings
+          char-bindings
+          char-set-bindings
+          clock-bindings
+          core-bindings
+          error-bindings
+          fluid-bindings
+          hash-bindings
+          iteration-bindings
+          keyword-bindings
+          list-bindings
+          macro-bindings
+          nil-bindings
+          number-bindings
+          pair-bindings
+          predicate-bindings
+          procedure-bindings
+          promise-bindings
+          prompt-bindings
+          regexp-bindings
+          sort-bindings
+          srfi-4-bindings
+          string-bindings
+          symbol-bindings
+          unspecified-bindings
+          variable-bindings
+          vector-bindings
+          version-bindings))
+
+
+(define all-pure-and-impure-bindings
+  (append all-pure-bindings
+          mutating-alist-bindings
+          mutating-array-bindings
+          mutating-bitvector-bindings
+          mutating-fluid-bindings
+          mutating-hash-bindings
+          mutating-list-bindings
+          mutating-pair-bindings
+          mutating-sort-bindings
+          mutating-srfi-4-bindings
+          mutating-string-bindings
+          mutating-variable-bindings
+          mutating-vector-bindings))