summaryrefslogtreecommitdiffstats
path: root/disarm.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commitdb04688faa20f3576257c0fe41752ec435beab9a (patch)
tree6d638c2e1f65afd5f49d20b2d22ce35bd74705ff /disarm.scm
parent1edcb9b62a1a520eddae8403c19d841c9b18737f (diff)
downloadscm-db04688faa20f3576257c0fe41752ec435beab9a.tar.gz
scm-db04688faa20f3576257c0fe41752ec435beab9a.zip
Import Upstream version 5c3upstream/5c3
Diffstat (limited to 'disarm.scm')
-rw-r--r--disarm.scm159
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)