59 lines
2.3 KiB
Scheme
59 lines
2.3 KiB
Scheme
|
;;; -*- Scheme -*-
|
||
|
|
;;; This file defines a Scheme 48 module that is R4RS without features that
|
||
|
|
;;; could examine or effect the file system. You can also use it
|
||
|
|
;;; as a model of how to execute code in other protected environments
|
||
|
|
;;; in S48.
|
||
|
|
;;;
|
||
|
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||
|
|
|
||
|
|
(define-structure loser-package (export loser)
|
||
|
|
(open scheme error-package)
|
||
|
|
(begin (define (loser name)
|
||
|
|
(lambda x (error "Illegal call" name)))))
|
||
|
|
|
||
|
|
;;; The toothless structure is R4RS without the dangerous procedures.
|
||
|
|
|
||
|
|
(define-structure toothless (interface-of scheme)
|
||
|
|
(open scheme loser-package)
|
||
|
|
(begin
|
||
|
|
(define call-with-input-file (loser "call-with-input-file"))
|
||
|
|
(define call-with-output-file (loser "call-with-output-file"))
|
||
|
|
(define load (loser "load"))
|
||
|
|
(define open-input-file (loser "open-input-file"))
|
||
|
|
(define open-output-file (loser "open-output-file"))
|
||
|
|
(define transcript-on (loser "transcript-on"))
|
||
|
|
(define with-input-from-file (loser "with-input-from-file"))
|
||
|
|
(define with-input-to-file (loser "with-input-to-file"))
|
||
|
|
(define eval (loser "eval"))
|
||
|
|
(define interaction-environment (loser "interaction-environment"))
|
||
|
|
(define scheme-report-environment (loser "scheme-report-environment"))))
|
||
|
|
|
||
|
|
;;; (EVAL-SAFELEY exp)
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Create a brand new package, import the TOOTHLESS structure, and
|
||
|
|
;;; evaluate EXP in it. When the evaluation is done, you throw away
|
||
|
|
;;; the environment, so EXP's side-effects don't persist from one
|
||
|
|
;;; EVAL-SAFELY call to the next. If EXP raises an error exception,
|
||
|
|
;;; we abort and return #f.
|
||
|
|
|
||
|
|
(define-structure toothless-eval (export eval-safely)
|
||
|
|
(open evaluation ; eval
|
||
|
|
package-commands-internal ; config-package, get-reflective-tower
|
||
|
|
packages ; structure-package, make-simple-package
|
||
|
|
environments ; environment-ref
|
||
|
|
handle ; ignore-errors
|
||
|
|
scheme)
|
||
|
|
(access toothless) ; Force it to be loaded.
|
||
|
|
(begin
|
||
|
|
|
||
|
|
(define toothless-struct (environment-ref (config-package) 'toothless))
|
||
|
|
(define toothless-package (structure-package toothless-struct))
|
||
|
|
|
||
|
|
(define (new-safe-package)
|
||
|
|
(make-simple-package (list toothless-struct) #t
|
||
|
|
(get-reflective-tower toothless-package) ; ???
|
||
|
|
'safe-env))
|
||
|
|
|
||
|
|
(define (eval-safely exp)
|
||
|
|
(ignore-errors (lambda () (eval exp (new-safe-package)))))))
|