psdir = @psdir@
INST_TARGETS = @INST_TARGETS@
-SUBDIRS = ffi gtk imail ref-manual sos user-manual
+SUBDIRS = ffi imail ref-manual sos user-manual
DISTCLEAN_FILES = Makefile make-common config.log config.status
all:
Makefile
make-common
ffi/Makefile
- gtk/Makefile
imail/Makefile
ref-manual/Makefile
sos/Makefile
+++ /dev/null
-# doc/gtk/Makefile.in
-
-@SET_MAKE@
-srcdir = @srcdir@
-top_srcdir = @top_srcdir@
-VPATH = @srcdir@
-
-SOURCES = gtk.texinfo
-TEXINFO_ROOT = gtk
-TARGET_ROOT = mit-scheme-gtk
-
-include $(top_srcdir)/make-common
<li><a href="mit-scheme-sos/index.html">SOS Reference Manual</a></li>
<li><a href="mit-scheme-imail/index.html">IMAIL User's Manual</a></li>
<li><a href="mit-scheme-ffi/index.html">FFI User's Manual</a></li>
-<li><a href="mit-scheme-gtk/index.html">GTK User's Manual</a></li>
</ul>
</body>
makeinfo --html $(TEXINFO_ROOT).texinfo
$(PDF_TARGET): $(SOURCES)
- texi2pdf $(TEX_OPTIONS) --output=$@ $(TEXINFO_ROOT).texinfo
+ texi2dvi --pdf $(TEX_OPTIONS) --output=$@ $(TEXINFO_ROOT).texinfo
$(PS_TARGET): $(SOURCES)
-rm -f $(DVI_TARGET)
to system tasks after the need for a garbage collection is detected and
before the garbage collector is started. (An example of such a system
task is changing the run-light to show ``gc'' when scheme is running
-under Emacs.) @strong{Note well} that you should not specify
+under Emacs.) @strong{Caution:} You should not specify
@var{safety-margin} unless you know what you are doing. If you specify
a value that is too small, you can put Scheme in an unusable state.
@end deffn
LIARC_BOOT_BUNDLES = compiler cref sf star-parser
LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) edwin ffi imail sos ssp xml
-FFIS = @FFIS@
SUBDIRS = $(INSTALLED_SUBDIRS) 6001 rcs win32 xdoc
-INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES) $(FFIS)
+INSTALLED_SUBDIRS = microcode runtime $(LIARC_BUNDLES)
MIT_SCHEME_EXE = @MIT_SCHEME_EXE@
AUXDIR_NAME = @AUXDIR_NAME@
check:
./microcode/scheme --library lib --batch-mode \
--load ../tests/check </dev/null
- @if [ -d ../doc/gtk ]; then \
- echo ./microcode/scheme --load ../doc/gtk/check; \
- ./microcode/scheme --library lib --batch-mode \
- --load ../doc/gtk/check </dev/null; \
- else \
- echo "; Warning: Gtk documentation not checked."; \
- fi
all-native: lib/runtime.com
all-native: lib/all.com
all-native: compile-star-parser
all-native: compile-win32
all-native: compile-xml
-all-native: compile-ffis
lib/runtime.com: compile-runtime
lib/runtime.com: microcode/scheme
compile-xml: compile-star-parser
echo '(compile-dir "xml")' | $(BOOTSTRAP_TOOLCHAIN)
-.PHONY: compile-ffis
-compile-ffis: lib/all.com
-compile-ffis: build-ffis
-
all-svm: microcode/svm1-defns.h
$(MAKE) compile-microcode
@$(top_srcdir)/etc/compile-svm.sh "$(MIT_SCHEME_EXE)"
- $(MAKE) build-bands build-ffis
+ $(MAKE) build-bands
microcode/svm1-defns.h: compiler/machines/svm/svm1-defns.h
@$(top_srcdir)/etc/maybe-update-file.sh \
all-liarc:
@$(top_srcdir)/etc/c-compile.sh "$(MIT_SCHEME_EXE)" --batch-mode
- $(MAKE) compile-liarc-bundles build-bands build-ffis
-
-build-ffis:
- etc/make-in-subdirs.sh build ffi $(FFIS)
+ $(MAKE) compile-liarc-bundles build-bands
macosx-app: stamp_macosx-app
$(INSTALL_DATA) lib/*.com $(DESTDIR)$(AUXDIR)/.
.PHONY: default-target all all-native all-liarc all-svm macosx-app
-.PHONY: compile-microcode build-bands build-ffis
+.PHONY: compile-microcode build-bands
.PHONY: liarc-dist compile-liarc-bundles install-liarc-bundles
.PHONY: mostlyclean clean distclean maintainer-clean c-clean clean-boot-root
.PHONY: tags TAGS subdir-list install install-standard install-auxdir-top
* "edwin" contains our Emacs-like editor written in Scheme.
* "imail" contains an email-reading program for Edwin.
+
+There is one C/Unix FFI wrapper thus far:
+
+* "gdbm" wraps libgdbm, the GNU dbm database routines, and provides a
+ drop-in replacement for the microcode module based package (runtime
+ gdbm).
\f
These are miscellaneous extras:
* "etc" contains miscellaneous files for building the program.
-* "gtk" provides a Schemely interface to GNOME. It features a Scheme
- canvas widget and limited SWAT emulation.
-
* "rcs" is a parser for RCS files. It also contains a program for
generating merged log files, in RCS or ChangeLog format, for
directory trees under RCS or CVS control.
. etc/functions.sh
-INSTALLED_SUBDIRS="cref edwin ffi gtk gtk-screen imail sf sos ssp \
- star-parser xml"
+INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
# lib
maybe_link lib/optiondb.scm ../etc/optiondb.scm
maybe_link lib/runtime ../runtime
maybe_link lib/compiler ../compiler
-maybe_link lib/sos ../sos
maybe_link lib/mit-scheme.h ../microcode/pruxffi.h
maybe_link lib/ffi ../ffi
-maybe_link lib/ffi-test-shim.so ../ffi/ffi-test-shim.so
-maybe_link lib/ffi-test-types.bin ../ffi/ffi-test-types.bin
-maybe_link lib/ffi-test-const.bin ../ffi/ffi-test-const.bin
-maybe_link lib/gtk ../gtk
-maybe_link lib/gtk-screen ../gtk-screen
maybe_link config.sub microcode/config.sub
maybe_link config.guess microcode/config.guess
imail/TAGS,include
\f
ffi/TAGS,include
-\f
-gtk/TAGS,include
-\f
-gtk-screen/TAGS,include
--- /dev/null
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+# Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+all: blowfish-shim.so blowfish-types.bin blowfish-const.bin
+ echo '(load "compile")' | $(EXE)
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install:
+ echo '(install-shim "blowfish")' | $(EXE) -- *.com *.bci *.pkd make.scm
+
+clean:
+ rm -f blowfish-const.scm blowfish-const blowfish-const.c
+ rm -f blowfish-shim.c
+ rm -f blowfish-*.crf blowfish-*.fre blowfish-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f test
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+blowfish-shim.so: blowfish-shim.o blowfish-adapter.o
+ echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS)
+
+blowfish-adapter.o: blowfish-adapter.c blowfish-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+blowfish-shim.o: blowfish-shim.c blowfish-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+blowfish-shim.c blowfish-const.c blowfish-types.bin: \
+ blowfish.cdecl blowfish-shim.h
+ echo '(generate-shim "blowfish" "#include \"blowfish-shim.h\"")' \
+ | $(EXE)
+
+blowfish-const.bin: blowfish-const.scm
+ echo '(sf "blowfish-const")' | $(EXE)
+
+blowfish-const.scm: blowfish-const
+ ./blowfish-const
+
+blowfish-const: blowfish-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+blowfish-const.o: blowfish-const.c blowfish-shim.h
+ $(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+.PHONY: all check install clean distclean maintainer-clean
--- /dev/null
+The blowfish wrapper.
+
+This is a drop-in replacement for the bfish microcode module and
+runtime/blowfish.scm. It is not part of the core build and can be
+built outside the core build tree in the customary way:
+
+ ./configure [--with-openssl=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path. You can override the default
+command name "mit-scheme" (and thus the system library path) by
+setting MIT_SCHEME_EXE.
+
+To load via load-option, install the following in your optiondb.scm:
+
+ (define-load-option 'BLOWFISH
+ (guarded-system-loader '(blowfish) "blowfish"))
+
+You will need to import the bindings you want to use. They are not
+exported to the global environment because they would conflict with
+the exports from (runtime blowfish).
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Adapters for the Blowfish encryption library. */
+#include "blowfish-shim.h"
+
+int
+do_BF_cfb64_encrypt (const unsigned char *in,
+ long istart,
+ unsigned char *out,
+ long ostart,
+ long length,
+ const BF_KEY *schedule,
+ unsigned char *ivec,
+ int num,
+ int enc)
+{
+ BF_cfb64_encrypt(&in[istart], &out[ostart], length,
+ schedule, ivec, &num, enc);
+ return (num);
+}
+
+extern int
+do_BF_ofb64_encrypt (const unsigned char *in,
+ long istart,
+ unsigned char *out,
+ long ostart,
+ long length,
+ const BF_KEY *schedule,
+ unsigned char *ivec,
+ int num)
+{
+ BF_ofb64_encrypt(&in[istart], &out[ostart], length,
+ schedule, ivec, &num);
+ return (num);
+}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the Blowfish wrapper.
+
+(if (not (blowfish-available?))
+ (warn "blowfish wrapper not found")
+ (let ((sample "Some text to encrypt and decrypt."))
+ (call-with-binary-output-file "test"
+ (lambda (output)
+ (call-with-input-string sample
+ (lambda (input)
+ (blowfish-encrypt-port input output "secret"
+ (write-blowfish-file-header output)
+ #t)))))
+ (let ((read-back
+ (call-with-binary-input-file "test"
+ (lambda (input)
+ (call-with-output-string
+ (lambda (output)
+ (blowfish-encrypt-port input output "secret"
+ (read-blowfish-file-header input)
+ #f)))))))
+ (if (not (string=? sample read-back))
+ (error "sample did not decrypt correctly")))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Interface to the Blowfish encryption library */
+
+#include "config.h"
+
+#if defined(HAVE_OPENSSL_BLOWFISH_H)
+# include <openssl/blowfish.h>
+#else
+# ifdef HAVE_BLOWFISH_H
+# include <blowfish.h>
+# endif
+#endif
+
+int
+do_BF_cfb64_encrypt (const unsigned char *in,
+ long istart,
+ unsigned char *out,
+ long ostart,
+ long length,
+ const BF_KEY *schedule,
+ unsigned char *ivec,
+ int num,
+ int enc);
+
+extern int
+do_BF_ofb64_encrypt (const unsigned char *in,
+ long istart,
+ unsigned char *out,
+ long ostart,
+ long length,
+ const BF_KEY *schedule,
+ unsigned char *ivec,
+ int num);
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for blowfish-shim.so.
+\f
+(enum (BF_ENCRYPT)
+ (BF_DECRYPT))
+
+(struct bf_key_st (P (array mumble)))
+
+(typedef BF_KEY
+ (struct bf_key_st))
+
+(extern void BF_set_key
+ (key (* BF_KEY))
+ (len int)
+ (data (* (const uchar))))
+
+(extern void BF_ecb_encrypt
+ (in (* (const uchar)))
+ (out (* uchar))
+ (key (* BF_KEY))
+ (enc int))
+
+(extern void BF_cbc_encrypt
+ (in (* (const uchar)))
+ (out (* uchar))
+ (length long)
+ (schedule (* BF_KEY))
+ (ivec (* uchar))
+ (enc int))
+
+(extern int do_BF_cfb64_encrypt
+ (in (* (const uchar)))
+ (istart long)
+ (out (* uchar))
+ (ostart long)
+ (length long)
+ (schedule (* BF_KEY))
+ (ivec (* uchar))
+ (num int)
+ (enc int))
+
+(extern int do_BF_ofb64_encrypt
+ (in (* (const uchar)))
+ (istart long)
+ (out (* uchar))
+ (ostart long)
+ (length long)
+ (schedule (* BF_KEY))
+ (ivec (* uchar))
+ (num int))
+
+(extern (* (const char)) BF_options)
+
+(extern void BF_encrypt
+ (data (* BF_LONG))
+ (key (* (const BF_KEY))))
+
+(extern void BF_decrypt
+ (data (* BF_LONG))
+ (key (* (const BF_KEY))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(global-definitions runtime/)
+
+(define-package (blowfish)
+ (files "blowfish")
+ (parent ())
+ ;; You'll have to import these from (global-definitions blowfish/).
+ ;; They are currently bound in () by exports from (runtime blowfish).
+ #;(export #f
+ blowfish-available?
+ blowfish-cbc
+ blowfish-cfb64
+ blowfish-ecb
+ blowfish-encrypt-port
+ blowfish-file?
+ blowfish-ofb64
+ blowfish-set-key
+ compute-blowfish-init-vector
+ read-blowfish-file-header
+ write-blowfish-file-header))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Blowfish wrapper
+;;; package: (blowfish)
+
+(declare (usual-integrations))
+\f
+(C-include "blowfish")
+
+(define (blowfish-set-key string)
+ ;; Generate a Blowfish key from STRING.
+ ;; STRING must be 72 bytes or less in length.
+ ;; For text-string keys, use MD5 on the text, and pass the digest here.
+ (guarantee-string string 'blowfish-set-key)
+ (let ((length (string-length string)))
+ (if (> length 72)
+ (error:bad-range-argument string
+ "a string of no more than 72 characters"
+ 'blowfish-set-key))
+ (let ((result (make-string (C-sizeof "BF_KEY"))))
+ (C-call "BF_set_key" result length string)
+ result)))
+
+(define (blowfish-ecb input output key encrypt?)
+ ;; Apply Blowfish in Electronic Code Book mode.
+ ;; INPUT is an 8-byte string.
+ ;; OUTPUT is an 8-byte string.
+ ;; KEY is a Blowfish key.
+ ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F).
+ (guarantee-bfkey key 'BLOWFISH-ECB)
+ (guarantee-8char-arg input 'BLOWFISH-ECB)
+ (guarantee-8char-arg output 'BLOWFISH-ECB)
+ (C-call "BF_ecb_encrypt" input output key (bf-de/encrypt encrypt?)))
+
+(define (blowfish-cbc input output key init-vector encrypt?)
+ ;; Apply Blowfish in Cipher Block Chaining mode.
+ ;; INPUT is a string whose length is a multiple of 8 bytes.
+ ;; OUTPUT is a string whose length is the same as INPUT.
+ ;; KEY is a Blowfish key.
+ ;; INIT-VECTOR is an 8-byte string; it is modified after each call.
+ ;; The value from any call may be passed in to a later call.
+ ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F).
+ (guarantee-init-vector init-vector 'BLOWFISH-CBC)
+ (guarantee-bfkey key 'BLOWFISH-CBC)
+ (guarantee-8Xchar-arg input 'BLOWFISH-CBC)
+ (if (or (eq? input output)
+ (not (= (string-length output) (string-length input))))
+ (error:bad-range-argument output
+ "a string as long as the input string"
+ 'BLOWFISH-CBC))
+ (C-call "BF_cbc_encrypt" input output (string-length input)
+ key init-vector (bf-de/encrypt encrypt?)))
+
+(define (blowfish-cfb64 input istart iend output ostart
+ key init-vector num encrypt?)
+ ;; Apply Blowfish in Cipher Feed-Back mode.
+ ;; (INPUT,ISTART,IEND) is an arbitrary substring.
+ ;; OUTPUT is a string as large as the input substring.
+ ;; OSTART says where to start writing to the output string.
+ ;; KEY is a Blowfish key.
+ ;; INIT-VECTOR is an 8-byte string; it is modified after each call.
+ ;; The value from any call may be passed in to a later call.
+ ;; The initial value must be unique for each message/key pair.
+ ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the
+ ;; number of bytes that have previously been processed in this stream.
+ ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F).
+ ;; Returned value is the new value of NUM.
+ (guarantee-bfkey key 'BLOWFISH-CFB64)
+ (guarantee-init-vector init-vector 'BLOWFISH-CFB64)
+ (guarantee-substring input istart iend 'BLOWFISH-CFB64)
+ (guarantee-substring output ostart (+ ostart (- iend istart)) 'BLOWFISH-CFB64)
+ (guarantee-init-index num 'BLOWFISH-CFB64)
+ (let ((ilen (- iend istart)))
+ (if (and (eq? input output)
+ (< ostart iend)
+ (< istart (+ ostart ilen)))
+ (error:bad-range-argument
+ ostart
+ "an index of a substring not overlapping the input substring"
+ 'BLOWFISH-CFB64))
+ (C-call "do_BF_cfb64_encrypt" input istart output ostart ilen
+ key init-vector num (bf-de/encrypt encrypt?))))
+
+(define (blowfish-ofb64 input istart iend output ostart
+ key init-vector num)
+ ;; Apply Blowfish in Output Feed-Back mode.
+ ;; (INPUT,ISTART,IEND) is an arbitrary substring.
+ ;; OUTPUT is a string as large as the input substring.
+ ;; OSTART says where to start writing to the output string.
+ ;; KEY is a Blowfish key.
+ ;; INIT-VECTOR is an 8-byte string; it is modified after each call.
+ ;; The value from any call may be passed in to a later call.
+ ;; The initial value must be unique for each message/key pair.
+ ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the
+ ;; number of bytes that have previously been processed in this stream.
+ ;; Returned value is the new value of NUM.
+ (guarantee-bfkey key 'BLOWFISH-OFB64)
+ (guarantee-init-vector init-vector 'BLOWFISH-OFB64)
+ (guarantee-substring input istart iend 'BLOWFISH-OFB64)
+ (guarantee-substring output ostart (+ ostart (- iend istart)) 'BLOWFISH-OFB64)
+ (guarantee-init-index num 'BLOWFISH-OFB64)
+ (let ((ilen (- iend istart)))
+ (if (and (eq? input output)
+ (< ostart iend)
+ (< istart (+ ostart ilen)))
+ (error:bad-range-argument
+ ostart
+ "an index of a substring not overlapping the input substring"
+ 'BLOWFISH-OFB64))
+ (C-call "do_BF_ofb64_encrypt" input istart output ostart ilen
+ key init-vector num)))
+
+(define (bf-de/encrypt encrypt?)
+ (if encrypt? (C-enum "BF_ENCRYPT") (C-enum "BF_DECRYPT")))
+
+(define (guarantee-8char-arg arg operator)
+ (guarantee-string arg operator)
+ (if (not (= 8 (string-length arg)))
+ (error:bad-range-argument arg
+ "an 8 character string"
+ operator)))
+
+(define (guarantee-8Xchar-arg arg operator)
+ (guarantee-string arg operator)
+ (if (not (= 0 (modulo (string-length arg) 8)))
+ (error:bad-range-argument arg
+ "a multiple of 8 characters string"
+ operator)))
+
+(define (guarantee-bfkey object operator)
+ (if (not (and (string? object)
+ (fix:= (C-sizeof "BF_KEY")
+ (string-length object))))
+ (error:bad-range-argument object "a blowfish key" operator)))
+
+(define (guarantee-init-vector object operator)
+ (guarantee-string object operator)
+ (if (not (= 8 (string-length object)))
+ (error:bad-range-argument object
+ "a blowfish init vector"
+ operator)))
+
+(define (guarantee-init-index object operator)
+ (guarantee-fixnum object 'operator)
+ (if (not (and (fix:<= 0 object) (fix:< object 8)))
+ (error:bad-range-argument object
+ "a blowfish init-vector index"
+ operator)))
+
+(define (blowfish-available?)
+ (let ((path (ignore-errors (lambda ()
+ (system-library-pathname "blowfish-shim.so")))))
+ (and (pathname? path)
+ (file-loadable? path))))
+
+(define (blowfish-encrypt-port input output key init-vector encrypt?)
+ ;; Assumes that INPUT is in blocking mode.
+ (let ((key (blowfish-set-key key))
+ (input-buffer (make-string 4096))
+ (output-buffer (make-string 4096)))
+ (dynamic-wind
+ (lambda ()
+ unspecific)
+ (lambda ()
+ (let loop ((m 0))
+ (let ((n (input-port/read-string! input input-buffer)))
+ (if (not (fix:= 0 n))
+ (let ((m
+ (blowfish-cfb64 input-buffer 0 n output-buffer 0
+ key init-vector m encrypt?)))
+ (write-substring output-buffer 0 n output)
+ (loop m))))))
+ (lambda ()
+ (string-fill! input-buffer #\NUL)
+ (string-fill! output-buffer #\NUL)))))
+
+(define (compute-blowfish-init-vector)
+ ;; This init vector includes a timestamp with a resolution of
+ ;; milliseconds, plus 20 random bits. This should make it very
+ ;; difficult to generate two identical vectors.
+ (let ((iv (make-string 8)))
+ (do ((i 0 (fix:+ i 1))
+ (t (+ (* (+ (* (get-universal-time) 1000)
+ (remainder (real-time-clock) 1000))
+ #x100000)
+ (random #x100000))
+ (quotient t #x100)))
+ ((fix:= 8 i))
+ (vector-8b-set! iv i (remainder t #x100)))
+ iv))
+
+(define (write-blowfish-file-header port)
+ (write-string blowfish-file-header-v2 port)
+ (newline port)
+ (let ((init-vector (compute-blowfish-init-vector)))
+ (write-string init-vector port)
+ init-vector))
+
+(define (read-blowfish-file-header port)
+ (let ((line (read-line port)))
+ (cond ((string=? blowfish-file-header-v1 line)
+ (make-string 8 #\NUL))
+ ((string=? blowfish-file-header-v2 line)
+ (let ((init-vector (make-string 8)))
+ (if (not (= 8 (read-substring! init-vector 0 8 port)))
+ (error "Short read while getting init-vector:" port))
+ init-vector))
+ (else
+ (error:bad-range-argument port 'READ-BLOWFISH-FILE-HEADER)))))
+
+(define (blowfish-file? pathname)
+ (let ((line (call-with-binary-input-file pathname read-line)))
+ (and (not (eof-object? line))
+ (or (string=? line blowfish-file-header-v1)
+ (string=? line blowfish-file-header-v2)))))
+
+(define blowfish-file-header-v1 "Blowfish, 16 rounds")
+(define blowfish-file-header-v2 "Blowfish, 16 rounds, version 2")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the Blowfish wrapper.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "blowfish-check" (->environment '(blowfish)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Compile the Blowfish wrapper.
+
+(fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'CREF)
+ (load-option 'FFI))
+
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (compile-system "blowfish" (directory-pathname (current-load-pathname)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme blowfish interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-blowfish])
+AC_CONFIG_SRCDIR([blowfish.pkg])
+AC_CONFIG_HEADERS([config.h])
+
+AC_COPYRIGHT(
+[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+])
+
+AH_TOP([/*
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/])
+
+AC_ARG_WITH([openssl],
+ AS_HELP_STRING([--with-openssl],
+ [Use OpenSSL crypto library if available [[yes]]]))
+: ${with_openssl='yes'}
+
+dnl The OpenSSL crypto library provides support for blowfish.
+if test "${with_openssl}" != no; then
+ if test "${with_openssl}" != yes; then
+ CPPFLAGS="${CPPFLAGS} -I${with_openssl}/include"
+ LDFLAGS="${LDFLAGS} -L${with_openssl}/lib"
+ fi
+ FOUND=
+ AC_CHECK_HEADERS([openssl/blowfish.h blowfish.h],[FOUND=yes])
+ if test -n "${FOUND}"; then
+ AC_CHECK_LIB([crypto], [BF_set_key],
+ [
+ AC_DEFINE([HAVE_LIBCRYPTO], [1],
+ [Define to 1 if you have the `crypto' library (-lcrypto).])
+ LIBS="-lcrypto"
+ ])
+ fi
+fi
+
+AC_SUBST([LIBS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Load the BLOWFISH option.
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "blowfish")))
+
+(add-subsystem-identification! "Blowfish2" '(0 1))
\ No newline at end of file
fi
DEFAULT_TARGET=${with_default_target}
-AC_ARG_WITH([gtk],
- [AS_HELP_STRING([--with-gtk],
- [Support the GNOME Toolkits [[auto]]])],
- [],
- [with_gtk=auto])
-
AC_CANONICAL_HOST
MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
fi
fi
-AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
-AC_MSG_CHECKING([for gtk])
-if test "${with_gtk}" = "yes"; then
- AC_MSG_RESULT([by request... yes])
-elif test "${with_gtk}" = "no"; then
- AC_MSG_RESULT([by request... no])
-elif test "${with_gtk}" = "auto"; then
- if pkg-config --exists gtk+-3.0 2>/dev/null; then
- AC_MSG_RESULT([yes])
- with_gtk=yes
- else
- AC_MSG_RESULT([no Gtk 3.0... no])
- with_gtk=no
- fi
-fi
-
AC_SUBST([DEFAULT_TARGET])
AC_SUBST([ALL_TARGET])
-AC_SUBST([FFIS])
AC_SUBST([INSTALL_COM])
AC_SUBST([INSTALL_LIARC_BUNDLES])
AC_SUBST([MIT_SCHEME_EXE])
xdoc/Makefile
xml/Makefile
])
-if test "${with_gtk}" = "yes"; then
- AC_CONFIG_FILES([gtk/Makefile])
- AC_CONFIG_FILES([gtk-screen/Makefile])
- FFIS="${FFIS} gtk gtk-screen"
-fi
AC_OUTPUT
if test x"${mit_scheme_native_code}" = xc; then
(cd lib; rm -f ${BN}; ${LN_S} ../${BN} .)
done
for BUNDLE in 6001 compiler cref edwin ffi imail sf sos ssp star-parser \
- xdoc xml $FFIS; do
+ xdoc xml; do
SO=${BUNDLE}.so
(cd lib/lib; rm -f ${SO}; ${LN_S} ../../${BUNDLE}/${SO} .)
done
install:
$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) cref-unx.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(TARGET_DIR)/.
packages
extensions
loads
- (map (lambda (pathname)
- (cons
- (->namestring pathname)
- (let ((pathname
- (package-set-pathname
- (merge-pathnames pathname model-pathname)
- os-type)))
- (if (file-exists? pathname)
- (let ((contents (fasload pathname #t)))
- (if (package-file? contents)
- contents
- (begin
- (warn "Malformed package-description file:"
- pathname)
- #f)))
- (begin
- (warn "Can't find package-description file:" pathname)
- #f)))))
+ (map (lambda (name)
+ (let ((pathname (find-global-definitions name model-pathname
+ os-type)))
+ (and pathname
+ (cons (->namestring pathname)
+ (let ((contents (fasload pathname #t)))
+ (if (package-file? contents)
+ contents
+ (begin
+ (warn "Malformed package-description file:"
+ pathname)
+ #f)))))))
globals)
model-pathname))))
+
+(define (find-global-definitions name model-pathname os-type)
+ (let* ((filename (->pathname
+ (cond ((symbol? name) (symbol-name name))
+ ((string? name) name)
+ (else (error "Not a globals name:" name)))))
+ (pkd (package-set-pathname filename os-type)))
+ (or
+ (if (symbol? name)
+ (let ((pathname (ignore-errors
+ (lambda ()
+ (system-library-pathname pkd)))))
+ (and (not (condition? pathname))
+ pathname))
+ (let ((pathname (merge-pathnames pkd model-pathname)))
+ (and (file-exists? pathname)
+ pathname)))
+ (begin
+ (warn "Could not find global definitions:" pkd)
+ #f))))
\f
(define (sort-descriptions descriptions)
(letrec
(cddr expression))))
((GLOBAL-DEFINITIONS)
(let ((filenames (cdr expression)))
- (if (not (for-all? filenames string?))
+ (if (not (for-all? filenames
+ (lambda (f) (or (string? f) (symbol? f)))))
(lose))
- (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+ (cons 'GLOBAL-DEFINITIONS filenames)))
((OS-TYPE-CASE)
(if (not (and (list? (cdr expression))
(for-all? (cdr expression)
package)))))))
;; GLOBALS is a list of the bindings supplied externally.
(for-each (lambda (global)
- (if (cdr global)
+ (if (and global (cdr global))
(process-globals-info (cdr global)
(->namestring (car global))
get-package)))
install:
rm -rf $(DESTDIR)$(EDDIR)
$(mkinstalldirs) $(DESTDIR)$(EDDIR)
- $(INSTALL_DATA) *.bci $(DESTDIR)$(EDDIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(EDDIR)/.
@for F in $(EDOPTS); do \
CMD="$(INSTALL_COM) $${F}.com $(DESTDIR)$(EDDIR)/.";\
echo "$${CMD}"; eval "$${CMD}";\
(let ((start
(forward-down-list (backward-up-list point 1 'ERROR) 1 'ERROR))
(buffer (mark-buffer point)))
- (let ((end (forward-sexp start 1 'ERROR)))
+ (let* ((end (forward-sexp start 1 'ERROR))
+ (procedure-region (make-region start end))
+ (procedure-name (region->string procedure-region)))
(let ((procedure
(let ((environment (evaluation-environment buffer)))
(extended-scode-eval
- (syntax (with-input-from-region (make-region start end) read)
+ (syntax (with-input-from-region procedure-region read)
environment)
environment))))
(if (procedure? procedure)
(insert-string " . " point)
(insert-string (symbol-name argl) point)))))
(fluid-let ((*unparse-uninterned-symbols-by-name?* #t))
- (message argl))))
+ (message procedure-name ": " argl))))
(editor-error "Expression does not evaluate to a procedure: "
(extract-string start end))))))))
(update-buffer-news-thread-status buffer thread)))))))
\f
(define-command news-select-article
- "Select a buffer containing the News article indicated by point."
- ()
- (lambda ()
- (select-buffer
- (let ((buffer (selected-buffer)))
- (cond ((news-article-buffer? buffer)
- buffer)
- ((news-group-buffer? buffer)
- (call-with-values
- (lambda ()
- (get-article-buffer buffer (current-news-header) #t))
- (lambda (buffer new?)
- new?
- buffer)))
- (else
- (editor-error "No article selected.")))))))
+ "Select a buffer in the other window containing the News article at point.
+With prefix arg, select the buffer in the same window."
+ "P"
+ (lambda (same-window?)
+ (let ((proc (if same-window?
+ select-buffer
+ select-buffer-other-window)))
+ (proc
+ (let ((buffer (selected-buffer)))
+ (cond ((news-article-buffer? buffer)
+ buffer)
+ ((news-group-buffer? buffer)
+ (call-with-values
+ (lambda ()
+ (get-article-buffer buffer (current-news-header) #t))
+ (lambda (buffer new?)
+ new?
+ buffer)))
+ (else
+ (editor-error "No article selected."))))))))
(define-command news-toggle-thread
"Expand or collapse the current thread."
run_cmd ln -s machines/"${MDIR}" compiler/machine
run_cmd ln -s machine/compiler.pkg compiler/.
-BUNDLES="6001 compiler cref edwin ffi gtk gtk-screen imail sf sos ssp \
- star-parser xdoc xml"
+BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml"
run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <<EOF
(begin
run_make stamp_install-liarc-boot-compiler c-clean distclean
run_configure --enable-native-code=c --disable-host-scheme-test "${@}"
-run_make stamp_compile-liarc-bundles build-bands clean-boot-root build-ffis
+run_make stamp_compile-liarc-bundles build-bands clean-boot-root
(define-load-option 'FFI
(guarded-system-loader '(ffi) "ffi"))
-(define-load-option 'GTK
- (guarded-system-loader '(gtk) "gtk"))
-
-(define-load-option 'GTK-SCREEN
- (guarded-system-loader '(edwin screen gtk-screen) "gtk-screen"))
-
(define-load-option 'IMAIL
(guarded-system-loader '(edwin imail) "imail"))
COMPILE = $(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS)
LINK = $(CCLD) $(LDFLAGS) -o $@
-SHIM_CFLAGS = @MODULE_CFLAGS@
-SHIM_LDFLAGS = @MODULE_LDFLAGS@
-COMPILE_SHIM = $(COMPILE) $(SHIM_CFLAGS)
-LINK_SHIM = $(LINK) $(SHIM_LDFLAGS)
-SHIM_LOADER = @MODULE_LOADER@
-SHIM_LIBS = -lc
-
AUXDIR = @AUXDIR@
all:
$(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
$(INSTALL_DATA) ffi-*.pkd $(DESTDIR)$(TARGET_DIR)/.
$(INSTALL_DATA) make.scm $(DESTDIR)$(TARGET_DIR)/.
-
-# Build a test library interface.
-
-# This target is built after everything else (during build-ffis), and
-# should use the new machine, runtime, etc.
-
-# This interface is for tests/ffi/test-ffi.scm, which uses its own
-# wrapper, so there is no need for the compile-ffi procedure (hint).
-build: ffi-test-shim.so ffi-test-types.bin ffi-test-const.bin
-
-ffi-test-shim.so: ffi-test-shim.o ffi-test.o $(SHIM_LOADER)
- $(LINK_SHIM) ffi-test-shim.o ffi-test.o $(SHIM_LIBS)
-
-ffi-test-shim.o: ffi-test-shim.c ffi-test.h
- $(COMPILE_SHIM) -c $*.c
-
-ffi-test-shim.c ffi-test-const.c ffi-test-types.bin: ffi-test.cdecl
- (echo "(begin"; \
- echo " (load-option 'FFI)"; \
- echo ' (C-generate "ffi-test" "#include \"ffi-test.h\""))') \
- | ../microcode/scheme --library ../lib --batch-mode
-
-ffi-test-const.bin: ffi-test-const.scm
- echo '(sf "ffi-test-const")' \
- | ../microcode/scheme --library ../lib --batch-mode
-
-ffi-test-const.scm: ffi-test-const
- ./ffi-test-const
-
-ffi-test-const: ffi-test-const.o
- @rm -f $@
- $(CC) $(CFLAGS) $(LDFLAGS) -o $@ ffi-test-const.o
-
-ffi-test-const.o: ffi-test-const.c
- $(CC) $(CFLAGS) -o $@ -c $<
-
-# Finally, the test library itself.
-
-ffi-test.o: ffi-test.c ffi-test.h
- $(COMPILE_SHIM) -o $@ -c $<
-
-ffi-test.c: ffi-test.c.stay
- cp -p ffi-test.c.stay ffi-test.c
-
-.PHONY: build
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Build Utilities
+;;; package: (ffi build)
+
+(define (compile-shim)
+ (run-command (append cc-cmdline-prefix (command-line))))
+
+(define (link-shim)
+ (run-command (append CCLD LDFLAGS (command-line) MODULE_LDFLAGS)))
+
+(define (install-shim libname)
+ (let* ((pathname (pathname-as-directory libname))
+ (library-dir
+ (->namestring
+ (or (system-library-directory-pathname pathname)
+ (merge-pathnames pathname
+ (system-library-directory-pathname))))))
+ (run-command (list "rm" "-rf" library-dir))
+ (run-command (list "mkdir" library-dir))
+ (run-command (append (list "install" "-m" "644")
+ (command-line) (list library-dir)))
+ (run-command (list "install" "-m" "644"
+ (string-append libname "-shim.so")
+ (string-append libname "-types.bin")
+ (string-append libname "-const.bin")
+ (->namestring
+ (pathname-new-directory
+ library-dir
+ (except-last-pair
+ (pathname-directory library-dir))))))))
+\f
+(define (parse-words string)
+ (burst-string string char-set:whitespace #t))
+
+(define CC (parse-words "@CC@"))
+(define CFLAGS (parse-words "@CFLAGS@"))
+(define CCLD (parse-words "@CCLD@"))
+(define LDFLAGS (parse-words "@LDFLAGS@"))
+(define MODULE_LDFLAGS (parse-words "@MODULE_LDFLAGS@"))
+(define AUXDIR/ "@libdir@/@AUXDIR_NAME@/")
+(define INSTALL_DATA (parse-words "@INSTALL_DATA@"))
+(define cc-cmdline-prefix
+ (append
+ (filter
+ (lambda (i) (not (string=? "-DMIT_SCHEME" i)))
+ (parse-words "@CC@ @DEFS@ @SCHEME_DEFS@ @CPPFLAGS@"))
+ (list (string-append "-I" (->namestring
+ (directory-pathname
+ (system-library-pathname "mit-scheme.h")))))
+ (parse-words "@CFLAGS@ @MODULE_CFLAGS@")))
+
+(define (working-directory-name)
+ (let ((name (pathname-name (directory-pathname-as-file
+ (working-directory-pathname)))))
+ (if (and (string? name) (not (string-null? name)))
+ name
+ (error "Could not find the current working directory name."))))
+
+(define (run-command command)
+ (with-notification
+ (lambda (port)
+ (write-string (decorated-string-append "" " " "" command) port)
+ (newline port))
+ (lambda ()
+ (let ((code (run-synchronous-subprocess
+ (car command) (cdr command)
+ 'working-directory (working-directory-pathname))))
+ (if (not (zero? code))
+ (error "Process exited with error code:" code command))))))
\ No newline at end of file
+++ /dev/null
-/* -*-C-*- */
-
-/* A test library; used to test the C/Unix FFI. */
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include "ffi-test.h"
-
-static void *callback_data;
-static TestDoubleCallback callback_func;
-
-extern void
-test_register_double (TestDoubleCallback callback, void *user_data)
-{
- callback_func = callback;
- callback_data = user_data;
-}
-
-extern double
-test_double (double d, TestStruct *s)
-{
- if (!callback_data) return 0.0;
- return (d * callback_func (s->second, callback_data));
-}
-
-extern char *
-test_string (char *stri, TestStruct *stru)
-{
- int l1 = strlen (stri);
- int l2 = strlen (stru->fourth);
- char *s = malloc (3);
- snprintf (s, 3, "%d", l1 + l2);
- return (s);
-}
-
-extern TestStruct
-test_struct (TestStruct s)
-{
- s.second += strlen (s.fourth);
- return (s);
-}
-
-extern TestUnion
-test_union (TestUnion u)
-{
- u.d += 1.0;
- return (u);
-}
alien-function/parameters
alien-function/return-type)
(export ()
- c-generate))
\ No newline at end of file
+ c-generate))
+
+(define-package (ffi build)
+ (parent ())
+ (files "build")
+ (import (runtime pathname)
+ library-directory-path)
+ (export (ffi)
+ generate-shim
+ compile-shim
+ link-shim
+ install-shim))
\ No newline at end of file
(receiver (cadr form)))))
(define (load-c-includes library)
- (let* ((lib (merge-pathnames library (system-library-directory-pathname)))
- (name (pathname-name lib))
- (const (pathname-new-name lib (string-append name "-const")))
- (types (pathname-new-name lib (string-append name "-types")))
- (includes (fasload types (not c-include-noisily?)))
- (comment (fasload const (not c-include-noisily?)))
- (enums.struct-values
- (if (comment? comment) (comment-expression comment)
- (error:wrong-type-datum comment "a fasl comment"))))
- (warn-new-cdecls includes)
- (set-c-includes/enum-values! includes (car enums.struct-values))
- (set-c-includes/struct-values! includes (cadr enums.struct-values))
- includes))
+ (let ((lib (system-library-pathname (string-append library "-shim.so"))))
+ (let ((includes (fasload
+ (pathname-new-name (pathname-new-type lib "bin")
+ (string-append library "-types"))
+ (not c-include-noisily?)))
+ (comment (fasload
+ (pathname-new-name (pathname-new-type lib "bin")
+ (string-append library "-const"))
+ (not c-include-noisily?))))
+ (let ((enums.struct-values
+ (if (comment? comment) (comment-expression comment)
+ (error:wrong-type-datum comment "a fasl comment"))))
+ (warn-new-cdecls includes)
+ (set-c-includes/enum-values! includes (car enums.struct-values))
+ (set-c-includes/struct-values! includes (cadr enums.struct-values))
+ includes))))
(define (warn-new-cdecls includes)
(for-each
--- /dev/null
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+# Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+all: gdbm-shim.so gdbm-types.bin gdbm-const.bin
+ echo '(load "compile")' | $(EXE)
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install:
+ echo '(install-shim "gdbm")' | $(EXE) -- *.com *.bci *.pkd make.scm
+
+clean distclean maintainer-clean:
+ rm -f gdbm-const.scm gdbm-const gdbm-const.c gdbm-shim.c
+ rm -f gdbm-*.crf gdbm-*.fre gdbm-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f gdbm-check.db
+
+gdbm-shim.so: gdbm-shim.o gdbm-adapter.o
+ echo "(link-shim)" | $(EXE) -- -o $@ $^ -lgdbm
+
+gdbm-adapter.o: gdbm-adapter.c gdbm-shim.h
+ echo '(compile-shim)' | $(EXE) -- -c $<
+
+gdbm-shim.o: gdbm-shim.c gdbm-shim.h
+ echo '(compile-shim)' | $(EXE) -- -c $<
+
+gdbm-shim.c gdbm-const.c gdbm-types.bin: gdbm.cdecl gdbm-shim.h
+ echo '(generate-shim "gdbm" "#include \"gdbm-shim.h\"")' | $(EXE)
+
+gdbm-const.bin: gdbm-const.scm
+ echo '(sf "gdbm-const")' | $(EXE)
+
+gdbm-const.scm: gdbm-const
+ ./gdbm-const
+
+gdbm-const: gdbm-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+gdbm-const.o: gdbm-const.c gdbm-shim.h
+ $(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+.PHONY: all check install clean distclean maintainer-clean
--- /dev/null
+The GDBM wrapper.
+
+This is a drop-in replacement for the gdbm microcode module and
+runtime/gdbm.scm. It is not part of the core build and can be built
+outside the core build tree. There is no ./configure script yet. If
+you know you have libgdbm installed, you should win with this command:
+
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path. You can override the default
+command name "mit-scheme" (and thus the system library path) by
+setting MIT_SCHEME_EXE.
+
+To load via load-option, install the following in your optiondb.scm:
+
+ (define-load-option 'GDBM2 (guarded-system-loader '(gdbm) "gdbm"))
+
+You will need to call it GDBM2 while GDBM refers to the original
+microcode module.
+
+You will need to import the bindings you want to use. They are not
+exported to the global environment because they would conflict with
+the exports from (runtime gdbm).
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the GDBM wrapper.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "gdbm-check" (->environment '(gdbm)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Compile the GDBM wrapper.
+
+(fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'CREF)
+ (load-option 'FFI))
+
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (compile-system "gdbm" (directory-pathname (current-load-pathname)))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Adapters for the GDBM database library. */
+
+#include <mit-scheme.h>
+#include "gdbm-shim.h"
+
+extern char *
+alloc_gdbm_key (gdbm_args * args, int size)
+{
+ char * bytes;
+
+ if (size <= args->key_allocation)
+ {
+ bytes = args->key.dptr;
+ }
+ else
+ {
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ bytes = args->key.dptr = malloc (size);
+ args->key_allocation = size;
+ }
+ args->key.dsize = size;
+ return (bytes);
+}
+
+extern char *
+alloc_gdbm_content (gdbm_args * args, int size)
+{
+ char * bytes;
+
+ if (size <= args->content_allocation)
+ bytes = args->content.dptr;
+ else
+ {
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ bytes = args->content.dptr = malloc (size);
+ args->content_allocation = size;
+ }
+ args->content.dsize = size;
+ return (bytes);
+}
+
+extern char *
+get_gdbm_version (void)
+{
+ return (gdbm_version);
+}
+
+static void
+fatal_error (const char * msg)
+{
+ outf_error ("\ngdbm: %s\n", msg);
+ outf_flush_error ();
+ error_external_return ();
+}
+
+extern gdbm_args *
+do_gdbm_open (char * name, int block_size, int read_write, int mode)
+{
+ gdbm_args *args = (gdbm_args *) malloc (sizeof (gdbm_args));
+ if (!args) return (args);
+
+ args->key.dsize = 0;
+ args->key.dptr = NULL;
+ args->key_allocation = 0;
+ args->content.dsize = 0;
+ args->content.dptr = NULL;
+ args->content_allocation = 0;
+ args->gdbm_errno = 0;
+ args->sys_errno = 0;
+ args->dbf = gdbm_open (name, block_size, read_write, mode, &fatal_error);
+
+ if (args->dbf == NULL)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (args);
+}
+
+extern void
+do_gdbm_close (gdbm_args * args)
+{
+ gdbm_close (args->dbf);
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ free (args);
+}
+
+extern int
+do_gdbm_store (gdbm_args * args, int flag)
+{
+ int ret = gdbm_store (args->dbf, args->key, args->content, flag);
+ if (ret == -1)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
+
+extern void
+do_gdbm_fetch (gdbm_args * args)
+{
+ if (args->content.dptr != NULL)
+ free (args->content.dptr);
+ args->content = gdbm_fetch (args->dbf, args->key);
+ args->content_allocation = args->content.dsize;
+}
+
+extern int
+do_gdbm_exists (gdbm_args * args)
+{
+ return (gdbm_exists (args->dbf, args->key));
+}
+
+extern int
+do_gdbm_delete (gdbm_args * args)
+{
+ return (gdbm_delete (args->dbf, args->key));
+}
+
+extern void
+do_gdbm_firstkey (gdbm_args * args)
+{
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ args->key = gdbm_firstkey (args->dbf);
+ if (args->key.dptr != NULL)
+ args->key_allocation = args->key.dsize;
+ else
+ args->key_allocation = 0;
+}
+
+extern int
+do_gdbm_nextkey (gdbm_args * args)
+{
+ datum next = gdbm_nextkey (args->dbf, args->key);
+ if (next.dptr == NULL)
+ return (1);
+ if (args->key.dptr != NULL)
+ free (args->key.dptr);
+ args->key = next;
+ args->key_allocation = next.dsize;
+ return (0);
+}
+
+extern int
+do_gdbm_reorganize (gdbm_args * args)
+{
+ int ret = gdbm_reorganize (args->dbf);
+ if (ret)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
+
+extern void
+do_gdbm_sync (gdbm_args * args)
+{
+ gdbm_sync (args->dbf);
+}
+
+extern int
+do_gdbm_setopt (gdbm_args * args, int option, int value)
+{
+ int ret = gdbm_setopt (args->dbf, option, &value, sizeof (int));
+ if (ret)
+ {
+ args->gdbm_errno = gdbm_errno;
+ args->sys_errno = errno;
+ }
+ return (ret);
+}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the GDBM wrapper.
+
+(if (not (gdbm-available?))
+ (warn "gdbm wrapper not found")
+ (let ((filename.db "gdbm-check.db"))
+ (ignore-errors (lambda () (delete-file filename.db)))
+ (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660)))
+ ;; Must be set before first store.
+ (gdbm-setopt dbf GDBM_CACHESIZE 101)
+
+ (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE)
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT)))))
+ (error "storing null content did not signal"))
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT)))))
+ (error "storing null key did not signal"))
+ (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE)))
+ (error "replace produced wrong indication"))
+ (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT)))
+ (error "double insert produced no indication"))
+
+ (gdbm-setopt dbf GDBM_SYNCMODE 1)
+
+ (let ((content (gdbm-fetch dbf "Silly String")))
+ (if (not (string=? "Ahoy!" content))
+ (error "fetched:" content)))
+ (let ((content (gdbm-fetch dbf "Missing String")))
+ (if (not (eq? #f content))
+ (error "missing fetched:" content)))
+
+ (if (gdbm-exists? dbf "Missing String")
+ (error "exists"))
+ (if (not (gdbm-exists? dbf "Silly String"))
+ (error "not exists"))
+
+ (gdbm-delete dbf "Silly String")
+ (if (gdbm-exists? dbf "Silly String")
+ (error "not deleted"))
+ (if (gdbm-delete dbf "Missing String")
+ (error "deleted"))
+
+ (let ((k (gdbm-firstkey dbf)))
+ (if k
+ (error "empty database returned a firstkey:" k)))
+ (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT)
+ (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE)
+ (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT)
+ #;(let ((keys (sort (gdbm-keys dbf) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "keys:" keys)))
+
+ (gdbm-reorganize dbf)
+ (gdbm-sync dbf)
+ (gdbm-setopt dbf 'SYNCMODE #f)
+ (gdbm-version)
+ (gdbm-close dbf))
+
+ (if (not (condition?
+ (ignore-errors
+ (lambda () (gdbm-open "notfound.db" 0 GDBM_READER 0)))))
+ (error "opened a nonexistent database file:" gdbf))
+ (let ((dbf2 (gdbm-open filename.db 0 GDBM_READER 0)))
+ (let ((keys (sort (gdbm-keys dbf2) string<?)))
+ (if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
+ (error "bogus keys:" keys))
+ (map (lambda (key)
+ (if (not (string=? "Testing 1 2 3." (gdbm-fetch dbf2 key)))
+ (error "bogus content:" key)))
+ keys))
+ (gdbm-close dbf2))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Interface to the gdbm database library */
+
+#include <stdlib.h>
+#include <errno.h>
+#include <string.h>
+#include <gdbm.h>
+
+typedef struct gdbm_args {
+ GDBM_FILE dbf;
+ gdbm_error gdbm_errno;
+ int sys_errno;
+ datum key, content;
+ int key_allocation, content_allocation;
+} gdbm_args;
+
+extern char * alloc_gdbm_key (gdbm_args * args, int size);
+extern char * alloc_gdbm_content (gdbm_args * args, int size);
+
+extern gdbm_args * do_gdbm_open (char * name,
+ int block_size, int read_write, int mode);
+extern void do_gdbm_close (gdbm_args * args);
+extern int do_gdbm_store (gdbm_args * args, int flag);
+extern void do_gdbm_fetch (gdbm_args * args);
+extern int do_gdbm_exists (gdbm_args * args);
+extern int do_gdbm_delete (gdbm_args * args);
+extern void do_gdbm_firstkey (gdbm_args * args);
+extern int do_gdbm_nextkey (gdbm_args * args);
+extern int do_gdbm_reorganize (gdbm_args * args);
+extern void do_gdbm_sync (gdbm_args * args);
+extern int do_gdbm_setopt (gdbm_args * args, int option, int value);
+extern char * get_gdbm_version (void);
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for gdbm-shim.so.
+\f
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who
+;; can create the database.
+(enum (GDBM_READER) ;; A reader.
+ (GDBM_WRITER) ;; A writer.
+ (GDBM_WRCREAT) ;; A writer. Create the db if needed.
+ (GDBM_NEWDB) ;; A writer. Always create a new db.
+ (GDBM_FAST) ;; Write fast! => No fsyncs. OBSOLETE.
+ (GDBM_SYNC) ;; Sync operations to the disk.
+ (GDBM_NOLOCK)) ;; Don't do file locking operations.
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(enum (GDBM_INSERT) ;; Never replace old data with new.
+ (GDBM_REPLACE)) ;; Always replace old data with new.
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(enum (GDBM_CACHESIZE) ;; Set the cache size.
+ (GDBM_FASTMODE) ;; Toggle fast mode. OBSOLETE.
+ (GDBM_SYNCMODE) ;; Turn on or off sync operations.
+ (GDBM_CENTFREE) ;; Keep all free blocks in the header.
+ (GDBM_COALESCEBLKS)) ;; Attempt to coalesce free blocks.
+
+(typedef datum
+ (struct
+ (dptr (* char))
+ (dsize int)))
+
+(typedef gdbm_args
+ (struct
+ (dbf GDBM_FILE)
+ (gdbm_errno int)
+ (sys_errno int)
+ (key datum)
+ (content datum)))
+
+(typedef GDBM_FILE (* dummy))
+
+(extern (* char) alloc_gdbm_key (args (* gdbm_args)) (size int))
+(extern (* char) alloc_gdbm_content (args (* gdbm_args)) (size int))
+
+(extern (* gdbm_args) do_gdbm_open
+ (name (* char)) (block_size int) (read_write int) (mode int))
+(extern void do_gdbm_close (args (* gdbm_args)))
+(extern int do_gdbm_store (args (* gdbm_args)) (flag int))
+(extern void do_gdbm_fetch (args (* gdbm_args)))
+(extern int do_gdbm_exists (args (* gdbm_args)))
+(extern int do_gdbm_delete (args (* gdbm_args)))
+(extern void do_gdbm_firstkey (args (* gdbm_args)))
+(extern int do_gdbm_nextkey (args (* gdbm_args)))
+(extern int do_gdbm_reorganize (args (* gdbm_args)))
+(extern void do_gdbm_sync (args (* gdbm_args)))
+(extern (* char) gdbm_strerror (errnum int))
+(extern (* char) strerror (errnum int))
+(extern int do_gdbm_setopt (args (* gdbm_args)) (option int) (value int))
+(extern (* char) get_gdbm_version)
+
+(enum (GDBM_NO_ERROR)
+ (GDBM_MALLOC_ERROR)
+ (GDBM_BLOCK_SIZE_ERROR)
+ (GDBM_FILE_OPEN_ERROR)
+ (GDBM_FILE_WRITE_ERROR)
+ (GDBM_FILE_SEEK_ERROR)
+ (GDBM_FILE_READ_ERROR)
+ (GDBM_BAD_MAGIC_NUMBER)
+ (GDBM_EMPTY_DATABASE)
+ (GDBM_CANT_BE_READER)
+ (GDBM_CANT_BE_WRITER)
+ (GDBM_READER_CANT_DELETE)
+ (GDBM_READER_CANT_STORE)
+ (GDBM_READER_CANT_REORGANIZE)
+ (GDBM_UNKNOWN_UPDATE)
+ (GDBM_ITEM_NOT_FOUND)
+ (GDBM_REORGANIZE_FAILED)
+ (GDBM_CANNOT_REPLACE)
+ (GDBM_ILLEGAL_DATA)
+ (GDBM_OPT_ALREADY_SET)
+ (GDBM_OPT_ILLEGAL))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(global-definitions runtime/)
+
+(define-package (gdbm)
+ (files "gdbm")
+ (parent ())
+ (initialization (initialize-package!))
+ ;; You'll have to import these from (global-definitions gdbm/).
+ ;; They are currently bound in () by exports from (runtime gdbm).
+ #;(export #f
+ gdbm-available?
+ gdbm-close
+ gdbm-delete
+ gdbm-exists?
+ gdbm-fetch
+ gdbm-firstkey
+ gdbm-nextkey
+ gdbm-open
+ gdbm-reorganize
+ gdbm-setopt
+ gdbm-store
+ gdbm-sync
+ gdbm-version
+ gdbm_cachesize
+ gdbm_fast
+ gdbm_fastmode
+ gdbm_insert
+ gdbm_newdb
+ gdbm_reader
+ gdbm_replace
+ gdbm_wrcreat
+ gdbm_writer))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; GDBM wrapper
+;;; package: (gdbm)
+
+(declare (usual-integrations))
+\f
+(C-include "gdbm")
+
+(define (gdbm-available?)
+ (let ((path (ignore-errors (lambda ()
+ (system-library-pathname "gdbm-shim.so")))))
+ (and (pathname? path)
+ (file-loadable? path))))
+
+;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
+;; create the database.
+(define GDBM_READER (C-enum "GDBM_READER")) ;A reader.
+(define GDBM_WRITER (C-enum "GDBM_WRITER")) ;A writer.
+(define GDBM_WRCREAT(C-enum "GDBM_WRCREAT")) ;A writer. Create the db if needed.
+(define GDBM_NEWDB (C-enum "GDBM_NEWDB")) ;A writer. Always create a new db.
+(define GDBM_FAST (C-enum "GDBM_FAST")) ;Write fast! => No fsyncs.
+
+(define (gdbm-open filename block-size flags mode)
+ (guarantee-integer block-size 'GDBM-OPEN)
+ (guarantee-integer mode 'GDBM-OPEN)
+ (let ((args (make-alien '|gdbm_args|))
+ (flagsnum (guarantee-gdbm-open-flags flags)))
+ (let ((gdbf (make-gdbf args (make-thread-mutex) filename)))
+ (if (not (gdbm-available?))
+ (error "GDBM support is not installed."))
+ (add-open-gdbf-cleanup gdbf)
+ (with-gdbf-locked
+ gdbf
+ (lambda ()
+ (C-call "do_gdbm_open" args filename block-size flagsnum mode)
+ (if (alien-null? args)
+ (error "gdbm_open failed: malloc failed")
+ (if (alien-null? (C-> args "gdbm_args dbf"))
+ (gdbm-error gdbf "gdbm_open")))))
+ gdbf)))
+
+(define (guarantee-gdbm-open-flags flags)
+ (define (flag->number flag)
+ (case flag
+ ((READER) (C-enum "GDBM_READER"))
+ ((WRITER) (C-enum "GDBM_WRITER"))
+ ((WRCREAT) (C-enum "GDBM_WRCREAT"))
+ ((NEWDB) (C-enum "GDBM_NEWDB"))
+ ((FAST) (C-enum "GDBM_FAST"))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+ (cond ((integer? flags) flags)
+ ((symbol? flags) (flag->number flags))
+ ((list-of-type? flags symbol?)
+ (reduce + 0 (map flag->number flags)))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+
+(define (gdbm-close gdbf)
+ (guarantee-gdbf gdbf 'GDBM-CLOSE)
+ (with-gdbf-locked
+ gdbf
+ (lambda ()
+ (let ((args (gdbf-args gdbf)))
+ (if (not (alien-null? args))
+ (begin
+ (C-call "do_gdbm_close" args)
+ (alien-null! args)
+ (remove-open-gdbf-cleanup gdbf))))
+ unspecific)))
+
+;; Parameters to gdbm_store for simple insertion or replacement in the
+;; case that the key is already in the database.
+(define GDBM_INSERT (C-enum "GDBM_INSERT")) ;Never replace old data.
+(define GDBM_REPLACE (C-enum "GDBM_REPLACE")) ;Always replace old data.
+
+(define (gdbm-store gdbf key content flag)
+ (guarantee-gdbf gdbf 'GDBM-STORE)
+ (guarantee-nonnull-string key 'GDBM-STORE)
+ (guarantee-nonnull-string content 'GDBM-STORE)
+ (let ((flagnum (cond ((= flag GDBM_INSERT) flag)
+ ((= flag GDBM_REPLACE) flag)
+ ((eq? flag 'INSERT) (C-enum "GDBM_INSERT"))
+ ((eq? flag 'REPLACE) (C-enum "GDBM_REPLACE"))
+ (else (error:wrong-type-argument flag "gdbm-store flag"
+ 'GDBM-STORE)))))
+ (with-gdbf-locked-open
+ gdbf 'GDBM-STORE
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (gdbf-args-put-content! args content)
+ (let ((ret (C-call "do_gdbm_store" args flagnum)))
+ (cond ((fix:zero? ret) #t)
+ ((fix:< 0 ret) #f)
+ (else (gdbm-error gdbf "gdbm_store"))))))))
+
+(define (gdbm-fetch gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-FETCH)
+ (guarantee-nonnull-string key 'GDBM-FETCH)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-FETCH
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (C-call "do_gdbm_fetch" args)
+ (gdbf-args-get-content args))))
+
+(define (gdbm-exists? gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-EXISTS?)
+ (guarantee-nonnull-string key 'GDBM-EXISTS?)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-EXISTS
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (not (zero? (C-call "do_gdbm_exists" args))))))
+
+(define (gdbm-delete gdbf key)
+ (guarantee-gdbf gdbf 'GDBM-DELETE)
+ (guarantee-nonnull-string key 'GDBM-DELETE)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-DELETE
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (zero? (C-call "do_gdbm_delete" (gdbf-args gdbf))))))
+
+(define (gdbm-keys gdbf)
+ (guarantee-gdbf gdbf 'GDBM-KEYS)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-KEYS
+ (lambda (args)
+ (C-call "do_gdbm_firstkey" args)
+ (let ((key (gdbf-args-get-key args)))
+ (if (not key)
+ '()
+ (let loop ((keys (list key)))
+ (if (zero? (C-call "do_gdbm_nextkey" args))
+ (loop (cons (gdbf-args-get-key args) keys))
+ keys)))))))
+
+(define (gdbm-firstkey gdbf)
+ (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-FIRSTKEY
+ (lambda (args)
+ (C-call "do_gdbm_firstkey" args)
+ (gdbf-args-get-key args))))
+
+(define (gdbm-nextkey gdbf key)
+ ;; Returns #f if KEY is not (or no longer) in the database. Use
+ ;; gdbm-keys to read a complete list despite deletes. Gdbm-keys
+ ;; also avoids copying the keys back for gdbm_nextkey.
+ (guarantee-gdbf gdbf 'GDBM-NEXTKEY)
+ (guarantee-nonnull-string key 'GDBM-NEXTKEY)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-NEXTKEY
+ (lambda (args)
+ (gdbf-args-put-key! args key)
+ (if (zero? (C-call "do_gdbm_nextkey" args))
+ (gdbf-args-get-key args)
+ #f))))
+
+(define (gdbm-reorganize gdbf)
+ (guarantee-gdbf gdbf 'GDBM-REORGANIZE)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-REORGANIZE
+ (lambda (args)
+ (if (not (zero? (C-call "do_gdbm_reorganize" args)))
+ (gdbm-error gdbf "gdbm_reorganize")))))
+
+(define (gdbm-sync gdbf)
+ (guarantee-gdbf gdbf 'GDBM-SYNC)
+ (with-gdbf-locked-open
+ gdbf 'GDBM-SYNC
+ (lambda (args)
+ (C-call "do_gdbm_sync" args))))
+
+(define (gdbm-strerror errno)
+ (guarantee-fixnum errno 'GDBM-STRERROR)
+ (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno)))
+
+(define (strerror errno)
+ (guarantee-fixnum errno 'STRERROR)
+ (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno)))
+
+;; Parameters to gdbm_setopt, specifing the type of operation to perform.
+(define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE")) ;Set the cache size.
+(define GDBM_SYNCMODE (C-enum "GDBM_SYNCMODE")) ;Toggle fast mode.
+
+(define (gdbm-setopt gdbf opt val)
+ (guarantee-gdbf gdbf 'GDBM-SETOPT)
+ (let* ((optnum
+ (cond ((eq? opt 'SYNCMODE) (C-enum "GDBM_SYNCMODE"))
+ ((eq? opt 'CACHESIZE) (C-enum "GDBM_CACHESIZE"))
+ ((and (number? opt) (= opt GDBM_SYNCMODE)) opt)
+ ((and (number? opt) (= opt GDBM_CACHESIZE)) opt)
+ (else (error:wrong-type-argument opt "option" 'GDBM-SETOPT))))
+ (valnum
+ (cond ((= optnum GDBM_SYNCMODE)
+ (cond ((not val) 0)
+ ((eq? val #t) 1)
+ ((zero? val) val)
+ ((= val 1) val)
+ (else (error:wrong-type-argument val "SYNCMODE boolean"
+ 'GDBM-SETOPT))))
+ ((= optnum GDBM_CACHESIZE)
+ (guarantee-integer val 'GDBM-SETOPT)
+ val))))
+ (with-gdbf-locked-open
+ gdbf 'GDBM-SETOPT
+ (lambda (args)
+ (if (not (zero? (C-call "do_gdbm_setopt" args optnum valnum)))
+ (gdbm-error gdbf "gdbm_setopt"))))))
+
+(define (gdbm-version)
+ (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char)))))
+
+(define (guarantee-nonnull-string obj procedure)
+ (if (or (not (string? obj)) (string-null? obj))
+ (error:wrong-type-argument obj "non-null string" procedure)))
+\f
+(define-structure (gdbf (constructor make-gdbf)
+ (print-procedure
+ (standard-unparser-method
+ 'GDBF
+ (lambda (gdbf port)
+ (write-char #\space port)
+ (write (gdbf-filename gdbf) port)))))
+ ;; Note that communicating through this malloced-per-GDBM_FILE
+ ;; helper struct assumes there are no callbacks possible during gdbm
+ ;; operations (via which this procedure could be called multiple
+ ;; times [requiring a malloc per operation]). The per-gdbf lock is
+ ;; probably already be poised to deadlock any thread trying it.
+ (args #f read-only #t)
+ (mutex #f read-only #t)
+ (filename #f read-only #t))
+
+(define (guarantee-gdbf gdbf procedure)
+ (if (gdbf? gdbf)
+ (or (not (alien-null? (gdbf-args gdbf)))
+ (error:bad-range-argument gdbf procedure))
+ (error:wrong-type-argument gdbf "gdbm handle" procedure)))
+
+(define-integrable (with-gdbf-locked gdbf thunk)
+ (with-thread-mutex-locked (gdbf-mutex gdbf) thunk))
+
+(define (with-gdbf-locked-open gdbf operator receiver)
+ (with-thread-mutex-locked
+ (gdbf-mutex gdbf)
+ (lambda ()
+ (let ((args (gdbf-args gdbf)))
+ (if (alien-null? args)
+ (error (string-append (symbol-name operator) " failed: closed")))
+ (receiver args)))))
+
+(define (gdbm-error gdbf msg)
+ (let ((args (gdbf-args gdbf)))
+ (error (string-append msg " failed:")
+ (gdbm-strerror (C-> args "gdbm_args gdbm_errno"))
+ (strerror (C-> args "gdbm_args sys_errno")))))
+
+(define (gdbf-args-put-key! args key)
+ (let ((size (string-length key))
+ (dptr (make-alien '(* char))))
+ (if (< size 1)
+ (error "empty key:" key))
+ (C-call "alloc_gdbm_key" dptr args size)
+ (if (alien-null? dptr)
+ (error "gdbf-args-put-key!: malloc failed" key))
+ (c-poke-bytes dptr 0 size key 0)))
+
+(define (gdbf-args-put-content! args content)
+ (let ((size (string-length content))
+ (dptr (make-alien '(* char))))
+ (if (< size 1)
+ (error "empty content:" content))
+ (C-call "alloc_gdbm_content" dptr args size)
+ (if (alien-null? dptr)
+ (error "gdbf-args-put-content!: malloc failed" size))
+ (c-poke-bytes dptr 0 size content 0)))
+
+(define (gdbf-args-get-key args)
+ (let ((data (C-> args "gdbm_args key dptr")))
+ (if (alien-null? data)
+ #f
+ (let* ((size (C-> args "gdbm_args key dsize"))
+ (string (string-allocate size)))
+ (c-peek-bytes data 0 size string 0)
+ string))))
+
+(define (gdbf-args-get-content args)
+ (let ((data (C-> args "gdbm_args content dptr")))
+ (if (alien-null? data)
+ #f
+ (let* ((size (C-> args "gdbm_args content dsize"))
+ (string (string-allocate size)))
+ (c-peek-bytes data 0 size string 0)
+ string))))
+
+(define open-gdbfs '())
+(define open-gdbfs-mutex)
+
+(define (add-open-gdbf-cleanup gdbf)
+ (with-thread-mutex-locked
+ open-gdbfs-mutex
+ (lambda ()
+ (set! open-gdbfs (cons (weak-cons gdbf (gdbf-args gdbf))
+ open-gdbfs)))))
+
+(define (remove-open-gdbf-cleanup gdbf)
+ (with-thread-mutex-locked
+ open-gdbfs-mutex
+ (lambda ()
+ (let ((entry (weak-assq gdbf open-gdbfs)))
+ (if entry
+ (set! open-gdbfs (delq! entry open-gdbfs)))))))
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+
+(define (cleanup-open-gdbfs)
+ (if (not (thread-mutex-owner open-gdbfs-mutex))
+ (let loop ((entries open-gdbfs)
+ (prev #f))
+ (if (pair? entries)
+ (let ((entry (car entries))
+ (next (cdr entries)))
+ (if (weak-pair/car? entry)
+ (loop next entries)
+ (let ((args (weak-cdr entry)))
+ (if prev
+ (set-cdr! prev next)
+ (set! open-gdbfs next))
+ (if (not (alien-null? args))
+ (begin
+ (C-call "do_gdbm_close" args)
+ (alien-null! args)))
+ (loop next prev))))))))
+
+(define (reset-open-gdbfs)
+ (for-each (lambda (weak) (alien-null! (weak-cdr weak))) open-gdbfs)
+ (set! open-gdbfs '()))
+
+(define (initialize-package!)
+ (set! open-gdbfs-mutex (make-thread-mutex))
+ (set! open-gdbfs '())
+ (add-gc-daemon! cleanup-open-gdbfs)
+ (add-event-receiver! event:after-restart reset-open-gdbfs))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Load the GDBM option.
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "gdbm")))
+
+(add-subsystem-identification! "GDBM2" '(0 1))
\ No newline at end of file
--- /dev/null
+# Copyright (C) 2011, 2012, 2013 Matthew Birkholz
+#
+# This file is part of an extension to MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+all:
+ echo '(load "compile")' | $(EXE)
+ @if [ -s gtk-screen-unx.crf ]; then \
+ echo "gtk-screen-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install:
+ echo '(install-shim)' | $(EXE) -- *.com *.bci *.pkd make.scm
+
+clean distclean maintainer-clean:
+ rm -f *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd
+
+tags:
+ etags *.scm
+
+.PHONY: all check install clean distclean maintainer-clean tags
+++ /dev/null
-# gtk-screen/Makefile-fragment
-
-TARGET_DIR = $(AUXDIR)/gtk-screen
-
-# This is not an FFI, but depends on one. Nothing is generated at
-# first. At "build" time the latest FFIs should be available.
-# Compile-ffi is used so that `make compile-liarc-bundle' will happen
-# when needed.
-
-generate:
-
-build:
- cd ../ && echo '(load "etc/compile.scm")(compile-ffi "gtk-screen")' \
- | microcode/scheme --library lib --batch-mode
- @if [ -s gtk-screen-unx.crf ]; then \
- echo "gtk-screen-unx.crf:0: warning: non-empty"; exit 1; fi
-
-install:
- rm -rf $(DESTDIR)$(TARGET_DIR)
- $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
- $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) gtk-screen-*.pkd $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) make.scm $(DESTDIR)$(TARGET_DIR)/.
- if test `echo "(pp microcode-id/compiled-code-type)" \
- | ../microcode/scheme --library ../lib --batch-mode` = "c"; \
- then $(MAKE) install-liarc-bundle; fi
+++ /dev/null
-gtk-const
-gtk-const.c
-gtk-const.scm
-gtk-shim.c
-gtk-shim.so
-scmwidget.c
-gtkio.c
-swat-pole-zero.scm
+++ /dev/null
-#!/bin/sh
-
-set -e
-
-if [ ${#} -ne 1 ]; then
- echo "usage: ${0} <command>"
- exit 1
-fi
-
-../etc/Clean.sh "${1}"
-. ../etc/functions.sh
-
-maybe_rm gtk-shim.c gtk-const* gtk-types* swat-pole-zero*
-maybe_rm ../lib/conses.png
-maybe_rm ../lib/gtk-*
-# And, just because the maintainer- and c-clean targets nail these anyway:
-maybe_rm scmwidget.c gtkio.c
+++ /dev/null
-#-*-Makefile-*-
-# gtk/Makefile-fragment
-#
-# Copyright (C) 2011, 2012 Matthew Birkholz
-#
-# This file is part of an extension to MIT/GNU Scheme.
-#
-# MIT/GNU Scheme 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 of the
-# License, or (at your option) any later version.
-#
-# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-# 02110-1301, USA.
-
-TARGET_DIR = $(AUXDIR)/gtk
-
-build: ../lib/gtk-shim.so ../lib/gtk-types.bin ../lib/gtk-const.bin \
- ../lib/conses.png swat-pole-zero.scm
- cd ../ && echo '(load "etc/compile.scm")(compile-ffi "gtk")' \
- | microcode/scheme --library lib --batch-mode
- @if [ -s ../gtk/gtk-unx.crf ]; then \
- echo "../gtk/gtk-unx.crf:0: warning: non-empty"; exit 1; fi
-
-../lib/gtk-shim.so: gtk-shim.so
- $(INSTALL_DATA) gtk-shim.so $@
-
-../lib/gtk-types.bin: gtk-types.bin
- $(INSTALL_DATA) gtk-types.bin $@
-
-../lib/gtk-const.bin: gtk-const.bin
- $(INSTALL_DATA) gtk-const.bin $@
-
-../lib/conses.png: conses.png
- $(INSTALL_DATA) conses.png $@
-
-swat-pole-zero.scm:
- $(LN_S) ../swat/scheme/other/pole-zero.scm swat-pole-zero.scm
-
-install:
- rm -rf $(DESTDIR)$(TARGET_DIR)
- $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
- $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) gtk-*.pkd $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) make.scm $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) gtk-shim.so $(DESTDIR)$(AUXDIR)/.
- $(INSTALL_DATA) gtk-types.bin $(DESTDIR)$(AUXDIR)/.
- $(INSTALL_DATA) gtk-const.bin $(DESTDIR)$(AUXDIR)/.
- $(INSTALL_DATA) conses.png $(DESTDIR)$(AUXDIR)/.
- if test `echo "(pp microcode-id/compiled-code-type)" \
- | ../microcode/scheme --library ../lib --batch-mode` = "c"; \
- then $(MAKE) install-liarc-bundle; fi
-
-gtk-shim.so: gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o \
- gtkio.o $(SHIM_LOADER)
- $(LINK_SHIM) gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o \
- gtkio.o `pkg-config --libs gtk+-3.0 gthread-2.0` $(SHIM_LIBS)
-
-gtkscrolledview.o: gtkscrolledview.c gtkscrolledview.h
- $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c gtkscrolledview.c
-
-gtkscrolledview.c: gtkscrolledview.c.stay
- cp -p gtkscrolledview.c.stay gtkscrolledview.c
-
-gtkpanedview.o: gtkpanedview.c gtkpanedview.h
- $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c gtkpanedview.c
-
-gtkpanedview.c: gtkpanedview.c.stay
- cp -p gtkpanedview.c.stay gtkpanedview.c
-
-scmwidget.o: scmwidget.c scmwidget.h
- $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c scmwidget.c
-
-scmwidget.c: scmwidget.c.stay
- cp -p scmwidget.c.stay scmwidget.c
-
-# COMPILE_SHIM will not do. COMPILE's DEFS conflict (cause warnings)
-# with config.h. This is COMPILE_SHIM without DEFS.
-gtkio.o: gtkio.c
- $(CC) $(CPPFLAGS) $(CFLAGS) $(SHIM_CFLAGS) \
- `pkg-config --cflags gtk+-3.0` -I../microcode -c $<
-
-gtkio.c: gtkio.c.stay
- cp -p gtkio.c.stay gtkio.c
-
-gtk-shim.o: gtk-shim.c gtk-shim.h ../lib/mit-scheme.h
- $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -o $@ -c $<
-
-gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl \
- Includes/*.cdecl Includes/*/*.cdecl
- ( echo "(load-option 'FFI)"; \
- echo '(C-generate "gtk" "#include \"gtk-shim.h\"")' ) \
- | ../microcode/scheme --library ../lib --batch-mode
-
-gtk-const.bin: gtk-const.scm
- echo '(sf "gtk-const")' \
- | ../microcode/scheme --library ../lib --batch-mode
-
-gtk-const.scm: gtk-const
- ./gtk-const
-
-gtk-const: gtk-const.o
- @rm -f $@
- $(CCLD) $(CFLAGS) $(LDFLAGS) -o $@ $< `pkg-config --libs gtk+-3.0`
-
-gtk-const.o: gtk-const.c
- $(CC) $(CFLAGS) `pkg-config --cflags gtk+-3.0` -o $@ -c $<
-
-.PHONY: build install
--- /dev/null
+# Copyright (C) 2011, 2012, 2013 Matthew Birkholz
+#
+# This file is part of an extension to MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+all: gtk-shim.so gtk-types.bin gtk-const.bin
+ echo '(load "compile")' | $(EXE)
+ @if [ -s gtk-unx.crf ]; then \
+ echo "gtk-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
+ echo '(load "check")' | $(EXE)
+ echo '(load "check-doc")' | $(EXE)
+
+install:
+ echo '(install-shim "gtk")' \
+ | $(EXE) -- *.com *.bci *.pkd make.scm conses.png
+
+#install-optiondb
+#install-manual "<li><a href=\"mit-scheme-gtk/index.html\">GTK User's Manual</a></li>"
+
+clean:
+ rm -f gtk-const.scm gtk-const gtk-const.c gtk-shim.c
+ rm -f gtk-*.crf gtk-*.fre gtk-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+tags:
+ etags *.h \
+ `echo *.c | sed 's/ gtk-const.c//; s/ gtk-shim.c//'` \
+ `echo *.scm | sed 's/ gtk-const.scm//'` \
+ -r '/^([^iI].*/' Includes/*.cdecl
+
+gtk-shim.so: gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o gtkio.o
+ echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
+ `pkg-config --libs gtk+-3.0 gthread-2.0`
+
+gtkscrolledview.o: gtkscrolledview.c gtkscrolledview.h
+ echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
+
+gtkpanedview.o: gtkpanedview.c gtkpanedview.h
+ echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
+
+scmwidget.o: scmwidget.c scmwidget.h
+ echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
+
+gtkio.o: gtkio.c
+ echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
+
+gtk-shim.o: gtk-shim.c gtk-shim.h
+ echo "(compile-shim)" | $(EXE) -- $(CPPFLAGS) $(CFLAGS) \
+ `pkg-config --cflags gtk+-3.0` -c $<
+
+gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl \
+ Includes/*.cdecl Includes/*/*.cdecl
+ echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(EXE)
+
+gtk-const.bin: gtk-const.scm
+ echo '(sf "gtk-const")' | $(EXE)
+
+gtk-const.scm: gtk-const
+ ./gtk-const
+
+gtk-const: gtk-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS) `pkg-config --libs gtk+-3.0`
+
+gtk-const.o: gtk-const.c gtk-shim.h
+ $(CC) $(CPPFLAGS) `pkg-config --cflags gtk+-3.0` $(CFLAGS) -c $<
+
+.PHONY: all check install clean distclean maintainer-clean tags
--- /dev/null
+The gtk wrapper.
+
+To build:
+
+ ./configure [--with-gtk=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path. You can override the default
+command name "mit-scheme" (and thus the system library path) by
+setting MIT_SCHEME_EXE.
+
+To load via load-option, install the following in your optiondb.scm:
+
+ (define-load-option 'GTK
+ (guarded-system-loader '(gtk) "gtk"))
+++ /dev/null
-#!/bin/sh
-
-# Utility to make TAGS file for the gtk build directory.
-# The working directory must be the build directory.
-
-etags gtk-shim.h scmwidget.c.stay `echo *.scm | sed 's/ gtk-const.scm//'` \
- --language=scheme Includes/*.cdecl
(loop (cdr items) (cons (car items) difference))))))
(define (check)
- (let* ((texinfo (list->vector (call-with-input-file "../doc/gtk/gtk.texinfo"
+ (let* ((texinfo (list->vector (call-with-input-file "gtk.texinfo"
read-lines)))
(deffns (texinfo-deffns texinfo))
(dups (duplicates deffns))
- (pmodel (with-working-directory-pathname "gtk/"
- (lambda ()
- (read-package-model "gtk" microcode-id/operating-system))))
+ (pmodel (read-package-model "gtk" microcode-id/operating-system))
(bindings (append (pmodel/global-exports pmodel)
(pmodel/package-bindings pmodel '(gtk))))
(missing (minus (minus bindings deffns)
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test optiondb, includes the installed system's optiondb.
+
+(define-load-option 'GTK
+ (let ((pathname
+ (merge-pathnames "make"
+ (directory-pathname (current-load-pathname)))))
+ (named-lambda (gtk-option-loader)
+ (load pathname))))
+
+(further-load-options
+ (merge-pathnames "optiondb"
+ (last (access library-directory-path
+ (->environment '(runtime pathname))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the gtk wrapper.
+
+(let ((env (->environment '(runtime pathname)))
+ (dirname (directory-pathname (current-load-pathname))))
+ (set! (access library-directory-path env)
+ (cons dirname (access library-directory-path env)))
+ (set! *initial-options-file* (merge-pathnames "check-optiondb" dirname)))
+
+(if (not (warn-errors? (lambda () (load-option 'GTK))))
+ (load "gtk-check" (->environment '(GTK))))
\ No newline at end of file
(load-option 'SOS)
(load-option 'FFI))
-(compile-system "gtk" (directory-pathname (current-load-pathname))
- ;; Temporary hack, until the released CREF loosens up
- ;; and simply warns about new options it does not
- ;; support, like the depends-on options commented out
- ;; of gtk.pkg and recreated below.
- 'dependencies
- (let (
- ;; gtk.scm includes the Gtk c-includes, but does
- ;; not otherwise use the FFI.
- (c-types '("gtk-const.bin"))
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (compile-system "gtk" (directory-pathname (current-load-pathname))
+ ;; Temporary hack, until the released CREF loosens up
+ ;; and simply warns about new options it does not
+ ;; support, like the depends-on options commented out
+ ;; of gtk.pkg and recreated below.
+ 'dependencies
+ (let (
+ ;; gtk.scm includes the Gtk c-includes, but does
+ ;; not otherwise use the FFI.
+ (c-types '("gtk-const.bin"))
- ;; The wrappers use the FFI, c-includes, and
- ;; some integrable definitions in gtk.scm.
- ;; Dependencies between them are rare.
- (base '("gtk.bin" "gtk"
- ;; "../runtime/ffi" ;; No workie???!!!
- ))
+ ;; The wrappers use the FFI, c-includes, and
+ ;; some integrable definitions in gtk.scm.
+ ;; Dependencies between them are rare.
+ (base '("gtk.bin" "gtk"
+ ;; "../runtime/ffi" ;; No workie???!!!
+ ))
- ;; Users of the toolkit interface do NOT use the
- ;; FFI directly, and do not need integrable
- ;; definitions.
- (user '()))
- `(("gtk" ,@c-types)
- ("gobject" ,@base)
- ("gio" ,@base)
- ("pango" ,@base)
- ("cairo" ,@base)
- ("gtk-widget" ,@base)
- ("scm-widget" ,@base)
- ("fix-layout" "pango" "cairo" ,@base ,@c-types)
- ("keys" ,@base ,@c-types)
- ("gtk-graphics" ,@base)
- ("main" ,@base)
- ("thread" "main" ,@user)
- ("gtk-ev" ,@base)
- ("fix-demo" ,@user)
- ("swat" ,@user)
- ("swat-pole-zero" ,@user))))
\ No newline at end of file
+ ;; Users of the toolkit interface do NOT use the
+ ;; FFI directly, and do not need integrable
+ ;; definitions.
+ (user '()))
+ `(("gtk" ,@c-types)
+ ("gobject" ,@base)
+ ("gio" ,@base)
+ ("pango" ,@base)
+ ("cairo" ,@base)
+ ("gtk-widget" ,@base)
+ ("scm-widget" ,@base)
+ ("fix-layout" "pango" "cairo" ,@base ,@c-types)
+ ("keys" ,@base ,@c-types)
+ ("gtk-graphics" ,@base)
+ ("main" ,@base)
+ ("thread" "main" ,@user)
+ ("gtk-ev" ,@base)
+ ("fix-demo" ,@user)
+ ("swat" ,@user)
+ ("swat-pole-zero" ,@user))))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme gtk interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-gtk])
+AC_CONFIG_SRCDIR([gtk.pkg])
+AC_CONFIG_HEADERS([config.h])
+
+AC_COPYRIGHT(
+[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+])
+
+AH_TOP([/*
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/])
+
+AC_ARG_WITH([gtk],
+ [AS_HELP_STRING([--with-gtk],
+ [Support the GNOME Toolkits [[auto]]])],
+ [],
+ [with_gtk=auto])
+
+AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes])
+AC_MSG_CHECKING([for gtk])
+if test "${with_gtk}" = "yes"; then
+ AC_MSG_RESULT([by request... yes])
+elif test "${with_gtk}" = "no"; then
+ AC_MSG_RESULT([by request... no])
+elif test "${with_gtk}" = "auto"; then
+ if pkg-config --exists gtk+-3.0 2>/dev/null; then
+ AC_MSG_RESULT([yes])
+ with_gtk=yes
+ else
+ AC_MSG_RESULT([no Gtk 3.0... no])
+ with_gtk=no
+ fi
+fi
+
+if test "${with_gtk}" = "yes"; then
+ AC_CONFIG_FILES([Makefile])
+fi
+
+AC_SUBST([CFLAGS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_SUBST([LIBS])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2012, 2013 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the Gtks
+
+(let ((new (extend-top-level-environment (->environment '(gtk))))
+ (ffi (->environment '(runtime ffi))))
+ (display "; libpath: ")
+ (display (access library-directory-path (->environment '(runtime pathname))))
+ (newline)
+ (display "; gtk-thread: ")
+ (display (access gtk-thread (->environment '(gtk thread))))
+ (newline)
+ (load "gtk-tests" new)
+ (load "hello" new)
+ (let ((gcp (access gcp new))
+ (gls (access gls new))
+ (ls (access ls new))
+ (await-closed-demos (access await-closed-demos new))
+ (registered-callback-count (access registered-callback-count ffi))
+ (malloced-aliens (named-lambda (malloced-aliens)
+ (access malloced-aliens ffi))))
+
+ (define (run-test name thunk)
+ (let ((condition (ignore-errors thunk)))
+ (cond ((eq? condition #t)
+ (for-each display (list "; Test "name" succeeded.\n")))
+ ((condition? condition)
+ (for-each display (list "; Test "name" failed with error:\n"))
+ (write-condition-report condition (current-output-port))
+ (newline))
+ (else
+ (for-each display (list "; Test "name" returned "condition
+ ".\n"))))))
+
+ (define (assert = obj1 obj2 form)
+ (if (not (= obj1 obj2))
+ (error "Assertion failed:" form))
+ #t)
+
+ (run-test
+ 'gio-copy
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (gio-copy-test)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((file1 "../README.txt")
+ (file2 "test-copy-1.txt"))
+ (gcp file1 file2)
+ (assert equal? (md5-file file2) (md5-file file1)
+ `(GCP ,file1 ,file2))))))))
+
+ (run-test
+ 'gio-list
+ (let ((cwd (directory-pathname (current-load-pathname))))
+ (named-lambda (gio-list-test)
+ (with-working-directory-pathname cwd
+ (lambda ()
+ (let ((native (sort (ls "../runtime/") string<?))
+ (gio (sort (gls "../runtime/") string<?)))
+ (assert equal? gio native
+ '(GLS "../runtime/"))))))))
+
+ (run-test
+ 'gtk-demos
+ (named-lambda (gtk-demos-test)
+ (with-gc-notification! #t await-closed-demos)
+ #t))
+
+ (gc-flip)
+
+ (run-test
+ 'gtk-demos.callbacks
+ (named-lambda (gtk-demos.callbacks-test)
+ (assert = 0 (car (registered-callback-count))
+ '(REGISTERED-CALLBACK-COUNT))))
+
+ (run-test
+ 'gtk-demos.mallocs
+ (named-lambda (gtk-demos.mallocs-test)
+ (assert = 0 (length (malloced-aliens))
+ '(LENGTH (MALLOCED-ALIENS)))))))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2010, 2011, 2012 Matthew Birkholz
+Copyright (C) 2010, 2011, 2012, 2013 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
(named-lambda (test-copy-integrity)
(with-working-directory-pathname cwd
(lambda ()
- (let ((file1 "../../src/README.txt")
+ (let ((file1 "../README.txt")
(file2 "test-copy-1.txt"))
(gcp file1 file2)
(assert-equal (md5-file file2) (md5-file file1))))))))
(make-gtk-event-viewer-demo)
(make-fix-layout-demo)
(make-pole-zero)
- (make-tellurion)
(let loop ()
(if (not (null? (access toplevel-windows
(->environment '(gtk gtk-widget)))))
|#
-;;;; C declarations for gtk.so.
+;;;; C declarations for gtk-shim.so.
\f
(include "Includes/glib")
(include "Includes/glib-object")
/* SchemeSource -- the custom GSource that runs Scheme in an idle task. */
-#include "scheme.h"
-#include "option.h"
-#include "ux.h"
-#include "ossig.h"
-#include "osctty.h"
-#include "ostty.h"
-#include "ostop.h"
-#include "osio.h"
-#include "osenv.h"
-#include "osproc.h"
-#include "osscheme.h"
-#include "uxtrap.h"
-#include "uxsig.h"
-#include "uxutil.h"
-#include "critsec.h"
-
-#include <pthread.h>
-#include <glib.h>
+#include <mit-scheme.h>
#include <gtk/gtk.h>
-#define MIT_SCHEME /* Avoid re-declaring things included above. */
-#include "pruxffi.h"
-
+#include <glib.h>
+#include <math.h>
+#include <stdlib.h>
+
+/* Presumed externs/const of the Gtk-ready machine. */
+extern double OS_real_time_clock (void);
+extern int OS_process_any_status_change (void);
+extern int OS_select_registry_length (unsigned long registry);
+#define SELECT_MODE_READ 1
+#define SELECT_MODE_WRITE 2
+extern void OS_select_registry_entry (unsigned long registry,
+ int i, int *fd, unsigned int *mode);
+extern void OS_syserr_names (unsigned long *, const char ***);
+extern void Interpret (int pop_return_p);
extern void alienate_float_environment (void);
+extern void foreach_async_signal (void(*func)(int signo));
+extern void abort_to_c (void);
+extern int interrupts_p (void);
+
static void init_signal_handling (void);
struct _SchemeSource
static SchemeSource * scheme_source = NULL;
static gboolean tracing_gtk_select = 0;
static void trace (const char *format, ...);
-static gboolean interrupt_p (void);
-static GSList * gtk_registry (select_registry_t registry);
+static GSList * gtk_registry (unsigned long registry);
static int slice_counter = 0;
static GtkWidget * slice_window = NULL;
va_start (args, format);
if (tracing_gtk_select)
{
- voutf_console (format, args);
- outf_flush_console ();
+ vfprintf (stderr, format, args);
+ fflush (stderr);
}
va_end (args);
}
-static gboolean
-interrupt_p (void)
-{
- /* Ignores the INT_MASK, which is interrupt-mask/gc-ok per
- call-alien. That mask keeps callbacks from wandering onto other
- threads. Ignoring it allows the scheme_source to return to the
- gtk-thread, where call-alien will restore gtk-thread's mask,
- unmasking whatever interrupt was pending (assuming gtk-thread
- runs with all interrupts unmasked). */
-
- /* return (INTERRUPT_PENDING_P (INT_Mask)); */
- /* return (((PENDING_INTERRUPTS ()) & (INT_Mask)) != 0); */
- /* return ((((GET_INT_MASK & GET_INT_CODE)) & (INT_Mask)) != 0); */
- return (GET_INT_CODE);
-}
-
static gboolean
scheme_source_prepare (GSource * source, gint * timeout)
{
SchemeSource * src = (SchemeSource *)source;
if (src->runnable
- || interrupt_p ()
+ || interrupts_p ()
|| OS_process_any_status_change ())
{
trace (";scheme_source_prepare: ready (%s)\n",
src->runnable ? "thread"
- : interrupt_p () ? "interrupt"
+ : interrupts_p () ? "interrupt"
: "subprocess");
*timeout = 0;
return (TRUE);
if (src->time_limit == 0.0
|| src->runnable
- || interrupt_p ()
+ || interrupts_p ()
|| OS_process_any_status_change ()
|| pending_io (src))
{
trace (";scheme_source_check: ready (%s)\n",
src->runnable ? "thread"
- : interrupt_p () ? "interrupt"
+ : interrupts_p () ? "interrupt"
: OS_process_any_status_change () ? "subprocess"
: src->time_limit == 0.0 ? "" : "i/o");
return (TRUE);
GPollFD * gfd = scan->data;
if (gfd->revents != 0)
{
- outf_console (";scheme_source_check: i/o ready on %d\n",
- gfd->fd);
+ fprintf (stderr, ";scheme_source_check: i/o ready on %d\n",
+ gfd->fd);
}
scan = scan->next;
}
simulated poll should not re-enter Scheme until TIME. */
set_registry (scheme_source,
- gtk_registry ((select_registry_t)registry),
+ gtk_registry (registry),
time);
if (tracing_gtk_select)
{
GSList * gpollfds = scheme_source->gpollfds;
gchar * fdstr = gpollfds_string (gpollfds);
- outf_console (";run_gtk%s%s until %.1f\n",
- gpollfds == NULL ? "" : " waiting on", fdstr, time);
- outf_flush_console ();
+ fprintf (stderr, ";run_gtk%s%s until %.1f\n",
+ gpollfds == NULL ? "" : " waiting on", fdstr, time);
+ fflush (stderr);
if (fdstr[0] != '\0')
g_free (fdstr);
}
| ((((revents) & G_IO_HUP) != 0) ? SELECT_MODE_HUP : 0))
static GSList *
-gtk_registry (select_registry_t registry)
+gtk_registry (unsigned long registry)
{
/* Construct Gtk's version of a select_registry_t. */
itself running in the scheme_thread, it invokes the original
handler. */
-extern void OS_syserr_names (unsigned long * length, const char *** names);
+#include <signal.h>
+#include <pthread.h>
static const char * errno_name (int err);
static void complain (const char *format, ...);
static pthread_t scheme_thread;
-static GSList *old_handlers = NULL;
+static struct handler_record * old_handlers = NULL;
struct handler_record
{
int signo;
- Tsignal_handler handler;
+ void (*handler)(int, siginfo_t *, void *);
+ struct handler_record *next;
};
-Tsignal_handler_result
+void
signal_forwarder (int signo, siginfo_t *siginfo, void *ptr)
{
pthread_t self;
self = pthread_self ();
if (self == scheme_thread)
{
- GSList * scan;
+ struct handler_record * scan;
scan = old_handlers;
while (scan != NULL)
{
- struct handler_record * old = scan->data;
- if (old->signo == signo)
+ if (scan->signo == signo)
{
- trace ("signal_forwarder: running handler\n");
- (old->handler)(signo, siginfo, ptr);
+ (scan->handler)(signo, siginfo, ptr);
return;
}
scan = scan->next;
{
int err;
- trace (";signal_forwarder: forwarding signo %d\n", signo);
err = pthread_kill (scheme_thread, signo);
if (err != 0)
{
}
}
-void
+static void
init_signal_forwarder (int signo)
{
int err;
struct handler_record *hrec;
- Tsignal_handler handler;
struct sigaction act;
err = sigaction (signo, 0, (&act));
if (err != 0)
- complain ("init_signal_forwarder: sigaction access failed\n");
- handler = act.sa_sigaction;
- if ((handler == ((Tsignal_handler) SIG_DFL))
- || (handler == (Tsignal_handler) SIG_IGN))
+ {
+ complain ("init_signal_forwarder: sigaction access failed\n");
+ return;
+ }
+
+ if (((act.sa_flags & SA_SIGINFO) == 0)
+ && ((act.sa_handler == SIG_DFL)
+ || (act.sa_handler == SIG_IGN)))
return;
- act.sa_sigaction = &signal_forwarder;
+ if ((act.sa_flags & SA_SIGINFO) == 0)
+ {
+ complain ("init_signal_forwarder: no SA_SIGINFO\n");
+ return;
+ }
+ hrec = malloc (sizeof (struct handler_record));
+ if (hrec == NULL)
+ {
+ complain ("init_signal_forwarder: malloc failed\n");
+ return;
+ }
+ hrec->signo = signo;
+ hrec->handler = act.sa_sigaction;
+ hrec->next = old_handlers;
+ act.sa_sigaction = &signal_forwarder;
err = sigaction (signo, &act, 0);
if (err != 0)
complain ("init_signal_forwarder: sigaction modify failed\n");
-
- hrec = g_malloc (sizeof (struct handler_record));
- hrec->signo = signo;
- hrec->handler = handler;
- old_handlers = g_slist_prepend (old_handlers, hrec);
+ old_handlers = hrec;
}
-void
+static void
init_signal_handling (void)
{
scheme_thread = pthread_self ();
{
va_list args;
va_start (args, format);
- voutf_console (format, args);
- outf_flush_console ();
+ vfprintf (stderr, format, args);
+ fflush (stderr);
va_end (args);
}
(ld 'SUBPROCESS) ;; Hacked in main.scm.
(ld 'SOS)
(ld 'FFI) ;; Referenced in gtk.pkg.
- (with-loader-base-uri
- (system-library-uri "gtk/")
- (lambda ()
- (load-package-set "gtk"))))
+ (load-package-set "gtk"))
(add-subsystem-identification! "Gtk" '(0 4))
((access gtk-start (->environment '(gtk main))))))
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;Demo of DT frequency response by frobbing poles and zeros
+
+(define half-window-size 200)
+(define zero-size 5)
+(define pole-size 4)
+(define trim 10)
+(define zero-color "violetred")
+(define pole-color "blue")
+(define canvas-color "white")
+(define text-font "CourR12")
+
+
+(define symbol-font
+ "-adobe-symbol-medium-r-normal--14-100-100-100-p-85-adobe-fontspecific")
+
+(define tracking-coords? #F)
+(define time-to-update-plot? #F)
+(define LOCATION 'later) ; active variable
+(define all-zeros '()) ; alist of zeros(objects)/coords
+(define all-poles '()) ; alist of poles(objects)/coords
+
+(define number-of-points 100)
+(define max-w 3.14159)
+
+;;hack to print numbers to three decimals
+(define (unsigned->string n)
+ (let* ((int-part (floor n))
+ (frac-part (- n int-part))
+ (dec (floor->exact (* frac-part 1000)))
+ (string-dec (number->string dec))
+ (padded-string-dec
+ (cond ((< dec 10) (string-append "00" string-dec))
+ ((< dec 100) (string-append "0" string-dec))
+ (else string-dec))))
+ (string-append (number->string (floor->exact int-part))
+ "."
+ padded-string-dec)))
+
+(define (our-cx->string z)
+ (let* ((r (real-part z))
+ (i (imag-part z))
+ (rs (unsigned->string (abs r)))
+ (is (unsigned->string (abs i)))
+ (signed-r
+ (if (< r 0)
+ (string-append "-" rs)
+ rs))
+ (signed-i
+ (if (< i 0)
+ (string-append "-" is)
+ (string-append "+" is))))
+ (string-append signed-r signed-i "j")))
+
+(define (our-real->string r)
+ (let* ((rs (unsigned->string (abs r)))
+ (signed-r
+ (if (< r 0)
+ (string-append "-" rs)
+ rs)))
+ signed-r))
+
+
+(define (z->canvas-coords z)
+ (let ((x (real-part z))
+ (y (imag-part z)))
+ (list
+ (round->exact
+ (+ (* x (- half-window-size (* 2 trim)))
+ half-window-size))
+ (round->exact
+ (+ (* y (- (* 2 trim) half-window-size))
+ half-window-size)))))
+
+(define (canvas-coords->z xy)
+ (let ((x (exact->inexact (car xy)))
+ (y (exact->inexact (cadr xy))))
+ (let ((real (/ (- x half-window-size)
+ (- half-window-size (* 2 trim))))
+ (imag (/ (- y half-window-size)
+ (- (* 2 trim) half-window-size))))
+ (+ real (* imag +i)))))
+
+;;; Pole/Zero Movement
+(define (move-with-conjugate-pair pole-zero obj1 obj2)
+ (let ((last-x 'later)
+ (last-y 'later))
+ (define (keep-track-of-coords x y)
+ (set! last-x x)
+ (set! last-y y)
+ (if tracking-coords?
+ (let ((z (canvas-coords->z (list last-x last-y))))
+ (set-active-variable! LOCATION (our-cx->string z)))))
+ (define (store-coords)
+ (let* ((zero-entry (assq obj1 all-zeros))
+ (obj1-entry
+ (if zero-entry zero-entry (assq obj1 all-poles)))
+ (obj2-entry
+ (if zero-entry
+ (assq obj2 all-zeros)
+ (assq obj2 all-poles)))
+ (z (canvas-coords->z (list last-x last-y))))
+ (set-cdr! obj1-entry z)
+ (set-cdr! obj2-entry (conjugate z))))
+ (add-event-handler!
+ obj1
+ "<ButtonPress-1>"
+ (lambda (x y)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x y))
+ "%x" "%y")
+ (add-event-handler!
+ obj1
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj1
+ "<B1-Motion>"
+ (lambda (x y)
+ (ask-widget obj1 `(move ,(- x last-x) ,(- y last-y)))
+ (ask-widget obj2 `(move ,(- x last-x) ,(- last-y y)))
+ (keep-track-of-coords x y))
+ "%x" "%y")))
+
+(define (move-by-itself pole-zero obj)
+ (let ((last-x 'later))
+ (define (keep-track-of-coords x)
+ (set! last-x x)
+ (let ((z (canvas-coords->z (list last-x half-window-size))))
+ (if tracking-coords?
+ (set-active-variable! LOCATION (our-real->string z)))))
+ (define (store-coords)
+ (let ((entry
+ (let ((zero (assq obj all-zeros)))
+ (if zero zero (assq obj all-poles))))
+ (z (real-part (canvas-coords->z (list last-x 0)))))
+ (set-cdr! entry z)))
+ (add-event-handler!
+ obj
+ "<ButtonPress-1>"
+ (lambda (x)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x))
+ "%x")
+ (add-event-handler!
+ obj
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj
+ "<B1-Motion>"
+ (lambda (x)
+ (ask-widget obj `(move ,(- x last-x) 0))
+ (keep-track-of-coords x))
+ "%x")))
+
+
+;;; This isn't quite right. Time-to-update-plot? might be set to #F
+;;; and then back to #T inside the 2 sec interval, so the update will
+;;; come too soon.
+(define (maybe-update-plot graph-canvas)
+ (set! time-to-update-plot? #T)
+ (after-delay
+ 2
+ (lambda ()
+ (if time-to-update-plot?
+ (plot-pole-zero graph-canvas)))))
+
+
+;;; Zeros
+(define (make-zero canvas xy)
+ (let ((x (car xy))
+ (y (cadr xy)))
+ (let ((zero
+ (make-oval-on-canvas canvas
+ (- x zero-size) (- y zero-size)
+ (+ x zero-size) (+ y zero-size))))
+ (set! all-zeros (cons (cons zero (canvas-coords->z xy))
+ all-zeros))
+ (ask-widget zero `(configure -outline ,zero-color -fill ,canvas-color -width 2))
+ zero)))
+
+(define (make-single-zero pole-zero x)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((z (make-zero canvas (list x half-window-size))))
+ (move-by-itself pole-zero z)
+ z)))
+
+(define (make-zero-pair pole-zero x y)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((zero (canvas-coords->z (list x y))))
+ (let ((other-pos
+ (z->canvas-coords (conjugate zero))))
+ (let ((z1 (make-zero canvas (list x y)))
+ (z2 (make-zero canvas other-pos)))
+ (move-with-conjugate-pair pole-zero z1 z2)
+ (move-with-conjugate-pair pole-zero z2 z1))))))
+
+
+;;; Poles
+(define (make-pole canvas xy)
+ (let ((x (car xy))
+ (y (cadr xy)))
+ (let* ((line1
+ (make-line-on-canvas canvas
+ (- x pole-size) (- y pole-size)
+ (+ x pole-size) (+ y pole-size)))
+ (line2
+ (make-line-on-canvas canvas
+ (- x pole-size) (+ y pole-size)
+ (+ x pole-size) (- y pole-size)))
+ (pole (make-canvas-item-group canvas (list line1 line2))))
+ (set! all-poles (cons (cons pole (canvas-coords->z xy))
+ all-poles))
+ (ask-widget pole `(configure -fill ,pole-color -width 2))
+ pole)))
+
+(define (make-single-pole pole-zero x)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((p (make-pole canvas (list x half-window-size))))
+ (move-by-itself pole-zero p)
+ p)))
+
+(define (make-pole-pair pole-zero x y)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((pole (canvas-coords->z (list x y))))
+ (let ((other-pos
+ (z->canvas-coords (conjugate pole))))
+ (let ((p1 (make-pole canvas (list x y)))
+ (p2 (make-pole canvas other-pos)))
+ (move-with-conjugate-pair pole-zero p1 p2)
+ (move-with-conjugate-pair pole-zero p2 p1))))))
+
+;;; Button that switches from one label to another
+
+(define (make-switch color to-switch)
+ ;;to-switch is list ((text command) (text command))
+ (let ((n (length to-switch))
+ (button (make-button))
+ (state #F))
+ (define (switch-to-state i)
+ (set! state i)
+ ((cadr (list-ref to-switch i)))
+ (ask-widget button `(configure -text ,(car (list-ref to-switch i)))))
+ (ask-widget button `(configure -background ,color))
+ (switch-to-state 0)
+ (set-callback! button
+ (lambda ()
+ (switch-to-state (modulo (+ state 1) n))))
+ button))
+
+;;; Demo
+(define (make-pole-zero)
+ (set! all-zeros '())
+ (set! all-poles '())
+ (let ((diagram-canvas (make-canvas `(-width ,(* 2 half-window-size)
+ -height ,(* 2 half-window-size))))
+ (graph-canvas #F)
+ (pz 'later)
+ (shape-size 'later)
+ (single-maker 'later)
+ (pair-maker 'later))
+
+ (define (switch-to-zeros)
+ (set! shape-size zero-size)
+ (set! single-maker make-single-zero)
+ (set! pair-maker make-zero-pair))
+
+ (define (switch-to-poles)
+ (set! shape-size pole-size)
+ (set! single-maker make-single-pole)
+ (set! pair-maker make-pole-pair))
+
+ (let* ((maker-button (make-switch "yellow"
+ `(("Zeros" ,switch-to-zeros)
+ ("Poles" ,switch-to-poles))))
+ (clear-button (make-button '(-text "Clear")))
+ (show-coords? (make-active-variable))
+ (coords-button
+ (make-checkbutton `(-text "Show Coords?" -variable ,show-coords?)))
+ (coords-display (make-label))
+ (plot-button (make-button '(-text "Plot"))))
+
+ (set! LOCATION (make-active-variable))
+ (ask-widget coords-display `(configure -width 13 -background ,canvas-color
+ -relief sunken -textvariable ,LOCATION
+ -font ,text-font))
+ (for-each (lambda (b)
+ (ask-widget b `(configure -background "yellow" -font ,text-font)))
+ (list maker-button clear-button coords-button plot-button))
+ (ask-widget diagram-canvas `(configure -background ,canvas-color))
+ (on-death! diagram-canvas 'little-brother-canvas
+ (lambda () (if graph-canvas (swat-close graph-canvas))))
+
+ (set-callback!
+ clear-button
+ (lambda ()
+ (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
+ all-zeros)
+ (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
+ all-poles)
+ (set-active-variable! LOCATION "")
+ (cond (graph-canvas
+ (ask-widget graph-canvas '(delete all))
+ (draw-axes graph-canvas)))
+ (set! all-zeros '())
+ (set! all-poles '())))
+
+ (set-callback!
+ coords-button
+ (lambda ()
+ (if (checkbutton-variable-on? show-coords?)
+ (set! tracking-coords? #T)
+ (begin
+ (set-active-variable! LOCATION "")
+ (set! tracking-coords? #F)))))
+ (set-callback!
+ plot-button
+ (lambda ()
+ (cond ((not graph-canvas)
+ (set! graph-canvas
+ (make-canvas `(-width ,(* 2 half-window-size)
+ -height ,(* 2 half-window-size))))
+ (ask-widget graph-canvas `(configure -background ,canvas-color))
+ (swat-open graph-canvas '-title "Magnitude of Frequency Response")
+ (on-death! graph-canvas 'big-brother-canvas
+ (lambda () (set! graph-canvas #F)))))
+ (plot-pole-zero graph-canvas)))
+ (add-event-handler!
+ diagram-canvas
+ "<Double-ButtonPress-1>"
+ (lambda (x y)
+ (set! time-to-update-plot? #F)
+ (if (< (abs (- y half-window-size)) shape-size)
+ (single-maker pz x)
+ (pair-maker pz x y)))
+ "%x" "%y")
+
+ (let ((me (make-vbox diagram-canvas
+ (make-hbox maker-button clear-button coords-button
+ coords-display plot-button))))
+ (swat-open me '-title "Pole-Zero Diagram")
+ (let ((x-axis (make-line-on-canvas
+ diagram-canvas
+ trim half-window-size
+ (- (* 2 half-window-size) trim) half-window-size))
+ (y-axis (make-line-on-canvas
+ diagram-canvas
+ half-window-size trim
+ half-window-size (- (* 2 half-window-size) trim)))
+ (unit-circle (make-oval-on-canvas
+ diagram-canvas
+ (* 2 trim) (* 2 trim)
+ (* 2 (- half-window-size trim))
+ (* 2 (- half-window-size trim)))))
+ (ask-widget x-axis '(configure -arrow last))
+ (ask-widget y-axis '(configure -arrow first))
+ (ask-widget unit-circle '(configure -outline "gray")))
+
+ (set! pz
+ (lambda (message)
+ (case message
+ ((graph-canvas) graph-canvas)
+ ((diagram-canvas) diagram-canvas)
+ ((add-zero)
+ (lambda (z)
+ (let ((xy (z->canvas-coords z)))
+ (if (= (imag-part z) 0)
+ (make-single-zero pz (car xy))
+ (make-zero-pair pz (car xy) (cadr xy))))))
+ ((add-pole)
+ (lambda (p)
+ (let ((xy (z->canvas-coords p)))
+ (if (= (imag-part p) 0)
+ (make-single-pole pz (car xy))
+ (make-pole-pair pz (car xy) (cadr xy))))))
+ (else "Unknown message -- MAKE-POLE-ZERO" message))))
+ pz))))
+
+
+(define (add-butterworth-poles pole-zero-diagram n)
+ (define pi (* (atan 1 1) 4))
+ (define (make-index-list n start)
+ (if (> start n)
+ '()
+ (cons start (make-index-list n (+ start 1)))))
+ (let ((index-list (make-index-list n (+ (ceiling->exact (/ n 2)) 1)))
+ (w (exp (/ (* 2 +i pi) (* 2 n)))))
+ (for-each (lambda (pole)
+ ((pole-zero-diagram 'add-pole) pole))
+ (map (lambda (s)
+ (let ((t 1))
+ (/ (+ 1 (* (/ t 2) s))
+ (- 1 (* (/ t 2) s)))))
+ (map (lambda (k) (expt w (- k .5)))
+ index-list)))
+ (let loop ((z 1))
+ (if (> z n)
+ 'done
+ (begin ((pole-zero-diagram 'add-zero) -1)
+ (loop (1+ z)))))
+ (plot-pole-zero (pole-zero-diagram 'graph-canvas))))
+
+
+(define (plot-pole-zero graph-canvas)
+ (cond (graph-canvas
+ (ask-widget graph-canvas '(delete all))
+ (draw-axes graph-canvas)
+ (plot-magnitude graph-canvas))))
+
+(define (plot-magnitude graph-canvas)
+ (let ((zero-locations (map cdr all-zeros))
+ (pole-locations (map cdr all-poles)))
+ (let ((fcn
+ (lambda (x)
+ (let ((jw (exp (* x +i))))
+ (let ((numer
+ (apply * (map (lambda (z) (magnitude (- jw z)))
+ zero-locations)))
+ (denom
+ (apply * (map (lambda (z) (magnitude (- jw z)))
+ pole-locations))))
+ (if (< denom 1.e-10)
+ 1.e5
+ (/ numer denom)))))))
+ (plot-graph-on-canvas
+ graph-canvas
+ (let loop ((index 0) (points '()))
+ (if (> index number-of-points)
+ points
+ (let ((w (* index (/ max-w number-of-points))))
+ (loop (+ index 1)
+ (cons (cons w (fcn w)) points)))))))))
+
+(define (plot-graph-on-canvas canvas graph)
+ (let* ((maxval (apply max (map cdr graph)))
+ (canvas-points
+ (map (lambda (graph-point)
+ (magnitude-coords->canvas-coords graph-point maxval))
+ graph)))
+ (let loop ((rest-points (cdr canvas-points))
+ (this-point (car canvas-points)))
+ (if (null? rest-points)
+ 'done
+ (let ((next-point (car rest-points)))
+ (make-line-on-canvas canvas
+ (car this-point)
+ (cdr this-point)
+ (car next-point)
+ (cdr next-point))
+ (loop (cdr rest-points)
+ (car rest-points)))))
+ (let ((maxval-display
+ (make-text-on-canvas
+ canvas (* 3 trim) (* 2 trim) `(-text ,(our-real->string maxval)))))
+ (ask-widget maxval-display
+ `(configure -anchor sw -font ,symbol-font)))))
+
+
+(define (magnitude-coords->canvas-coords xy max-mag)
+ (let ((x (car xy))
+ (y (cdr xy)))
+ (cons (round->exact (+ (* x (/ (- (* 2 half-window-size) (* 4 trim)) max-w))
+ (* 2 trim)))
+ (round->exact (+ (* y (/ (- (* 4 trim) (* 2 half-window-size)) max-mag))
+ (* 2 (- half-window-size trim)))))))
+
+
+(define (draw-axes graph-canvas)
+ (let ((x-axis (make-line-on-canvas
+ graph-canvas
+ trim (* 2 (- half-window-size trim))
+ (- (* 2 half-window-size) trim)
+ (* 2 (- half-window-size trim))))
+ (y-axis (make-line-on-canvas
+ graph-canvas
+ (* 2 trim) trim
+ (* 2 trim) (- (* 2 half-window-size) trim)))
+ (pi (make-text-on-canvas
+ graph-canvas
+ (* 2 (- half-window-size trim)) (- (* 2 half-window-size) trim)
+ '(-text "p"))))
+ (ask-widget x-axis '(configure -arrow last))
+ (ask-widget y-axis '(configure -arrow first))
+ (ask-widget pi `(configure -anchor e -font ,symbol-font))))
+
install:
$(mkinstalldirs) $(DESTDIR)$(IMAIL_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(IMAIL_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(IMAIL_DIR)/.
- $(INSTALL_DATA) imail-unx.pkd $(DESTDIR)$(IMAIL_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(IMAIL_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(IMAIL_DIR)/.
--- /dev/null
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+# Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+all: md5-shim.so md5-types.bin md5-const.bin
+ echo '(load "compile")' | $(EXE)
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install:
+ echo '(install-shim "md5")' | $(EXE) -- *.com *.bci *.pkd make.scm
+
+clean:
+ rm -f md5-const.scm md5-const md5-const.c md5-shim.c
+ rm -f md5-*.crf md5-*.fre md5-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f sample
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+md5-shim.so: md5-shim.o md5-adapter.o
+ echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS)
+
+md5-adapter.o: md5-adapter.c md5-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+md5-shim.o: md5-shim.c md5-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+md5-shim.c md5-const.c md5-types.bin: md5.cdecl md5-shim.h
+ echo '(generate-shim "md5" "#include \"md5-shim.h\"")' | $(EXE)
+
+md5-const.bin: md5-const.scm
+ echo '(sf "md5-const")' | $(EXE)
+
+md5-const.scm: md5-const
+ ./md5-const
+
+md5-const: md5-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+md5-const.o: md5-const.c md5-shim.h
+ $(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+.PHONY: all check install clean distclean maintainer-clean
--- /dev/null
+The md5 wrapper.
+
+This is a drop-in replacement for the md5 microcode module and the
+md5-* procedures in runtime/crypto.scm. It is not part of the core
+build and can be built outside the core build tree in the customary
+way:
+
+ ./configure [--with-openssl=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path. You can override the default
+command name "mit-scheme" (and thus the system library path) by
+setting MIT_SCHEME_EXE.
+
+To load via load-option, install the following in your optiondb.scm:
+
+ (define-load-option 'MD5
+ (guarded-system-loader '(md5) "md5"))
+
+You will need to import the bindings you want to use. They are not
+exported to the global environment because they would conflict with
+the exports from (runtime crypto).
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the MD5 wrapper.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "md5-check" (->environment '(md5)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Compile the MD5 wrapper.
+
+(fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'CREF)
+ (load-option 'FFI))
+
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (compile-system "md5" (directory-pathname (current-load-pathname)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme md5 interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-md5])
+AC_CONFIG_SRCDIR([md5.pkg])
+AC_CONFIG_HEADERS([config.h])
+
+AC_COPYRIGHT(
+[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+])
+
+AH_TOP([/*
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/])
+
+AC_ARG_WITH([openssl],
+ AS_HELP_STRING([--with-openssl],
+ [Use OpenSSL crypto library if available [[yes]]]))
+: ${with_openssl='yes'}
+
+dnl The OpenSSL crypto library provides support for md5.
+if test "${with_openssl}" != no; then
+ if test "${with_openssl}" != yes; then
+ CPPFLAGS="${CPPFLAGS} -I${with_openssl}/include"
+ LDFLAGS="${LDFLAGS} -L${with_openssl}/lib"
+ fi
+ FOUND=
+ AC_CHECK_HEADERS([openssl/md5.h md5.h],[FOUND=yes])
+ if test -n "${FOUND}"; then
+ AC_CHECK_LIB([crypto], [BF_set_key],
+ [
+ AC_DEFINE([HAVE_LIBCRYPTO], [1],
+ [Define to 1 if you have the `crypto' library (-lcrypto).])
+ LIBS="-lcrypto"
+ ])
+ fi
+fi
+
+AC_SUBST([LIBS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Load the MD5 option.
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "md5")))
+
+(add-subsystem-identification! "MD5" '(0 1))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Adapters for the MD5 crypto-hash library. */
+
+#include "md5-shim.h"
+
+extern void
+do_MD5 (unsigned char * string, int length, unsigned char * result)
+{
+ MD5_CTX context;
+
+ MD5_INIT (&context);
+ MD5_UPDATE (&context, string, length);
+#ifdef HAVE_LIBCRYPTO
+ MD5_FINAL (result, &context);
+#else
+ MD5_FINAL (&context);
+ memcpy (result, context.digest, MD5_DIGEST_LENGTH);
+#endif
+}
+
+extern void
+do_MD5_UPDATE (MD5_CTX *context, unsigned char *string, int start, int end)
+{
+ MD5_UPDATE (context, string + start, end - start);
+}
+
+extern void
+do_MD5_FINAL (MD5_CTX *context, unsigned char *result)
+{
+#ifdef HAVE_LIBCRYPTO
+ MD5_FINAL (result, context);
+#else
+ MD5_FINAL (context);
+ memcpy (result, context->digest, MD5_DIGEST_LENGTH);
+#endif
+}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the MD5 wrapper.
+
+(if (not (md5-available?))
+ (warn "md5 wrapper not found")
+ (let ((sample "Some text to hash."))
+ (let ((hash (md5-sum->hexadecimal (md5-string sample))))
+ (if (not (string=? hash "c8e89c4cbf3abf9aa758d691cbe4b784"))
+ (error "Bad hash for sample text:" hash)))
+ (call-with-output-file "sample"
+ (lambda (port) (write-string sample port) (newline port)))
+ (let ((hash (md5-sum->hexadecimal (md5-file "sample"))))
+ (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
+ (error "Bad hash for sample file:" hash)))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Interface to the MD5 crypto-hash library. */
+
+#include "config.h"
+
+#if defined(HAVE_LIBCRYPTO) && defined(HAVE_OPENSSL_MD5_H)
+# include <openssl/md5.h>
+#else
+# ifdef HAVE_MD5_H
+# include <md5.h>
+# endif
+#endif
+
+#ifdef HAVE_LIBCRYPTO
+# define MD5_INIT MD5_Init
+# define MD5_UPDATE MD5_Update
+# define MD5_FINAL MD5_Final
+#else
+# define MD5_INIT MD5Init
+# define MD5_UPDATE MD5Update
+# define MD5_FINAL MD5Final
+# define MD5_DIGEST_LENGTH 16
+#endif
+
+extern void do_MD5 (unsigned char * string, int length, unsigned char * result);
+extern void do_MD5_UPDATE (MD5_CTX *context,
+ unsigned char *string, int start, int end);
+extern void do_MD5_FINAL (MD5_CTX *context, unsigned char *result);
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for md5-shim.so.
+\f
+(enum (MD5_DIGEST_LENGTH))
+
+(typedef MD5_CTX
+ (struct MD5state_st
+ ;; mumble
+ (num uint)))
+
+(extern int MD5_INIT
+ (c (* MD5_CTX)))
+
+(extern void do_MD5
+ (string (* uchar))
+ (length int)
+ (result (* uchar)))
+
+(extern void do_MD5_UPDATE
+ (context (* MD5_CTX))
+ (string (* uchar))
+ (start int)
+ (end int))
+
+(extern void do_MD5_FINAL
+ (context (* MD5_CTX))
+ (result (* uchar)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(global-definitions runtime/)
+
+(define-package (md5)
+ (files "md5")
+ (parent ())
+ ;; You'll have to import these from (global-definitions md5/). They
+ ;; are currently bound in () by exports from (runtime crypto).
+ #;(export #f
+ md5-available?
+ md5-file
+ md5-string
+ md5-substring
+ md5-sum->hexadecimal
+ md5-sum->number))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; MD5 wrapper
+;;; package: (md5)
+
+(declare (usual-integrations))
+\f
+(C-include "md5")
+
+(define-integrable (mhash-available?) #f)
+
+(define (%md5-init)
+ ;; Create and return an MD5 digest context.
+ (let ((context (make-string (C-sizeof "MD5_CTX"))))
+ (C-call "MD5_INIT" context)
+ context))
+
+(define (%md5-update context string start end)
+ ;; Update CONTEXT with the contents of the substring (STRING,START,END).
+ (guarantee-md5-context context '%MD5-UPDATE)
+ (guarantee-substring string start end '%MD5-UPDATE)
+ (C-call "do_MD5_UPDATE" context string start end))
+
+(define (%md5-final context)
+ ;; Finalize CONTEXT and return the digest as a 16-byte string.
+ (guarantee-md5-context context '%MD5-FINAL)
+ (let ((result (make-string (C-enum "MD5_DIGEST_LENGTH"))))
+ (C-call "do_MD5_FINAL" context result)
+ result))
+
+(define (guarantee-md5-context object operator)
+ (if (and (string? object)
+ (= (string-length object) (C-sizeof "MD5_CTX")))
+ object
+ (error:bad-range-argument object
+ "an MD5 context"
+ operator)))
+
+(define (%md5 string)
+ ;; Generate an MD5 digest of string.
+ ;; The digest is returned as a 16-byte string.
+ (guarantee-string string '%MD5)
+ (let ((length (string-length string))
+ (result (make-string (C-enum "MD5_DIGEST_LENGTH"))))
+ (C-call "do_MD5" string length result)
+ result))
+
+(define (md5-available?)
+ (or (mhash-available?)
+ (%md5-available?)))
+
+(define (%md5-available?)
+ (let ((path (ignore-errors (lambda ()
+ (system-library-pathname "md5-shim.so")))))
+ (and (pathname? path)
+ (file-loadable? path))))
+
+(define (md5-file filename)
+ (cond ((mhash-available?)
+ (mhash-file 'MD5 filename))
+ ((%md5-available?)
+ (%md5-file filename))
+ (else
+ (error "This Scheme system was built without MD5 support."))))
+
+(define (%md5-file filename)
+ (call-with-binary-input-file filename
+ (lambda (port)
+ (let ((buffer (make-string 4096))
+ (context (%md5-init)))
+ (dynamic-wind (lambda ()
+ unspecific)
+ (lambda ()
+ (let loop ()
+ (let ((n (read-substring! buffer 0 4096 port)))
+ (if (fix:= 0 n)
+ (%md5-final context)
+ (begin
+ (%md5-update context buffer 0 n)
+ (loop))))))
+ (lambda ()
+ (string-fill! buffer #\NUL)))))))
+
+(define (md5-string string)
+ (md5-substring string 0 (string-length string)))
+
+(define (md5-substring string start end)
+ (cond ((mhash-available?)
+ (mhash-substring 'MD5 string start end))
+ ((%md5-available?)
+ (%md5-substring string start end))
+ (else
+ (error "This Scheme system was built without MD5 support."))))
+
+(define (%md5-substring string start end)
+ (let ((context (%md5-init)))
+ (%md5-update context string start end)
+ (%md5-final context)))
+
+(define (md5-sum->number sum)
+ (let ((l (string-length sum)))
+ (do ((i 0 (fix:+ i 1))
+ (n 0 (+ (* n #x100) (vector-8b-ref sum i))))
+ ((fix:= i l) n))))
+
+(define (md5-sum->hexadecimal sum)
+ (let ((n (string-length sum))
+ (digits "0123456789abcdef"))
+ (let ((s (make-string (fix:* 2 n))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (string-set! s (fix:* 2 i)
+ (string-ref digits
+ (fix:lsh (vector-8b-ref sum i) -4)))
+ (string-set! s (fix:+ (fix:* 2 i) 1)
+ (string-ref digits
+ (fix:and (vector-8b-ref sum i) #x0F))))
+ s)))
\ No newline at end of file
--- /dev/null
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+# Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+MIT_SCHEME_EXE = mit-scheme
+EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+
+CFLAGS = @CFLAGS@
+CPPFLAGS = @CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBS = @LIBS@
+
+all: mhash-shim.so mhash-types.bin mhash-const.bin
+ echo '(load "compile")' | $(EXE)
+
+check:
+ echo '(load "check")' | $(EXE)
+
+install:
+ echo '(install-shim "mhash")' | $(EXE) -- *.com *.bci *.pkd make.scm
+
+clean:
+ rm -f mhash-const.scm mhash-const mhash-const.c mhash-shim.c
+ rm -f mhash-*.crf mhash-*.fre mhash-*.pkd
+ rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
+ rm -f sample
+
+distclean: clean
+ rm -f Makefile config.h config.log config.status
+
+maintainer-clean: distclean
+ rm -f configure config.h.in
+ rm -rf autom4te.cache
+
+mhash-shim.so: mhash-shim.o mhash-adapter.o
+ echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS)
+
+mhash-adapter.o: mhash-adapter.c mhash-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+mhash-shim.o: mhash-shim.c mhash-shim.h
+ echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $<
+
+mhash-shim.c mhash-const.c mhash-types.bin: mhash.cdecl mhash-shim.h
+ echo '(generate-shim "mhash" "#include \"mhash-shim.h\"")' | $(EXE)
+
+mhash-const.bin: mhash-const.scm
+ echo '(sf "mhash-const")' | $(EXE)
+
+mhash-const.scm: mhash-const
+ ./mhash-const
+
+mhash-const: mhash-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+mhash-const.o: mhash-const.c mhash-shim.h
+ $(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+.PHONY: all check install clean distclean maintainer-clean
--- /dev/null
+The mhash wrapper.
+
+This is a drop-in replacement for the mhash microcode module and the
+mhash-* procedures in runtime/crypto.scm. It is not part of the core
+build and can be built outside the core build tree in the customary
+way:
+
+ ./configure [--with-mhash=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
+files into the system library path. You can override the default
+command name "mit-scheme" (and thus the system library path) by
+setting MIT_SCHEME_EXE.
+
+To load via load-option, install the following in your optiondb.scm:
+
+ (define-load-option 'MHASH
+ (guarded-system-loader '(mhash) "mhash"))
+
+You will need to import the bindings you want to use. They are not
+exported to the global environment because they would conflict with
+the exports from (runtime crypto).
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the mhash wrapper.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "mhash-check" (->environment '(mhash)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Compile the mhash wrapper.
+
+(fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'CREF)
+ (load-option 'FFI))
+
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (compile-system "mhash" (directory-pathname (current-load-pathname)))))
\ No newline at end of file
--- /dev/null
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT([MIT/GNU Scheme mhash interface],
+ [0.1],
+ [bug-mit-scheme@gnu.org],
+ [mit-scheme-mhash])
+AC_CONFIG_SRCDIR([mhash.pkg])
+AC_CONFIG_HEADERS([config.h])
+
+AC_COPYRIGHT(
+[Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+])
+
+AH_TOP([/*
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/])
+
+AC_ARG_WITH([mhash],
+ AS_HELP_STRING([--with-mhash],
+ [Use mhash library if available [[yes]]]))
+: ${with_mhash='yes'}
+
+if test "${with_mhash}" != no; then
+ if test "${with_mhash}" != yes; then
+ CPPFLAGS="${CPPFLAGS} -I${with_mhash}/include"
+ LDFLAGS="${LDFLAGS} -L${with_mhash}/lib"
+ fi
+ AC_CHECK_HEADER([mhash.h],[
+ AC_DEFINE([HAVE_MHASH_H], [1],
+ [Define to 1 if you have the <mhash.h> header file.])
+ AC_CHECK_LIB([mhash], [mhash_count],[
+ AC_DEFINE([HAVE_LIBMHASH], [1],
+ [Define to 1 if you have the `mhash' library (-lmhash).])
+ LIBS="-lmhash"
+ ])
+ ])
+fi
+
+AC_SUBST([LIBS])
+AC_SUBST([CPPFLAGS])
+AC_SUBST([LDFLAGS])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Load the mhash option.
+
+(with-working-directory-pathname (directory-pathname (current-load-pathname))
+ (lambda ()
+ (load-package-set "mhash")))
+
+(add-subsystem-identification! "mhash" '(0 1))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Adapters for the mhash crypto-hash library. */
+
+#include "mhash-shim.h"
+
+extern void
+do_mhash (MHASH thread, const char *string, int start, int end)
+{
+ mhash (thread, string + start, end - start);
+}
+
+extern void
+do_mhash_end (MHASH context, char *string, size_t size)
+{
+ void * digest = mhash_end (context);
+ memcpy (string, digest, size);
+ free (digest);
+}
+
+extern void
+do_mhash_hmac_end (MHASH context, char *string, size_t size)
+{
+ void * digest = mhash_hmac_end (context);
+ memcpy (string, digest, size);
+ free (digest);
+}
+
+extern int
+do_mhash_keygen (keygenid algorithm,
+ hashid hashid1, hashid hashid2,
+ int count,
+ void *salt, int salt_size,
+ char *keyword, int keysize,
+ unsigned char *password, int passwordlen)
+{
+ KEYGEN keygen;
+
+ keygen.hash_algorithm[0] = hashid1;
+ keygen.hash_algorithm[1] = hashid2;
+ keygen.count = count;
+ keygen.salt = salt;
+ keygen.salt_size = salt_size;
+
+ return (mhash_keygen_ext (algorithm, keygen,
+ keyword, keysize,
+ password, passwordlen));
+}
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the mhash wrapper.
+
+(if (not (mhash-available?))
+ (warn "mhash wrapper not found")
+ (let ((sample "Some text to hash."))
+ (let ((hash (mhash-sum->hexadecimal (mhash-string 'MD5 sample))))
+ (if (not (string=? hash "c8e89c4cbf3abf9aa758d691cbe4b784"))
+ (error "Bad hash for sample text:" hash)))
+ (call-with-output-file "sample"
+ (lambda (port) (write-string sample port) (newline port)))
+ (let ((hash (mhash-sum->hexadecimal (mhash-file 'MD5 "sample"))))
+ (if (not (string=? hash "43eb9eccb88c329721925efc04843af1"))
+ (error "Bad hash for sample file:" hash)))))
\ No newline at end of file
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Interface to the mhash crypto-hash library. */
+
+#include "config.h"
+
+/* If mhash.h unavailable, ignore it. This helps
+ "makegen/makegen.scm" work properly on systems lacking this
+ library. */
+#ifdef HAVE_MHASH_H
+# include <mhash.h>
+#endif
+
+extern void do_mhash (MHASH thread, const char *string, int start, int end);
+extern void do_mhash_end (MHASH context, char *string, size_t size);
+extern void do_mhash_hmac_end (MHASH context, char *string, size_t size);
+extern int do_mhash_keygen (keygenid algorithm,
+ hashid hashid1, hashid hashid2,
+ int count,
+ void *salt, int salt_size,
+ char *keyword, int keysize,
+ unsigned char *password, int passwordlen);
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; C declarations for mhash-shim.so.
+\f
+(typedef MHASH (* MHASH_INSTANCE))
+(typedef hashid int)
+(typedef keygenid int)
+
+(extern int mhash_count)
+(extern (* char) mhash_get_hash_name (id hashid))
+(extern int mhash_get_block_size (id hashid))
+(extern int mhash_get_hash_pblock (id hashid))
+
+(extern int mhash_keygen_count)
+(extern (* uchar) mhash_get_keygen_name (id keygenid))
+(extern int mhash_get_keygen_salt_size (id keygenid))
+(extern int mhash_get_keygen_max_key_size (id keygenid))
+(extern int mhash_keygen_uses_salt (id keygenid))
+(extern int mhash_keygen_uses_count (id keygenid))
+(extern int mhash_keygen_uses_hash_algorithm (id keygenid))
+
+(extern MHASH mhash_init (type hashid))
+
+(extern void mhash_deinit (context MHASH) (digest (* void)))
+
+(extern void do_mhash
+ (thread MHASH)
+ (string (* (const char)))
+ (start int)
+ (end int))
+
+(extern void do_mhash_end
+ (context MHASH)
+ (string (* char))
+ (size int))
+
+(extern MHASH mhash_hmac_init
+ (type hashid)
+ (key (* void))
+ (keysize int)
+ (blocksize int))
+
+(extern int mhash_hmac_deinit (context MHASH) (digest (* void)))
+
+(extern void do_mhash_hmac_end
+ (context MHASH)
+ (string (* char))
+ (size int))
+
+(extern int do_mhash_keygen
+ (id keygenid)
+ (hashid1 hashid)
+ (hashid2 hashid)
+ (count uint)
+ (salt (* void))
+ (salt_size int)
+ (keyword (* char))
+ (keysize int)
+ (password (* uchar))
+ (passwordlen int))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+(global-definitions runtime/)
+
+(define-package (mhash)
+ (files "mhash")
+ (parent ())
+ (initialization (initialize-package!))
+ ;; You'll have to import these from (global-definitions mhash/).
+ ;; They are currently bound in () by exports from (runtime crypto).
+ #;(export #f
+ make-mhash-keygen-type
+ mhash-available?
+ mhash-context?
+ mhash-end
+ mhash-file
+ mhash-get-block-size
+ mhash-hmac-end
+ mhash-hmac-init
+ mhash-hmac-update
+ mhash-init
+ mhash-keygen
+ mhash-keygen-max-key-size
+ mhash-keygen-salt-size
+ mhash-keygen-type-names
+ mhash-keygen-type?
+ mhash-keygen-uses-count?
+ mhash-keygen-uses-hash-algorithm
+ mhash-keygen-uses-salt?
+ mhash-string
+ mhash-substring
+ mhash-sum->hexadecimal
+ mhash-sum->number
+ mhash-type-names
+ mhash-update))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; mhash wrapper
+;;; package: (mhash)
+
+(declare (usual-integrations))
+\f
+(C-include "mhash")
+
+(define mhash-initialized? #f)
+(define mhash-algorithm-names)
+(define mhash-contexts '())
+(define mhash-hmac-contexts '())
+(define mhash-contexts-mutex)
+
+(define (add-context-cleanup context)
+ (with-thread-mutex-locked mhash-contexts-mutex
+ (lambda ()
+ (set! mhash-contexts
+ (cons (weak-cons context (mhash-context-alien context))
+ mhash-contexts)))))
+
+(define (add-hmac-context-cleanup context)
+ (with-thread-mutex-locked mhash-contexts-mutex
+ (lambda ()
+ (set! mhash-hmac-contexts
+ (cons (weak-cons context (mhash-hmac-context-alien context))
+ mhash-contexts)))))
+
+(define (remove-context-cleanup context)
+ (with-thread-mutex-locked mhash-contexts-mutex
+ (lambda ()
+ (let ((entry (weak-assq context mhash-contexts)))
+ (if entry
+ (set! mhash-contexts (delq! context mhash-contexts)))))))
+
+(define (remove-hmac-context-cleanup context)
+ (with-thread-mutex-locked mhash-contexts-mutex
+ (lambda ()
+ (let ((entry (weak-assq context mhash-hmac-contexts)))
+ (if entry
+ (set! mhash-hmac-contexts (delq! context mhash-hmac-contexts)))))))
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+
+(define (cleanup-contexts)
+ (let loop ((entries mhash-contexts)
+ (prev #f))
+ (if (pair? entries)
+ (let ((entry (car entries))
+ (next (cdr entries)))
+ (if (weak-pair/car? entry)
+ (loop next entries)
+ (let ((context (weak-cdr entry)))
+ (if prev
+ (set-cdr! prev next)
+ (set! mhash-contexts next))
+ (if (not (alien-null? context))
+ (begin
+ (C-call "mhash_deinit" context 0)
+ (alien-null! context)))
+ (loop next prev)))))))
+
+(define (cleanup-hmac-contexts)
+ (let loop ((entries mhash-hmac-contexts)
+ (prev #f))
+ (if (pair? entries)
+ (let ((entry (car entries))
+ (next (cdr entries)))
+ (if (weak-pair/car? entry)
+ (loop next entries)
+ (let ((context (weak-cdr entry)))
+ (if prev
+ (set-cdr! prev next)
+ (set! mhash-hmac-contexts next))
+ (if (not (alien-null? context))
+ (begin
+ (C-call "mhash_hmac_deinit" context 0)
+ (alien-null! context)))
+ (loop next prev)))))))
+
+(define (cleanup-mhash-contexts)
+ (if (not (thread-mutex-owner mhash-contexts-mutex))
+ (begin
+ (cleanup-contexts)
+ (cleanup-hmac-contexts))))
+
+(define (mhash-name->id name procedure)
+ (let ((n (vector-length mhash-algorithm-names)))
+ (let loop ((i 0))
+ (cond ((fix:= i n) (error:bad-range-argument name procedure))
+ ((eq? name (vector-ref mhash-algorithm-names i)) i)
+ (else (loop (fix:+ i 1)))))))
+
+(define-structure mhash-context mutex alien id)
+(define-structure mhash-hmac-context mutex alien id)
+
+(define (guarantee-mhash-context object procedure)
+ (if (not (mhash-context? object))
+ (error:wrong-type-argument object "mhash context" procedure))
+ (if (alien-null? (mhash-context-alien object))
+ (error:bad-range-argument object procedure)))
+
+(define (guarantee-mhash-hmac-context object procedure)
+ (if (not (mhash-hmac-context? object))
+ (error:wrong-type-argument object "mhash HMAC context" procedure))
+ (if (alien-null? (mhash-hmac-context-alien object))
+ (error:bad-range-argument object procedure)))
+
+(define (with-context-locked context thunk)
+ (with-thread-mutex-locked (mhash-context-mutex context) thunk))
+
+(define (with-hmac-context-locked context thunk)
+ (with-thread-mutex-locked (mhash-hmac-context-mutex context) thunk))
+
+(define (with-context-locked-open context operator receiver)
+ (with-thread-mutex-locked (mhash-context-mutex context)
+ (lambda ()
+ (let ((alien (mhash-context-alien context)))
+ (if (alien-null? alien)
+ (error:bad-range-argument context operator))
+ (receiver alien)))))
+
+(define (with-hmac-context-locked-open context operator receiver)
+ (with-thread-mutex-locked (mhash-hmac-context-mutex context)
+ (lambda ()
+ (let ((alien (mhash-hmac-context-alien context)))
+ (if (alien-null? alien)
+ (error:bad-range-argument context operator))
+ (receiver alien)))))
+
+(define (mhash-type-names)
+ (names-vector->list mhash-algorithm-names))
+
+(define (mhash-get-block-size name)
+ (C-call "mhash_get_block_size"
+ (mhash-name->id name 'MHASH-GET-BLOCK-SIZE)))
+
+(define (mhash-init name)
+ (let ((id (mhash-name->id name 'MHASH-INIT))
+ (alien (make-alien '|MHASH_INSTANCE|)))
+ (let ((context (make-mhash-context (make-thread-mutex) alien id)))
+ (add-context-cleanup context)
+ (with-context-locked context
+ (lambda ()
+ (C-call "mhash_init" alien id)
+ (if (alien-null? alien) ; == MHASH_FAILED
+ (error "Unable to allocate mhash context:" name))))
+ context)))
+
+(define (mhash-update context string start end)
+ (guarantee-substring string start end 'MHASH-UPDATE)
+ (with-context-locked-open context 'MHASH-UPDATE
+ (lambda (alien)
+ (C-call "do_mhash" alien string start end))))
+
+(define (mhash-end context)
+ (with-context-locked-open context 'MHASH-END
+ (lambda (alien)
+ (let* ((id (mhash-context-id context))
+ (size (C-call "mhash_get_block_size" id))
+ (digest (make-string size)))
+ (C-call "do_mhash_end" alien digest size)
+ (remove-context-cleanup context)
+ digest))))
+
+(define (mhash-hmac-init name key)
+ (guarantee-string key 'HMASH-HMAC-INIT)
+ (let ((id (mhash-name->id name 'MHASH-HMAC-INIT))
+ (alien (make-alien '|MHASH_INSTANCE|)))
+ (let ((context (make-mhash-hmac-context (make-thread-mutex) alien id))
+ (block-size (C-call "mhash_get_hash_pblock" id))
+ (key-size (string-length key)))
+ (add-hmac-context-cleanup context)
+ (with-hmac-context-locked context
+ (lambda ()
+ (C-call "mhash_hmac_init" alien id key key-size block-size)
+ (if (alien-null? alien) ; == MHASH_FAILED
+ (error "Unable to allocate mhash HMAC context:" name))))
+ context)))
+
+(define (mhash-hmac-update context string start end)
+ (guarantee-substring string start end 'MHASH-HMAC-UPDATE)
+ (with-hmac-context-locked-open context 'MHASH-HMAC-UPDATE
+ (lambda (alien)
+ (C-call "do_mhash" alien string start end))))
+
+(define (mhash-hmac-end context)
+ (with-hmac-context-locked-open context 'MHASH-HMAC-END
+ (lambda (alien)
+ (let* ((id (mhash-hmac-context-id context))
+ (size (C-call "mhash_get_block_size" id))
+ (digest (make-string size)))
+ (C-call "do_mhash_hmac_end" alien digest size)
+ (remove-hmac-context-cleanup context)
+ digest))))
+\f
+(define mhash-keygen-names)
+
+(define (keygen-name->id name procedure)
+ (let ((n (vector-length mhash-keygen-names)))
+ (let loop ((i 0))
+ (cond ((fix:= i n) (error:bad-range-argument name procedure))
+ ((eq? name (vector-ref mhash-keygen-names i)) i)
+ (else (loop (fix:+ i 1)))))))
+
+(define (mhash-keygen-type-names)
+ (names-vector->list mhash-keygen-names))
+
+(define (mhash-keygen-uses-salt? name)
+ (not (zero? (C-call "mhash_keygen_uses_salt"
+ (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?)))))
+
+(define (mhash-keygen-uses-count? name)
+ (not (zero? (C-call "mhash_keygen_uses_count"
+ (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?)))))
+
+(define (mhash-keygen-uses-hash-algorithm name)
+ (C-call "mhash_keygen_uses_hash_algorithm"
+ (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM)))
+
+(define (mhash-keygen-salt-size name)
+ (C-call "mhash_get_keygen_salt_size"
+ (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE)))
+
+(define (mhash-keygen-max-key-size name)
+ (C-call "mhash_get_keygen_max_key_size"
+ (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE)))
+
+(define (mhash-keygen type passphrase #!optional salt)
+ (if (not (mhash-keygen-type? type))
+ (error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN))
+ (let ((keygenid (mhash-keygen-type-id type))
+ (keyword-size (mhash-keygen-type-key-length type)))
+ (let ((params (salted-keygen-params
+ keygenid (mhash-keygen-type-parameter-vector type) salt))
+ (keyword (make-string keyword-size))
+ (max-key-size (C-call "mhash_get_keygen_max_key_size" keygenid)))
+
+ (define (hashid-map params i)
+ (let ((name (vector-ref params i)))
+ (if (not name)
+ 0
+ (mhash-name->id name 'MHASH-KEYGEN))))
+
+ (if (not (or (zero? max-key-size)
+ (< max-key-size (string-length keyword))))
+ (error "keyword size exceeds maximum:" max-key-size type))
+ (if (not (zero? (C-call "do_mhash_keygen"
+ keygenid
+ (hashid-map params 3) ;hash_algorithm[0]
+ (hashid-map params 4) ;hash_algorithm[1]
+ (vector-ref params 1) ;count
+ (vector-ref params 0) ;salt
+ (string-length (vector-ref params 0))
+ keyword keyword-size
+ passphrase (string-length passphrase))))
+ (error "Error signalled by mhash_keygen."))
+ keyword)))
+
+(define (salted-keygen-params id params #!optional salt)
+ (if (not (zero? (C-call "mhash_keygen_uses_salt" id)))
+ (begin
+ (if (or (default-object? salt) (not salt))
+ (error "Salt required:"
+ (vector-ref mhash-keygen-names id)))
+ (let ((n (C-call "mhash_get_keygen_salt_size" id)))
+ (if (not (or (= n 0)
+ (= n (string-length salt))))
+ (error "Salt size incorrect:"
+ (string-length salt)
+ (error-irritant/noise "; should be:")
+ n)))
+ (let ((p (vector-copy params)))
+ (vector-set! p 0 salt)
+ p))
+ params))
+\f
+(define-structure (mhash-keygen-type (constructor %make-mhash-keygen-type))
+ (id #f read-only #t)
+ (key-length #f read-only #t)
+ (parameter-vector #f read-only #t))
+
+(define (make-mhash-keygen-type name key-length hash-names #!optional count)
+ (if (not (index-fixnum? key-length))
+ (error:wrong-type-argument key-length "key length"
+ 'MAKE-MHASH-KEYGEN-TYPE))
+ (if (not (let ((m (mhash-keygen-max-key-size name)))
+ (or (= m 0)
+ (<= key-length m))))
+ (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE))
+ (%make-mhash-keygen-type
+ (keygen-name->id name 'MAKE-MHASH-KEYGEN-TYPE)
+ key-length
+ (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name))
+ (hash-names
+ (if (list? hash-names) hash-names (list hash-names))))
+ (let ((m (length hash-names)))
+ (if (not (= n-algorithms m))
+ (error "Wrong number of hash types supplied:"
+ m
+ (error-irritant/noise "; should be:")
+ n-algorithms)))
+ (let ((n (+ 2 n-algorithms)))
+ (let ((v (make-vector n)))
+ (vector-set! v 0 #f)
+ (vector-set!
+ v 1
+ (and (mhash-keygen-uses-count? name)
+ (begin
+ (if (or (default-object? count) (not count))
+ (error "Iteration count required:" name))
+ (if (not (and (exact-integer? count)
+ (positive? count)))
+ (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE))
+ count)))
+ (do ((i 2 (fix:+ i 1))
+ (names hash-names (cdr names)))
+ ((fix:= i n))
+ (vector-set! v i
+ (mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE)))
+ v)))))
+\f
+(define (mhash-available?)
+ (let ((path (ignore-errors (lambda ()
+ (system-library-pathname "mhash-shim.so")))))
+ (and (pathname? path)
+ (file-loadable? path)
+ (begin
+ (if (not mhash-initialized?)
+ (begin
+ (set! mhash-algorithm-names
+ (make-names-vector
+ (lambda () (C-call "mhash_count"))
+ (lambda (hashid)
+ (let* ((alien (make-alien-to-free
+ '(* char)
+ (lambda (alien)
+ (C-call "mhash_get_hash_name"
+ alien hashid))))
+ (str (c-peek-cstring alien)))
+ (free alien)
+ str))))
+ (set! mhash-keygen-names
+ (make-names-vector
+ (lambda () (C-call "mhash_keygen_count"))
+ (lambda (keygenid)
+ (let* ((alien (make-alien-to-free
+ '(* char)
+ (lambda (alien)
+ (C-call "mhash_get_keygen_name"
+ alien keygenid))))
+ (str (c-peek-cstring alien)))
+ (free alien)
+ str))))
+ (set! mhash-initialized? #t)))
+ #t))))
+
+(define (reset-mhash-variables!)
+ (set! mhash-initialized? #f)
+ (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-contexts)
+ (set! mhash-contexts '())
+ (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-hmac-contexts)
+ (set! mhash-hmac-contexts '())
+ unspecific)
+
+(define (mhash-file hash-type filename)
+ (call-with-binary-input-file filename
+ (lambda (port)
+ (let ((buffer (make-string 4096))
+ (context (mhash-init hash-type)))
+ (dynamic-wind (lambda ()
+ unspecific)
+ (lambda ()
+ (let loop ()
+ (let ((n (read-substring! buffer 0 4096 port)))
+ (if (fix:= 0 n)
+ (mhash-end context)
+ (begin
+ (mhash-update context buffer 0 n)
+ (loop))))))
+ (lambda ()
+ (string-fill! buffer #\NUL)))))))
+
+(define (mhash-string hash-type string)
+ (mhash-substring hash-type string 0 (string-length string)))
+
+(define (mhash-substring hash-type string start end)
+ (let ((context (mhash-init hash-type)))
+ (mhash-update context string start end)
+ (mhash-end context)))
+
+(define (mhash-sum->number sum)
+ (let ((l (string-length sum)))
+ (do ((i 0 (fix:+ i 1))
+ (n 0 (+ (* n #x100) (vector-8b-ref sum i))))
+ ((fix:= i l) n))))
+
+(define (mhash-sum->hexadecimal sum)
+ (let ((n (string-length sum))
+ (digits "0123456789abcdef"))
+ (let ((s (make-string (fix:* 2 n))))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (string-set! s (fix:* 2 i)
+ (string-ref digits
+ (fix:lsh (vector-8b-ref sum i) -4)))
+ (string-set! s (fix:+ (fix:* 2 i) 1)
+ (string-ref digits
+ (fix:and (vector-8b-ref sum i) #x0F))))
+ s)))
+\f
+;;;; Package initialization
+
+(define (initialize-package!)
+ (set! mhash-contexts-mutex (make-thread-mutex))
+ (reset-mhash-variables!)
+ (add-gc-daemon! cleanup-mhash-contexts)
+ (add-event-receiver! event:after-restart reset-mhash-variables!))
+
+(define (make-names-vector get-count get-name)
+ (let ((n (get-count)))
+ (let ((v (make-vector n)))
+ (do ((i 0 (fix:+ i 1)))
+ ((fix:= i n))
+ (vector-set! v i
+ (let ((name (get-name i)))
+ (and name
+ (intern name)))))
+ v)))
+
+(define (names-vector->list v)
+ (let ((end (vector-length v)))
+ (let loop ((index 0) (names '()))
+ (if (fix:< index end)
+ (loop (fix:+ index 1)
+ (let ((name (vector-ref v index)))
+ (if name
+ (cons name names)
+ names)))
+ names))))
\ No newline at end of file
AC_SUBST([CCLD])
AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([../ffi/build.scm])
AC_OUTPUT
# Make custom compilation program for "makegen.scm".
DISTCLEAN_FILES = Makefile config.h config.cache config.log config.status \
cmpauxmd.m4 cmpauxmd.c cmpintmd.h makegen-cc \
- cmpintmd-config.h cmpintmd.c liarc-cc liarc-ld
+ cmpintmd-config.h cmpintmd.c liarc-cc liarc-ld ../ffi/build.scm
MAINTAINER_CLEAN_FILES = Makefile.in Makefile.deps liarc-vars liarc-rules \
config.h.in configure TAGS
}
return;
}
+\f
+unsigned int
+OS_ctty_num_int_chars (void)
+{
+ return (NUM_INT_CHANNELS);
+}
+
+cc_t *
+OS_ctty_get_int_chars (void)
+{
+ return (&int_chars[0]);
+}
+
+void
+OS_ctty_set_int_chars (cc_t * new_int_chars)
+{
+ int i;
+
+ for (i = 0; i < NUM_INT_CHANNELS; i++)
+ int_chars[i] = new_int_chars[i];
+ update_interrupt_characters ();
+ return;
+}
+
+cc_t *
+OS_ctty_get_int_char_handlers (void)
+{
+ return (&int_handlers[0]);
+}
+
+void
+OS_ctty_set_int_char_handlers (cc_t * new_int_handlers)
+{
+ int i;
+
+ for (i = 0; i < NUM_INT_CHANNELS; i++)
+ int_handlers[i] = new_int_handlers[i];
+ update_interrupt_characters ();
+ return;
+}
static void
console_write_string (unsigned char * string)
keyboard_interrupt_enables = ((*mask) & ALL_ENABLES);
}
+unsigned int
+OS_ctty_num_int_chars (void)
+{
+ return (KB_INT_CHARS_SIZE + 1);
+}
+
cc_t
OS_tty_map_interrupt_char (cc_t int_char)
{
return (int_char);
}
+
+cc_t *
+OS_ctty_get_int_chars (void)
+{
+ static cc_t characters [KB_INT_CHARS_SIZE + 1];
+ unsigned int i;
+ for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
+ (characters[i]) = (keyboard_interrupt_characters[i]);
+ (characters[i]) = '\0'; /* dummy for control-break */
+ return (characters);
+}
+
+void
+OS_ctty_set_int_chars (cc_t * characters)
+{
+ unsigned int i;
+ for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
+ (keyboard_interrupt_characters[i]) = (characters[i]);
+ update_keyboard_interrupt_characters ();
+}
+
+cc_t *
+OS_ctty_get_int_char_handlers (void)
+{
+ static cc_t handlers [KB_INT_CHARS_SIZE + 1];
+ unsigned int i;
+ for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
+ (handlers[i]) = ((cc_t) (keyboard_interrupt_handlers[i]));
+ (handlers[i]) = ((cc_t) keyboard_break_interrupt);
+ return (handlers);
+}
+
+void
+OS_ctty_set_int_char_handlers (cc_t * handlers)
+{
+ unsigned int i;
+ for (i = 0; (i < KB_INT_CHARS_SIZE); i += 1)
+ (keyboard_interrupt_handlers[i]) =
+ ((enum interrupt_handler) (handlers[i]));
+ keyboard_break_interrupt = ((enum interrupt_handler) (handlers[i]));
+ update_keyboard_interrupt_characters ();
+}
\f
static char
check_if_enabled (enum interrupt_handler handler)
extern void OS_ctty_get_interrupt_enables (Tinterrupt_enables * mask);
extern void OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask);
+extern unsigned int OS_ctty_num_int_chars (void);
+extern cc_t * OS_ctty_get_int_chars (void);
+extern cc_t * OS_ctty_get_int_char_handlers (void);
+extern void OS_ctty_set_int_chars (cc_t *);
+extern void OS_ctty_set_int_char_handlers (cc_t *);
+
#endif /* SCM_OSCTTY_H */
(select_registry_t registry, int fd, unsigned int mode);
extern unsigned int OS_select_registry_length
(select_registry_t registry);
-extern void OS_select_registry_entry
- (select_registry_t registry, unsigned int index,
- int * fd_r, unsigned int * mode_r);
extern void OS_select_registry_result
(select_registry_t registry, unsigned int index,
int * fd_r, unsigned int * mode_r);
extern int OS_test_select_descriptor
(int fd, int blockp, unsigned int mode);
extern int OS_pause (int blockp);
-extern select_registry_t arg_select_registry (int arg_number);
#endif /* SCM_OSIO_H */
\f
/* Select registry */
-select_registry_t
+static select_registry_t
arg_select_registry (int arg_number)
{
return ((select_registry_t) (arg_ulong_integer (arg_number)));
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
+
+DEFINE_PRIMITIVE ("TTY-GET-INTERRUPT-CHARS", Prim_tty_get_interrupt_chars, 0, 0,
+ "Return the current interrupt characters as a string.")
+{
+ PRIMITIVE_HEADER (0);
+ {
+ unsigned int i;
+ unsigned int num_chars = (OS_ctty_num_int_chars ());
+ SCHEME_OBJECT result = (allocate_string (num_chars * 2));
+ cc_t * int_chars = (OS_ctty_get_int_chars ());
+ cc_t * int_handlers = (OS_ctty_get_int_char_handlers ());
+ char * scan = (STRING_POINTER (result));
+
+ for (i = 0; i < num_chars; i++)
+ {
+ (*scan++) = (int_chars[i]);
+ (*scan++) = (int_handlers[i]);
+ }
+ PRIMITIVE_RETURN (result);
+ }
+}
+
+DEFINE_PRIMITIVE ("TTY-SET-INTERRUPT-CHARS!", Prim_tty_set_interrupt_chars, 1, 1,
+ "Change the current interrupt characters to STRING.\n\
+STRING must be in the correct form for this operating system.")
+{
+ PRIMITIVE_HEADER (1);
+ {
+ unsigned int i;
+ unsigned int num_chars = (OS_ctty_num_int_chars ());
+ cc_t * int_chars = (OS_ctty_get_int_chars ());
+ cc_t * int_handlers = (OS_ctty_get_int_char_handlers ());
+ SCHEME_OBJECT argument = (ARG_REF (1));
+ char * scan;
+
+ if (! ((STRING_P (argument))
+ && (((unsigned int) (STRING_LENGTH (argument)))
+ == (num_chars * 2))))
+ error_wrong_type_arg (1);
+
+ for (i = 0, scan = (STRING_POINTER (argument)); i < num_chars; i++)
+ {
+ (int_chars[i]) = (*scan++);
+ (int_handlers[i]) = (*scan++);
+ }
+ OS_ctty_set_int_chars (int_chars);
+ OS_ctty_set_int_char_handlers (int_handlers);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
+
+int
+interrupts_p (void)
+{
+ /* Just the pending interrupts bitmap, ignoring the INT_MASK. */
+ /* This is mainly for src/gtk/gtkio.c, which finds pending_
+ interrupts_p() useless; it is always /gc-ok. */
+
+ return (GET_INT_CODE);
+}
extern void callout_continue (CalloutTrampIn tramp);
extern char* callout_lunseal (CalloutTrampIn expected);
extern void callout_pop (char* tos);
-extern void abort_to_c (void);
typedef void (*CallbackKernel)(void);
extern void callback_run_kernel (long callback_id, CallbackKernel kernel);
/* For debugging messages from shim code. */
extern void outf_error (const char *, ...);
extern void outf_flush_error (void);
+extern void error_external_return (void);
#endif
return (ctty_fildes);
}
\f
+#if 0
+
+/* not currently used */
+static void
+ctty_get_interrupt_chars (Tinterrupt_chars * ic)
+{
+ Ttty_state s;
+ if ((get_terminal_state (ctty_fildes, (&s))) == 0)
+ {
+#ifdef HAVE_TERMIOS_H
+ (ic -> quit) = ((s . tio . c_cc) [VQUIT]);
+ (ic -> intrpt) = ((s . tio . c_cc) [VINTR]);
+ (ic -> tstp) = ((s . tio . c_cc) [VSUSP]);
+
+#ifdef VDSUSP
+ (ic -> dtstp) = ((s . tio . c_cc) [VDSUSP]);
+#else /* not VDSUSP */
+#ifdef __HPUX__
+ (ic -> dtstp) = (s . ltc . t_dsuspc);
+#endif /* __HPUX__ */
+#endif /* not VDSUSP */
+
+#else /* not HAVE_TERMIOS_H */
+#ifdef HAVE_TERMIO_H
+
+ (ic -> quit) = ((s . tio . c_cc) [VQUIT]);
+ (ic -> intrpt) = ((s . tio . c_cc) [VINTR]);
+#ifdef HAVE_STRUCT_LTCHARS
+ (ic -> tstp) = (s . ltc . t_suspc);
+ (ic -> dtstp) = (s . ltc . t_dsuspc);
+#else /* not HAVE_STRUCT_LTCHARS */
+ {
+ cc_t disabled_char = (UX_PC_VDISABLE (ctty_fildes));
+ (ic -> tstp) = disabled_char;
+ (ic -> dtstp) = disabled_char;
+ }
+#endif /* not HAVE_STRUCT_LTCHARS */
+
+#else /* not HAVE_TERMIO_H */
+#ifdef HAVE_SGTTY_H
+
+ (ic -> quit) = (s . tc . t_quitc);
+ (ic -> intrpt) = (s . tc . t_intrc);
+#ifdef HAVE_STRUCT_LTCHARS
+ (ic -> tstp) = (s . ltc . t_suspc);
+ (ic -> dtstp) = (s . ltc . t_dsuspc);
+#else /* not HAVE_STRUCT_LTCHARS */
+ {
+ cc_t disabled_char = (UX_PC_VDISABLE (ctty_fildes));
+ (ic -> tstp) = disabled_char;
+ (ic -> dtstp) = disabled_char;
+ }
+#endif /* not HAVE_STRUCT_LTCHARS */
+
+#endif /* HAVE_SGTTY_H */
+#endif /* HAVE_TERMIO_H */
+#endif /* HAVE_TERMIOS_H */
+ }
+ else
+ {
+ cc_t disabled_char = (UX_PC_VDISABLE (ctty_fildes));
+ (ic -> quit) = disabled_char;
+ (ic -> intrpt) = disabled_char;
+ (ic -> tstp) = disabled_char;
+ (ic -> dtstp) = disabled_char;
+ }
+}
+#endif /* 0 */
+\f
static void
ctty_set_interrupt_chars (Tinterrupt_chars * ic)
{
current_interrupt_enables = (*mask);
ctty_update_interrupt_chars ();
}
+
+#if 0
+
+void
+OS_ctty_set_interrupt_chars (cc_t quit_char,
+ cc_t int_char,
+ cc_t tstp_char)
+{
+ (current_interrupt_chars . quit) = quit_char;
+ (current_interrupt_chars . intrpt) = int_char;
+ (current_interrupt_chars . tstp) = tstp_char;
+ ctty_update_interrupt_chars ();
+}
+#endif
+
+unsigned int
+OS_ctty_num_int_chars (void)
+{
+ return (3);
+}
+
+cc_t *
+OS_ctty_get_int_chars (void)
+{
+ static cc_t int_chars [3];
+
+ int_chars[0] = current_interrupt_chars.quit;
+ int_chars[1] = current_interrupt_chars.intrpt;
+ int_chars[2] = current_interrupt_chars.tstp;
+ return (& int_chars [0]);
+}
+
+void
+OS_ctty_set_int_chars (cc_t * int_chars)
+{
+ current_interrupt_chars.quit = int_chars[0];
+ current_interrupt_chars.intrpt = int_chars[1];
+ current_interrupt_chars.tstp = int_chars[2];
+ ctty_update_interrupt_chars ();
+ return;
+}
\f
+extern enum interrupt_handler OS_signal_quit_handler (void);
+extern enum interrupt_handler OS_signal_int_handler (void);
+extern enum interrupt_handler OS_signal_tstp_handler (void);
+extern void OS_signal_set_interrupt_handlers
+ (enum interrupt_handler quit_handler,
+ enum interrupt_handler int_handler,
+ enum interrupt_handler tstp_handler);
+
+cc_t *
+OS_ctty_get_int_char_handlers (void)
+{
+ static cc_t int_handlers [3];
+
+ int_handlers[0] = ((cc_t) (OS_signal_quit_handler ()));
+ int_handlers[1] = ((cc_t) (OS_signal_int_handler ()));
+ int_handlers[2] = ((cc_t) (OS_signal_tstp_handler ()));
+ return (& int_handlers [0]);
+}
+
+void
+OS_ctty_set_int_char_handlers (cc_t * int_handlers)
+{
+ OS_signal_set_interrupt_handlers
+ (((enum interrupt_handler) (int_handlers [0])),
+ ((enum interrupt_handler) (int_handlers [1])),
+ ((enum interrupt_handler) (int_handlers [2])));
+ return;
+}
+
void
UX_initialize_ctty (int interactive)
{
#elif defined(HAVE_CLOCK_GETTIME)
void
-OS_nanotime_since_utc_epoch (struct scheme_nanotime t)
+OS_nanotime_since_utc_epoch (struct scheme_nanotime *t)
{
struct timespec ts;
STD_VOID_SYSTEM_CALL
}
}
\f
+static enum interrupt_handler
+encode_interrupt_handler (Tsignal_handler handler)
+{
+ return
+ ((handler == ((Tsignal_handler) sighnd_control_g))
+ ? interrupt_handler_control_g
+ : (handler == ((Tsignal_handler) sighnd_interactive))
+ ? interrupt_handler_interactive
+ : (handler == ((Tsignal_handler) sighnd_stop))
+ ? interrupt_handler_stop
+ : (handler == ((Tsignal_handler) sighnd_terminate))
+ ? interrupt_handler_terminate
+ : (handler == ((Tsignal_handler) SIG_IGN))
+ ? interrupt_handler_ignore
+ : (handler == ((Tsignal_handler) SIG_DFL))
+ ? interrupt_handler_default
+ : interrupt_handler_unknown);
+}
+
+static Tsignal_handler
+decode_interrupt_handler (enum interrupt_handler encoding)
+{
+ return
+ ((encoding == interrupt_handler_control_g)
+ ? ((Tsignal_handler) sighnd_control_g)
+ : (encoding == interrupt_handler_interactive)
+ ? ((Tsignal_handler) sighnd_interactive)
+ : (encoding == interrupt_handler_stop)
+ ? ((Tsignal_handler) sighnd_stop)
+ : (encoding == interrupt_handler_terminate)
+ ? ((Tsignal_handler) sighnd_terminate)
+ : (encoding == interrupt_handler_ignore)
+ ? ((Tsignal_handler) SIG_IGN)
+ : (encoding == interrupt_handler_default)
+ ? ((Tsignal_handler) SIG_DFL)
+ : ((Tsignal_handler) 0));
+}
+
+enum interrupt_handler
+OS_signal_quit_handler (void)
+{
+ return (encode_interrupt_handler (current_handler (SIGQUIT)));
+}
+
+enum interrupt_handler
+OS_signal_int_handler (void)
+{
+ return (encode_interrupt_handler (current_handler (SIGINT)));
+}
+
+enum interrupt_handler
+OS_signal_tstp_handler (void)
+{
+ return
+ ((UX_SC_JOB_CONTROL ())
+ ? (encode_interrupt_handler (current_handler (SIGTSTP)))
+ : interrupt_handler_ignore);
+}
+
+void
+OS_signal_set_interrupt_handlers (enum interrupt_handler quit_handler,
+ enum interrupt_handler int_handler,
+ enum interrupt_handler tstp_handler)
+{
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (quit_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGQUIT, handler);
+ }
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (int_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGINT, handler);
+ }
+ if (UX_SC_JOB_CONTROL ())
+ {
+ Tsignal_handler handler = (decode_interrupt_handler (tstp_handler));
+ if (handler != 0)
+ INSTALL_HANDLER (SIGTSTP, handler);
+ }
+}
+\f
+static void
+describe_sighnd (int signo, unsigned char c)
+{
+ switch (encode_interrupt_handler (current_handler (signo)))
+ {
+ case interrupt_handler_control_g:
+ fputs ("When typed, scheme will get the ^G character interrupt.\n",
+ stdout);
+ fputs ("The default action is to abort the running program,\n", stdout);
+ fputs ("and to resume the top level read-eval-print loop.\n", stdout);
+ break;
+ case interrupt_handler_interactive:
+ fputs ("When typed, various interrupt options are offered.\n", stdout);
+ fprintf (stdout, "Type %s followed by `?' for a list of options.\n",
+ (char_description (c, 0)));
+ break;
+ case interrupt_handler_terminate:
+ describe_terminate:
+ fputs ("When typed, scheme will terminate.\n", stdout);
+ break;
+ case interrupt_handler_stop:
+ describe_stop:
+ fputs ("When typed, scheme will suspend execution.\n", stdout);
+ break;
+ case interrupt_handler_ignore:
+ describe_ignore:
+ fputs ("When typed, this character will be ignored.\n", stdout);
+ break;
+ case interrupt_handler_default:
+ {
+ struct signal_descriptor * descriptor =
+ (find_signal_descriptor (signo));
+ if (descriptor != 0)
+ switch (descriptor -> action)
+ {
+ case dfl_ignore: goto describe_ignore;
+ case dfl_stop: goto describe_stop;
+ case dfl_terminate: goto describe_terminate;
+ }
+ }
+ default:
+ fputs ("When typed, this character will have an unknown effect.\n",
+ stdout);
+ break;
+ }
+}
+\f
static void
print_interrupt_chars (void)
{
unsigned char quit_char = (OS_ctty_quit_char ());
fprintf (stdout, "\n\nThe quit character is %s.\n",
(char_description (quit_char, 1)));
- fputs ("When typed, various interrupt options are offered.\n", stdout);
- fprintf (stdout, "Type %s followed by `?' for a list of options.\n",
- (char_description (quit_char, 0)));
+ describe_sighnd (SIGQUIT, quit_char);
}
{
unsigned char int_char = (OS_ctty_int_char ());
fprintf (stdout, "\nThe interrupt character is %s.\n",
(char_description (int_char, 1)));
- fputs ("When typed, scheme will get the ^G character interrupt.\n", stdout);
- fputs ("The default action is to abort the running program,\n", stdout);
- fputs ("and to resume the top level read-eval-print loop.\n", stdout);
+ describe_sighnd (SIGINT, int_char);
}
if (UX_SC_JOB_CONTROL ())
{
unsigned char tstp_char = (OS_ctty_tstp_char ());
fprintf (stdout, "\nThe terminal stop character is %s.\n",
(char_description (tstp_char, 1)));
- fputs ("When typed, scheme will suspend execution.\n", stdout);
+ describe_sighnd (SIGTSTP, tstp_char);
}
putc ('\n', stdout);
fflush (stdout);
#define record_signal_delivery(signo)
#endif
-extern void foreach_async_signal (void(*func)(int signo));
-
#endif /* SCM_UXSIG_H */
install:
rm -rf $(DESTDIR)$(RUNDIR)
$(mkinstalldirs) $(DESTDIR)$(RUNDIR)
- $(INSTALL_DATA) *.bci $(DESTDIR)$(RUNDIR)/.
- $(INSTALL_DATA) runtime-*.pkd $(DESTDIR)$(RUNDIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(RUNDIR)/.
@for F in $(RUNOPTS); do \
CMD="$(INSTALL_COM) $${F}.com $(DESTDIR)$(RUNDIR)/.";\
echo "$${CMD}"; eval "$${CMD}";\
unspecific
(let* ((library (%alien-function/library afunc))
(name (%alien-function/name afunc))
- (pathname (merge-pathnames
- (pathname-new-type (string-append library "-shim") "so")
- (system-library-directory-pathname)))
+ (pathname (system-library-pathname
+ (pathname-new-type (string-append library"-shim")
+ "so")))
(handle (or (find-dld-handle
(lambda (h)
(pathname=? pathname (dld-handle-pathname h))))
(vector-set! (get-fixed-objects-vector) #x41 callback-handler))
\f
+;;; Build support, autoloaded
+
+(define (generate-shim library #!optional prefix)
+ (load-ffi-quietly)
+ ((environment-lookup (->environment '(ffi)) 'c-generate) library prefix))
+
+(define (compile-shim)
+ (load-ffi-quietly)
+ ((environment-lookup (->environment '(ffi)) 'compile-shim)))
+
+(define (link-shim)
+ (load-ffi-quietly)
+ ((environment-lookup (->environment '(ffi)) 'link-shim)))
+
+(define (install-shim library)
+ (load-ffi-quietly)
+ ((environment-lookup (->environment '(ffi)) 'install-shim) library))
+
+(define (load-ffi-quietly)
+ (if (not (name->package '(FFI)))
+ (let ((kernel (lambda ()
+ (fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'FFI)))))
+ (if (nearest-cmdl/batch-mode?)
+ (kernel)
+ (with-notification (lambda (port)
+ (write-string "Loading FFI option" port))
+ kernel)))))
+\f
+
(define calloutback-stack '())
(define %trace? #f)
(let ((value (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
(if value
(pathname-as-directory value)
- (system-library-directory-pathname)))))
+ (or (%find-library-directory pathname)
+ (system-library-directory-pathname))))))
+
+(define (%find-library-directory pathname)
+ (let ((dir (pathname-directory pathname)))
+ (or (and (pair? dir)
+ (eq? 'RELATIVE (car dir))
+ (pair? (cdr dir))
+ (string? (cadr dir))
+ (let ((libdir (system-library-directory-pathname (cadr dir))))
+ (and libdir
+ (pathname-new-directory libdir
+ (except-last-pair
+ (pathname-directory libdir)))))))))
\f
(define-integrable (dbg-block/layout-first-offset block)
(let ((layout (dbg-block/layout block)))
(if (eq? n #t)
(begin
(handle-subprocess-status-change)
- (if (channel-blocking? channel)
- (loop)
- #f))
+ (without-interrupts
+ (lambda ()
+ (if (and (channel-open? channel)
+ (channel-blocking? channel))
+ (loop)
+ #f))))
n))))
(define (%channel-read channel buffer start end)
(if (eq? n #t)
(begin
(handle-subprocess-status-change)
- (if (channel-blocking? channel)
- (loop)
- #f))
+ (without-interrupts
+ (lambda ()
+ (if (and (channel-open? channel)
+ (channel-blocking? channel))
+ (loop)
+ #f))))
n))))
(define (%channel-write channel buffer start end)
(define system-loader/enable-query? #f)
(define (package-set-pathname pathname #!optional os-type)
- (pathname-new-type
- (pathname-new-name pathname
- (string-append (pathname-name pathname)
- "-"
- (case (if (default-object? os-type)
- microcode-id/operating-system
- os-type)
- ((NT) "w32")
- ((OS/2) "os2")
- ((UNIX) "unx")
- (else "unk"))))
- "pkd"))
+ (let ((p (->pathname pathname)))
+ (pathname-new-type
+ (pathname-new-name p
+ (string-append
+ (or (pathname-name p)
+ ;; Interpret dirname/ as dirname/dirname-OS.pkd.
+ (let ((dir (pathname-directory p)))
+ (if (pair? dir)
+ (let ((name (last dir)))
+ (if (string? name)
+ name
+ ""))
+ "")))
+ "-"
+ (case (if (default-object? os-type)
+ microcode-id/operating-system
+ os-type)
+ ((NT) "w32")
+ ((OS/2) "os2")
+ ((UNIX) "unx")
+ (else "unk"))))
+ "pkd")))
\f
(define-integrable (make-package-file tag version descriptions loads)
(vector tag version descriptions loads))
(else #f)))
(%find-library-directory)))
+(define (with-system-library-directories directories thunk)
+
+ (define (existing-directory directory)
+ (let ((dirpath (pathname-as-directory (merge-pathnames directory))))
+ (if (file-directory? dirpath)
+ dirpath
+ (error:file-operation dirpath
+ "find" "directory" "no such directory"
+ 'with-system-library-directories
+ directories))))
+
+ (fluid-let ((library-directory-path
+ (append (map existing-directory directories)
+ library-directory-path)))
+ (thunk)))
+
(define (%find-library-directory)
(pathname-simplify
(or (find-matching-item library-directory-path file-directory?)
pathname?
system-library-directory-pathname
system-library-pathname
+ with-system-library-directories
uri->pathname
user-homedir-pathname)
(initialization (initialize-package!)))
free
register-c-callback
de-register-c-callback
- outf-error)
+ outf-error
+ generate-shim
+ compile-shim
+ link-shim
+ install-shim)
(initialization (initialize-package!)))
(define-package (runtime program-copier)
;; inexact result exception) that the interrupted thread cares about.
(%trace ";thread-timer: interrupt in "first-running-thread"\n")
(let ((fp-env (enter-default-float-environment first-running-thread)))
- (flo:set-environment! (flo:default-environment))
(set! next-scheduled-timeout #f)
(set-interrupt-enables! interrupt-mask/gc-ok)
(deliver-timer-events)
(delete-matching-items components string-null?)))
(define (parse-directory-component component)
- (if (string=? ".." component)
- 'UP
- component))
+ (cond ((string=? ".." component) 'UP)
+ ((string=? "." component) 'HERE)
+ (else component)))
(define (string-components string delimiter)
(substring-components string 0 (string-length string) delimiter))
(define (unparse-directory-component component)
(cond ((eq? component 'UP) "..")
+ ((eq? component 'HERE) ".")
((string? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
(lambda (element)
(if (string? element)
(not (string-null? element))
- (eq? element 'UP)))))
+ (memq element '(UP HERE))))))
(simplify-directory directory))
(else
(error:illegal-pathname-component directory "directory")))
(let ((directory (pathname-directory pathname)))
(let scan ((p (list-tail directory np)) (np np))
(if (pair? p)
- (if (and (not (eq? (car p) 'UP))
- (pair? (cdr p))
- (eq? (cadr p) 'UP))
- (let ((pathname*
- (pathname-new-directory pathname
- (delete-up directory p))))
- (if (file-eq? (directory-pathname pathname)
- (directory-pathname pathname*))
- (loop pathname* np)
- (scan (cddr p) (+ np 2))))
- (scan (cdr p) (+ np 1)))
+ (cond ((and (not (eq? (car p) 'UP))
+ (pair? (cdr p))
+ (eq? (cadr p) 'UP))
+ (let ((pathname*
+ (pathname-new-directory pathname
+ (delete-up directory p))))
+ (if (file-eq? (directory-pathname pathname)
+ (directory-pathname pathname*))
+ (loop pathname* np)
+ (scan (cddr p) (+ np 2)))))
+ ((eq? (car p) 'HERE)
+ (let ((pathname*
+ (pathname-new-directory pathname
+ (delete-here directory p))))
+ (loop pathname* np)))
+ (else
+ (scan (cdr p) (+ np 1))))
pathname))))
pathname))
(cddr p*)
(cons (car p*) (loop (cdr p*))))))
+(define (delete-here directory p)
+ (let loop ((p* directory))
+ (if (eq? p* p)
+ (cdr p)
+ (cons (car p*) (loop (cdr p*))))))
+
(define (file-eq? p1 p2)
((ucode-primitive file-eq? 2) (->namestring (merge-pathnames p1))
(->namestring (merge-pathnames p2))))
\ No newline at end of file
install:
$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) sf-unx.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(TARGET_DIR)/.
install:
$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) sos-unx.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(TARGET_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(TARGET_DIR)/.
install:
$(mkinstalldirs) $(DESTDIR)$(SSP_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(SSP_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(SSP_DIR)/.
- $(INSTALL_DATA) ssp-unx.pkd $(DESTDIR)$(SSP_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(SSP_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(SSP_DIR)/.
install:
$(mkinstalldirs) $(DESTDIR)$(PARSER_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(PARSER_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(PARSER_DIR)/.
- $(INSTALL_DATA) parser-unx.pkd $(DESTDIR)$(PARSER_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(PARSER_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(PARSER_DIR)/.
install:
$(mkinstalldirs) $(DESTDIR)$(XDOC_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(XDOC_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(XDOC_DIR)/.
- $(INSTALL_DATA) xdoc-unx.pkd $(DESTDIR)$(XDOC_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(XDOC_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(XDOC_DIR)/.
install:
$(mkinstalldirs) $(DESTDIR)$(TARGET_DIR)
$(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/.
- $(INSTALL_DATA) xml-unx.pkd $(DESTDIR)$(TARGET_DIR)/.
+ $(INSTALL_DATA) *.pkd *.bci $(DESTDIR)$(TARGET_DIR)/.
$(INSTALL_DATA) $(srcdir)/load.scm $(DESTDIR)$(TARGET_DIR)/.
"runtime/test-regsexp"
("runtime/test-wttree" (runtime wt-tree))
"ffi/test-ffi.scm"
- "gtk/test-gtk.scm"
- "gtk-screen/test-gtk-screen.scm"
))
(with-working-directory-pathname
--- /dev/null
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+# Massachusetts Institute of Technology
+#
+# This file is part of MIT/GNU Scheme.
+#
+# MIT/GNU Scheme 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 of the
+# License, or (at your option) any later version.
+#
+# MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
+# 02110-1301, USA.
+
+HOST=../../src/microcode/scheme --library ../../src/lib --batch-mode
+
+all: ffi-test-shim.so ffi-test-types.bin ffi-test-const.bin
+
+ffi-test-shim.so: ffi-test-shim.o ffi-test.o
+ echo "(link-shim)" | $(HOST) -- -o $@ $^
+
+ffi-test-shim.o: ffi-test-shim.c ffi-test.h
+ echo "(compile-shim)" | $(HOST) -- -c $<
+
+ffi-test-shim.c ffi-test-const.c ffi-test-types.bin: ffi-test.cdecl
+ echo '(generate-shim "ffi-test" "#include \"ffi-test.h\"")' | $(HOST)
+
+ffi-test-const.bin: ffi-test-const.scm
+ echo '(sf "ffi-test-const")' | $(HOST)
+
+ffi-test-const.scm: ffi-test-const
+ ./ffi-test-const
+
+ffi-test-const: ffi-test-const.o
+ $(CC) $(LDFLAGS) -o $@ $^ $(LIBS)
+
+ffi-test-const.o: ffi-test-const.c
+ $(CC) $(CPPFLAGS) $(CFLAGS) -c $<
+
+# The test library itself.
+
+ffi-test.o: ffi-test.c ffi-test.h
+ echo "(compile-shim)" | $(HOST) -- -o $@ -c $<
+
+.PHONY: all
--- /dev/null
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* A test library; used to test the C/Unix FFI. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "ffi-test.h"
+
+static void *callback_data;
+static TestDoubleCallback callback_func;
+
+extern void
+test_register_double (TestDoubleCallback callback, void *user_data)
+{
+ callback_func = callback;
+ callback_data = user_data;
+}
+
+extern double
+test_double (double d, TestStruct *s)
+{
+ if (!callback_data) return 0.0;
+ return (d * callback_func (s->second, callback_data));
+}
+
+extern char *
+test_string (char *stri, TestStruct *stru)
+{
+ int l1 = strlen (stri);
+ int l2 = strlen (stru->fourth);
+ char *s = malloc (3);
+ snprintf (s, 3, "%d", l1 + l2);
+ return (s);
+}
+
+extern TestStruct
+test_struct (TestStruct s)
+{
+ s.second += strlen (s.fourth);
+ return (s);
+}
+
+extern TestUnion
+test_union (TestUnion u)
+{
+ u.d += 1.0;
+ return (u);
+}
(C-include "ffi-test")
-(define (test-ffi)
+(define test-ffi
+ (let ((libdir (merge-pathnames "./")))
+ (named-lambda (test-ffi)
+ (with-system-library-directories (list libdir)
+ (lambda ()
+ (test-ffi*))))))
+
+(define (test-ffi*)
(let* ((struct (malloc (c-sizeof "TestStruct") '|TestStruct|))
(string "input string")
(pi (* 4 (atan 1 1)))
-;;;-*-Scheme-*-
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme 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 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Build and test the test library wrapper.
-(load-option 'FFI)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (compile-file "test-ffi-wrapper")
- (load "test-ffi-wrapper")))
-(define-test 'ffi test-ffi)
\ No newline at end of file
+ (let ((code
+ (with-notification
+ (lambda (port)
+ (write-string "make all" port)
+ (newline port))
+ (lambda ()
+ (run-synchronous-subprocess "make" (list "all"))))))
+ (if (not (zero? code))
+ (warn "Test library build failed:" code)
+ (begin
+ (fluid-let ((load/suppress-loading-message? #t))
+ (load-option 'FFI))
+ (with-system-library-directories '("./")
+ (lambda ()
+ (compile-file "test-ffi-wrapper")))
+ (load "test-ffi-wrapper")
+ (define-test 'ffi test-ffi))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 2012 Matthew Birkholz
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme 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 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Test the Gtks
-
-(define gcp)
-(define gls)
-(define ls)
-(define await-closed-demos)
-(define registered-callback-count)
-(define malloced-aliens)
-(define (main)
- (let ((new (extend-top-level-environment (->environment '(gtk))))
- (ffi (->environment '(runtime ffi))))
- (with-working-directory-pathname "gtk/"
- (lambda ()
- (compile-file "gtk-tests" '() new)
- (load "gtk-tests" new)))
- (load "../src/gtk/hello.scm" new)
- (load "../src/planetarium/mit-scheme")
- (set! gcp (access gcp new))
- (set! gls (access gls new))
- (set! ls (access ls new))
- (set! await-closed-demos (access await-closed-demos new))
- (set! registered-callback-count
- (access registered-callback-count ffi))
- (set! malloced-aliens (named-lambda (malloced-aliens)
- (access malloced-aliens ffi))))
-
- (define-test 'gio-copy
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (gio-copy-test)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((file1 "../../src/README.txt")
- (file2 "test-copy-1.txt"))
- (gcp file1 file2)
- (assert-equal (md5-file file2) (md5-file file1)
- 'EXPRESSION (list 'GCP file1 file2))))))))
-
- (define-test 'gio-list
- (let ((cwd (directory-pathname (current-load-pathname))))
- (named-lambda (gio-list-test)
- (with-working-directory-pathname cwd
- (lambda ()
- (let ((native (sort (ls "../runtime/") string<?))
- (gio (sort (gls "../runtime/") string<?)))
- (assert-equal gio native
- 'EXPRESSION '(GLS "../runtime/"))))))))
-
- (define-test 'gtk-demos
- (lambda ()
- (with-gc-notification! #t await-closed-demos)
- (gc-flip)))
-
- (define-test 'gtk-demos.callbacks
- (lambda ()
- (assert-= (car (registered-callback-count))
- 0
- 'EXPRESSION '(REGISTERED-CALLBACK-COUNT))))
-
- (define-test 'gtk-demos.mallocs
- (lambda ()
- (assert-= (length (malloced-aliens))
- 0
- 'EXPRESSION '(LENGTH (MALLOCED-ALIENS))))))
-
-(if (and (not (warn-errors? (lambda () (load-option 'gtk))))
- (let ((s (get-environment-variable "DISPLAY")))
- (and (string? s) (not (string-null? s)))))
- (main))
\ No newline at end of file
projects / mit-scheme.git / commitdiff