diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | db04688faa20f3576257c0fe41752ec435beab9a (patch) | |
tree | 6d638c2e1f65afd5f49d20b2d22ce35bd74705ff /disarm.scm | |
parent | 1edcb9b62a1a520eddae8403c19d841c9b18737f (diff) | |
download | scm-db04688faa20f3576257c0fe41752ec435beab9a.tar.gz scm-db04688faa20f3576257c0fe41752ec435beab9a.zip |
Import Upstream version 5c3upstream/5c3
Diffstat (limited to 'disarm.scm')
-rw-r--r-- | disarm.scm | 159 |
1 files changed, 159 insertions, 0 deletions
diff --git a/disarm.scm b/disarm.scm new file mode 100644 index 0000000..d77ac2b --- /dev/null +++ b/disarm.scm @@ -0,0 +1,159 @@ +;; Copyright (C) 1998 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;;; "disarm.scm", Make SCM safe for client-server applications. +;;; Author: Aubrey Jaffer. + +(define (disarm name) + (lambda args + ;;(if (memq? name *features*) (set! *features* (remove name *features))) + (error name 'disabled))) + +(define abort quit) +(define restart (disarm 'restart)) +(define ed (disarm 'ed)) +#+vms +(define vms-debug (disarm 'vms-debug)) + +;; opening files +(define open-file (disarm 'open-file)) +(define transcript-on (disarm 'transcript-on)) + +#+i/o-extensions +(begin + (define system (disarm 'system)) + (define execvp (disarm 'exec)) + (define execv execvp) + (define execlp execvp) + (define execl execvp) + (define putenv (disarm 'putenv)) + (define stat (disarm 'stat)) + (define reopen-file (disarm 'reopen-file)) + (define duplicate-port (disarm 'duplicate-port)) + (define redirect-port! (disarm 'redirect-port!)) + (define opendir (disarm 'opendir)) + (define mkdir (disarm 'mkdir)) + (define rmdir (disarm 'rmdir)) + (define chdir (disarm 'chdir)) + (define rename-file (disarm 'rename-file)) + (define chmod (disarm 'chmod)) + (define utime (disarm 'utime)) + (define umask (disarm 'umask)) + (define fileno (disarm 'fileno)) + (define access (disarm 'access)) + ) +#+posix +(begin + (define open-pipe (disarm 'open-pipe)) + (define fork (disarm 'fork)) + (define setuid (disarm 'setuid)) + (define setgid (disarm 'setgid)) + (define seteuid (disarm 'seteuid)) + (define setegid (disarm 'setegid)) + (define kill (disarm 'kill)) + (define waitpid (disarm 'waitpid)) + (define uname (disarm 'uname)) + (define getpw (disarm 'getpw)) + (define getgr (disarm 'getgr)) + (define getgroups (disarm 'getgroups)) + (define link (disarm 'link)) + (define chown (disarm 'chown)) + ) +;;#+unix +;;(begin +;; (define symlink (disarm 'symlink)) +;; (define readlink (disarm 'readlink)) +;; (define lstat (disarm 'lstat)) +;; (define nice (disarm 'nice)) +;; (define acct (disarm 'acct)) +;; (define mknod (disarm 'mknod)) +;; ) + +#+edit-line +(error 'edit-line 'inappropriate-for-server) +#+curses +(error 'curses 'inappropriate-for-server) +#+turtle-graphics +(error 'turtle-graphics 'inappropriate-for-server) + +;;#+socket +;;(begin +;; (define make-stream-socket (disarm 'make-stream-socket)) +;; (define make-stream-socketpair (disarm 'make-stream-socketpair)) +;; (define socket:connect (disarm 'socket:connect)) +;; (define socket:bind (disarm 'socket:bind)) +;; (define socket:listen (disarm 'socket:listen)) +;; (define socket:accept (disarm 'socket:accept)) +;; ) + +;; load +(define load (disarm 'load)) +(define try-load load) +(define scm:load load) +(define scm:load-source load) +(define link:link (disarm 'link:link)) + +;; SLIB loads +(define base:load load) +(define slib:load load) +(define slib:load-compiled load) +(define slib:load-source load) +(define defmacro:load load) +(define macro:load load) +;;(define macwork:load load) +;;(define syncase:load load) +;;(define synclo:load load) + +;;;; eval +;;(define eval (disarm 'eval)) +;;(define eval-string eval) +;;(define interaction-environment (disarm 'interaction-environment)) +;;(define scheme-report-environment (disarm 'scheme-report-environment)) + +;;;; SLIB evals +;;(define base:eval eval) +;;(define slib:eval eval) +;;(define defmacro:eval eval) +;;(define macro:eval eval) +;;(define macwork:eval eval) +;;(define repl:eval eval) +;;(define syncase:eval eval) +;;(define syncase:eval-hook eval) +;;(define synclo:eval eval) |