From: Matt Birkholz Date: Fri, 13 Sep 2013 02:15:57 +0000 (-0700) Subject: Merge branch 'Gtk' into Gtk-Screen. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~30 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3fefb5e1e3160afee24dcf49b60c3fcd96bbf875;p=mit-scheme.git Merge branch 'Gtk' into Gtk-Screen. Removed gtk-screen from the core build. Replaced Makefile-fragment with Makefile for a separate build. --- diff --git a/doc/Makefile.in b/doc/Makefile.in index faaf6ec05..dca4c5204 100644 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@ -65,7 +65,7 @@ pdfdir = @pdfdir@ 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: diff --git a/doc/configure.ac b/doc/configure.ac index cf0e3257b..358edff73 100644 --- a/doc/configure.ac +++ b/doc/configure.ac @@ -82,7 +82,6 @@ AC_CONFIG_FILES([ Makefile make-common ffi/Makefile - gtk/Makefile imail/Makefile ref-manual/Makefile sos/Makefile diff --git a/doc/gtk/Makefile.in b/doc/gtk/Makefile.in deleted file mode 100644 index 152a8b911..000000000 --- a/doc/gtk/Makefile.in +++ /dev/null @@ -1,12 +0,0 @@ -# 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 diff --git a/doc/index.html b/doc/index.html index 67ca0f7d8..a66f9d5bc 100644 --- a/doc/index.html +++ b/doc/index.html @@ -16,7 +16,6 @@ The following MIT/GNU Scheme manuals are available here:
  • SOS Reference Manual
  • IMAIL User's Manual
  • FFI User's Manual
    • -
  • GTK User's Manual
    • diff --git a/doc/make-common.in b/doc/make-common.in index 950b0eb59..7f70e4cc3 100644 --- a/doc/make-common.in +++ b/doc/make-common.in @@ -81,7 +81,7 @@ $(HTML_TARGET)/index.html: $(SOURCES) 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) diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index 274caaab6..212b4694e 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -1577,7 +1577,7 @@ storage available after collection, an exact non-negative integer. 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 diff --git a/src/Makefile.in b/src/Makefile.in index 90da94245..8a3c5d65c 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -62,10 +62,9 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/microcode/mkinstalldirs 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@ @@ -79,13 +78,6 @@ all: @ALL_TARGET@ check: ./microcode/scheme --library lib --batch-mode \ --load ../tests/check +#else +# ifdef HAVE_BLOWFISH_H +# include +# 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); diff --git a/src/blowfish/blowfish.cdecl b/src/blowfish/blowfish.cdecl new file mode 100644 index 000000000..0d8c2659a --- /dev/null +++ b/src/blowfish/blowfish.cdecl @@ -0,0 +1,85 @@ +#| -*-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. + +(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 diff --git a/src/blowfish/blowfish.pkg b/src/blowfish/blowfish.pkg new file mode 100644 index 000000000..3e5a145d8 --- /dev/null +++ b/src/blowfish/blowfish.pkg @@ -0,0 +1,45 @@ +#| -*-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 diff --git a/src/blowfish/blowfish.scm b/src/blowfish/blowfish.scm new file mode 100644 index 000000000..4f5b40e0b --- /dev/null +++ b/src/blowfish/blowfish.scm @@ -0,0 +1,242 @@ +#| -*-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)) + +(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 diff --git a/src/blowfish/check.scm b/src/blowfish/check.scm new file mode 100644 index 000000000..36ce18590 --- /dev/null +++ b/src/blowfish/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the Blowfish wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "blowfish-check" (->environment '(blowfish))))) \ No newline at end of file diff --git a/src/blowfish/compile.scm b/src/blowfish/compile.scm new file mode 100644 index 000000000..7f6406d5f --- /dev/null +++ b/src/blowfish/compile.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/blowfish/configure.ac b/src/blowfish/configure.ac new file mode 100644 index 000000000..440a3a628 --- /dev/null +++ b/src/blowfish/configure.ac @@ -0,0 +1,87 @@ +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 diff --git a/src/blowfish/make.scm b/src/blowfish/make.scm new file mode 100644 index 000000000..1abe46fb0 --- /dev/null +++ b/src/blowfish/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/configure.ac b/src/configure.ac index cf103b3bf..601a4bd9a 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -64,12 +64,6 @@ else 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}]) @@ -155,25 +149,8 @@ directory, which is usually \`/usr/local/lib/mit-scheme-${mit_scheme_native_code 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]) @@ -218,11 +195,6 @@ win32/Makefile 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 @@ -234,7 +206,7 @@ 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 diff --git a/src/cref/Makefile-fragment b/src/cref/Makefile-fragment index 0aff32a2d..40966e301 100644 --- a/src/cref/Makefile-fragment +++ b/src/cref/Makefile-fragment @@ -3,5 +3,4 @@ TARGET_DIR = $(AUXDIR)/cref 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)/. diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm index cf5ce5f06..a5a1dadae 100644 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@ -37,26 +37,40 @@ USA. 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)))) (define (sort-descriptions descriptions) (letrec @@ -265,9 +279,10 @@ USA. (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) @@ -465,7 +480,7 @@ USA. 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))) diff --git a/src/edwin/Makefile-fragment b/src/edwin/Makefile-fragment index 93c81cb09..56d56450c 100644 --- a/src/edwin/Makefile-fragment +++ b/src/edwin/Makefile-fragment @@ -6,7 +6,7 @@ EDOPTS = debian-changelog eystep lisppaste manual midas nntp paredit pasmod \ 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}";\ diff --git a/src/edwin/schmod.scm b/src/edwin/schmod.scm index d087d0e67..384a0538a 100644 --- a/src/edwin/schmod.scm +++ b/src/edwin/schmod.scm @@ -294,11 +294,13 @@ Otherwise, it is shown in the echo area." (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) @@ -326,7 +328,7 @@ Otherwise, it is shown in the echo area." (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)))))))) diff --git a/src/edwin/snr.scm b/src/edwin/snr.scm index 14fce5874..51cab4a81 100644 --- a/src/edwin/snr.scm +++ b/src/edwin/snr.scm @@ -2128,22 +2128,26 @@ This unmarks the article indicated by point and any other articles in (update-buffer-news-thread-status buffer thread))))))) (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." diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 6a2f3e292..8fe46f1c5 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -47,8 +47,7 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg 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 <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)))))))) + +(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 diff --git a/src/ffi/ffi-test.c.stay b/src/ffi/ffi-test.c.stay deleted file mode 100644 index 03dc76927..000000000 --- a/src/ffi/ffi-test.c.stay +++ /dev/null @@ -1,50 +0,0 @@ -/* -*-C-*- */ - -/* A test library; used to test the C/Unix FFI. */ - -#include -#include -#include - -#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); -} diff --git a/src/ffi/ffi.pkg b/src/ffi/ffi.pkg index cf471ce51..685b23eb5 100644 --- a/src/ffi/ffi.pkg +++ b/src/ffi/ffi.pkg @@ -35,4 +35,15 @@ FFI System Packaging |# 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 diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm index 83f05de45..453be6678 100644 --- a/src/ffi/syntax.scm +++ b/src/ffi/syntax.scm @@ -66,19 +66,22 @@ USA. (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 diff --git a/src/gdbm/Makefile b/src/gdbm/Makefile new file mode 100644 index 000000000..874937749 --- /dev/null +++ b/src/gdbm/Makefile @@ -0,0 +1,65 @@ +# 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 diff --git a/src/gdbm/README b/src/gdbm/README new file mode 100644 index 000000000..b59f067f0 --- /dev/null +++ b/src/gdbm/README @@ -0,0 +1,24 @@ +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). diff --git a/src/gdbm/check.scm b/src/gdbm/check.scm new file mode 100644 index 000000000..77bbd67a1 --- /dev/null +++ b/src/gdbm/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the GDBM wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "gdbm-check" (->environment '(gdbm))))) \ No newline at end of file diff --git a/src/gdbm/compile.scm b/src/gdbm/compile.scm new file mode 100644 index 000000000..b94c01ac7 --- /dev/null +++ b/src/gdbm/compile.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/gdbm/gdbm-adapter.c b/src/gdbm/gdbm-adapter.c new file mode 100644 index 000000000..333e1fc9c --- /dev/null +++ b/src/gdbm/gdbm-adapter.c @@ -0,0 +1,205 @@ +/* -*-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 +#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); +} diff --git a/src/gdbm/gdbm-check.scm b/src/gdbm/gdbm-check.scm new file mode 100644 index 000000000..7b31c0375 --- /dev/null +++ b/src/gdbm/gdbm-check.scm @@ -0,0 +1,99 @@ +#| -*-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 +#include +#include +#include + +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); diff --git a/src/gdbm/gdbm.cdecl b/src/gdbm/gdbm.cdecl new file mode 100644 index 000000000..02b21153a --- /dev/null +++ b/src/gdbm/gdbm.cdecl @@ -0,0 +1,105 @@ +#| -*-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. + +;; 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 diff --git a/src/gdbm/gdbm.pkg b/src/gdbm/gdbm.pkg new file mode 100644 index 000000000..92f52e243 --- /dev/null +++ b/src/gdbm/gdbm.pkg @@ -0,0 +1,57 @@ +#| -*-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 diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm new file mode 100644 index 000000000..6eee58755 --- /dev/null +++ b/src/gdbm/gdbm.scm @@ -0,0 +1,374 @@ +#| -*-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)) + +(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))) + +(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 diff --git a/src/gdbm/make.scm b/src/gdbm/make.scm new file mode 100644 index 000000000..797efbb58 --- /dev/null +++ b/src/gdbm/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/gtk-screen/Makefile b/src/gtk-screen/Makefile new file mode 100644 index 000000000..fc04e30bf --- /dev/null +++ b/src/gtk-screen/Makefile @@ -0,0 +1,40 @@ +# 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 diff --git a/src/gtk-screen/Makefile-fragment b/src/gtk-screen/Makefile-fragment deleted file mode 100644 index c6835c276..000000000 --- a/src/gtk-screen/Makefile-fragment +++ /dev/null @@ -1,27 +0,0 @@ -# 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 diff --git a/src/gtk/.gitignore b/src/gtk/.gitignore deleted file mode 100644 index 393d9ee2a..000000000 --- a/src/gtk/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -gtk-const -gtk-const.c -gtk-const.scm -gtk-shim.c -gtk-shim.so -scmwidget.c -gtkio.c -swat-pole-zero.scm diff --git a/src/gtk/Clean.sh b/src/gtk/Clean.sh deleted file mode 100755 index bbd312a5e..000000000 --- a/src/gtk/Clean.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/sh - -set -e - -if [ ${#} -ne 1 ]; then - echo "usage: ${0} " - 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 diff --git a/src/gtk/Makefile-fragment b/src/gtk/Makefile-fragment deleted file mode 100644 index 18c0092d9..000000000 --- a/src/gtk/Makefile-fragment +++ /dev/null @@ -1,117 +0,0 @@ -#-*-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 diff --git a/src/gtk/Makefile.in b/src/gtk/Makefile.in new file mode 100644 index 000000000..554634811 --- /dev/null +++ b/src/gtk/Makefile.in @@ -0,0 +1,98 @@ +# 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 "
  • GTK User's Manual
    • " + +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 diff --git a/src/gtk/README b/src/gtk/README new file mode 100644 index 000000000..2c9d66788 --- /dev/null +++ b/src/gtk/README @@ -0,0 +1,16 @@ +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")) diff --git a/src/gtk/Tags.sh b/src/gtk/Tags.sh deleted file mode 100755 index 54c42828d..000000000 --- a/src/gtk/Tags.sh +++ /dev/null @@ -1,7 +0,0 @@ -#!/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 diff --git a/doc/gtk/check.scm b/src/gtk/check-doc.scm similarity index 94% rename from doc/gtk/check.scm rename to src/gtk/check-doc.scm index efae589a9..6e6f3d459 100644 --- a/doc/gtk/check.scm +++ b/src/gtk/check-doc.scm @@ -94,13 +94,11 @@ (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) diff --git a/src/gtk/check-optiondb.scm b/src/gtk/check-optiondb.scm new file mode 100644 index 000000000..1bfbfe2de --- /dev/null +++ b/src/gtk/check-optiondb.scm @@ -0,0 +1,15 @@ +#| -*-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 diff --git a/src/gtk/check.scm b/src/gtk/check.scm new file mode 100644 index 000000000..0dd591901 --- /dev/null +++ b/src/gtk/check.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index b17cd648a..b7a9470de 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -7,41 +7,44 @@ (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 diff --git a/src/gtk/configure.ac b/src/gtk/configure.ac new file mode 100644 index 000000000..37eda064e --- /dev/null +++ b/src/gtk/configure.ac @@ -0,0 +1,90 @@ +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 diff --git a/src/gtk/gtk-check.scm b/src/gtk/gtk-check.scm new file mode 100644 index 000000000..504a0ce2c --- /dev/null +++ b/src/gtk/gtk-check.scm @@ -0,0 +1,102 @@ +#| -*-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/") stringenvironment '(gtk gtk-widget))))) diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index 9203adcb7..6f9a654fa 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -21,7 +21,7 @@ USA. |# -;;;; C declarations for gtk.so. +;;;; C declarations for gtk-shim.so. (include "Includes/glib") (include "Includes/glib-object") diff --git a/doc/gtk/gtk.texinfo b/src/gtk/gtk.texinfo similarity index 100% rename from doc/gtk/gtk.texinfo rename to src/gtk/gtk.texinfo diff --git a/src/gtk/gtkio.c.stay b/src/gtk/gtkio.c similarity index 86% rename from src/gtk/gtkio.c.stay rename to src/gtk/gtkio.c index 9010cdd64..8ce801cdb 100644 --- a/src/gtk/gtkio.c.stay +++ b/src/gtk/gtkio.c @@ -23,29 +23,27 @@ USA. /* 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 -#include +#include #include -#define MIT_SCHEME /* Avoid re-declaring things included above. */ -#include "pruxffi.h" - +#include +#include +#include + +/* 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 @@ -77,8 +75,7 @@ static void set_registry (SchemeSource * source, GSList * new, double time); 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; @@ -96,28 +93,12 @@ trace (const char * format, ...) 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) { @@ -129,12 +110,12 @@ 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); @@ -177,13 +158,13 @@ scheme_source_check (GSource * source) 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); @@ -221,8 +202,8 @@ pending_io (SchemeSource * src) 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; } @@ -407,15 +388,15 @@ run_gtk (unsigned long registry, double time) 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); } @@ -468,7 +449,7 @@ yield_gtk (void) | ((((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. */ @@ -600,19 +581,21 @@ gtk_select_trace (gboolean trace_p) itself running in the scheme_thread, it invokes the original handler. */ -extern void OS_syserr_names (unsigned long * length, const char *** names); +#include +#include 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; @@ -620,16 +603,14 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) 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; @@ -640,7 +621,6 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) { int err; - trace (";signal_forwarder: forwarding signo %d\n", signo); err = pthread_kill (scheme_thread, signo); if (err != 0) { @@ -651,35 +631,48 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) } } -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 (); @@ -703,7 +696,7 @@ complain (const char *format, ...) { va_list args; va_start (args, format); - voutf_console (format, args); - outf_flush_console (); + vfprintf (stderr, format, args); + fflush (stderr); va_end (args); } diff --git a/src/gtk/gtkpanedview.c.stay b/src/gtk/gtkpanedview.c similarity index 100% rename from src/gtk/gtkpanedview.c.stay rename to src/gtk/gtkpanedview.c diff --git a/src/gtk/gtkscrolledview.c.stay b/src/gtk/gtkscrolledview.c similarity index 100% rename from src/gtk/gtkscrolledview.c.stay rename to src/gtk/gtkscrolledview.c diff --git a/src/gtk/make.scm b/src/gtk/make.scm index e4546bee8..61e2fe485 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -19,9 +19,6 @@ Load the Gtk option. |# (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 diff --git a/src/gtk/scmwidget.c.stay b/src/gtk/scmwidget.c similarity index 100% rename from src/gtk/scmwidget.c.stay rename to src/gtk/scmwidget.c diff --git a/src/gtk/swat-pole-zero.scm b/src/gtk/swat-pole-zero.scm new file mode 100644 index 000000000..708f548f0 --- /dev/null +++ b/src/gtk/swat-pole-zero.scm @@ -0,0 +1,495 @@ +;;; -*- 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 + "" + (lambda (x y) + (set! time-to-update-plot? #F) + (keep-track-of-coords x y)) + "%x" "%y") + (add-event-handler! + obj1 + "" + (lambda () + (store-coords) + (maybe-update-plot (pole-zero 'graph-canvas)) + )) + (add-event-handler! + obj1 + "" + (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 + "" + (lambda (x) + (set! time-to-update-plot? #F) + (keep-track-of-coords x)) + "%x") + (add-event-handler! + obj + "" + (lambda () + (store-coords) + (maybe-update-plot (pole-zero 'graph-canvas)) + )) + (add-event-handler! + obj + "" + (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 + "" + (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)))) + diff --git a/tests/gtk/test-gport-performance.scm b/src/gtk/test-gport-performance.scm similarity index 100% rename from tests/gtk/test-gport-performance.scm rename to src/gtk/test-gport-performance.scm diff --git a/src/imail/Makefile-fragment b/src/imail/Makefile-fragment index 142869f26..b43784c72 100644 --- a/src/imail/Makefile-fragment +++ b/src/imail/Makefile-fragment @@ -3,6 +3,5 @@ IMAIL_DIR = $(AUXDIR)/imail 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)/. diff --git a/src/md5/Makefile.in b/src/md5/Makefile.in new file mode 100644 index 000000000..dd0f845dc --- /dev/null +++ b/src/md5/Makefile.in @@ -0,0 +1,77 @@ +# 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 diff --git a/src/md5/README b/src/md5/README new file mode 100644 index 000000000..bbabe599d --- /dev/null +++ b/src/md5/README @@ -0,0 +1,23 @@ +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). diff --git a/src/md5/check.scm b/src/md5/check.scm new file mode 100644 index 000000000..09647192b --- /dev/null +++ b/src/md5/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the MD5 wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "md5-check" (->environment '(md5))))) \ No newline at end of file diff --git a/src/md5/compile.scm b/src/md5/compile.scm new file mode 100644 index 000000000..bae363634 --- /dev/null +++ b/src/md5/compile.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/md5/configure.ac b/src/md5/configure.ac new file mode 100644 index 000000000..0f1b3c068 --- /dev/null +++ b/src/md5/configure.ac @@ -0,0 +1,87 @@ +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 diff --git a/src/md5/make.scm b/src/md5/make.scm new file mode 100644 index 000000000..b84c650c3 --- /dev/null +++ b/src/md5/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/md5/md5-adapter.c b/src/md5/md5-adapter.c new file mode 100644 index 000000000..f2e2d2b65 --- /dev/null +++ b/src/md5/md5-adapter.c @@ -0,0 +1,61 @@ +/* -*-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 +} diff --git a/src/md5/md5-check.scm b/src/md5/md5-check.scm new file mode 100644 index 000000000..6a732be17 --- /dev/null +++ b/src/md5/md5-check.scm @@ -0,0 +1,39 @@ +#| -*-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 diff --git a/src/md5/md5-shim.h b/src/md5/md5-shim.h new file mode 100644 index 000000000..7b52d522c --- /dev/null +++ b/src/md5/md5-shim.h @@ -0,0 +1,53 @@ +/* -*-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 +#else +# ifdef HAVE_MD5_H +# include +# 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); diff --git a/src/md5/md5.cdecl b/src/md5/md5.cdecl new file mode 100644 index 000000000..025b40224 --- /dev/null +++ b/src/md5/md5.cdecl @@ -0,0 +1,52 @@ +#| -*-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. + +(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 diff --git a/src/md5/md5.pkg b/src/md5/md5.pkg new file mode 100644 index 000000000..6c8ea6aa2 --- /dev/null +++ b/src/md5/md5.pkg @@ -0,0 +1,40 @@ +#| -*-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 diff --git a/src/md5/md5.scm b/src/md5/md5.scm new file mode 100644 index 000000000..8beaa880a --- /dev/null +++ b/src/md5/md5.scm @@ -0,0 +1,142 @@ +#| -*-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)) + +(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 diff --git a/src/mhash/Makefile.in b/src/mhash/Makefile.in new file mode 100644 index 000000000..0a82d9acf --- /dev/null +++ b/src/mhash/Makefile.in @@ -0,0 +1,77 @@ +# 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 diff --git a/src/mhash/README b/src/mhash/README new file mode 100644 index 000000000..528bd107a --- /dev/null +++ b/src/mhash/README @@ -0,0 +1,23 @@ +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). diff --git a/src/mhash/check.scm b/src/mhash/check.scm new file mode 100644 index 000000000..aaaf5065c --- /dev/null +++ b/src/mhash/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the mhash wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "mhash-check" (->environment '(mhash))))) \ No newline at end of file diff --git a/src/mhash/compile.scm b/src/mhash/compile.scm new file mode 100644 index 000000000..0f4899c2e --- /dev/null +++ b/src/mhash/compile.scm @@ -0,0 +1,12 @@ +#| -*-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 diff --git a/src/mhash/configure.ac b/src/mhash/configure.ac new file mode 100644 index 000000000..14f2b2db2 --- /dev/null +++ b/src/mhash/configure.ac @@ -0,0 +1,85 @@ +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 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 diff --git a/src/mhash/make.scm b/src/mhash/make.scm new file mode 100644 index 000000000..9f2d5000f --- /dev/null +++ b/src/mhash/make.scm @@ -0,0 +1,9 @@ +#| -*-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 diff --git a/src/mhash/mhash-adapter.c b/src/mhash/mhash-adapter.c new file mode 100644 index 000000000..41210eace --- /dev/null +++ b/src/mhash/mhash-adapter.c @@ -0,0 +1,72 @@ +/* -*-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)); +} diff --git a/src/mhash/mhash-check.scm b/src/mhash/mhash-check.scm new file mode 100644 index 000000000..0fc6caac3 --- /dev/null +++ b/src/mhash/mhash-check.scm @@ -0,0 +1,39 @@ +#| -*-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 diff --git a/src/mhash/mhash-shim.h b/src/mhash/mhash-shim.h new file mode 100644 index 000000000..bebfac7a3 --- /dev/null +++ b/src/mhash/mhash-shim.h @@ -0,0 +1,46 @@ +/* -*-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 +#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); diff --git a/src/mhash/mhash.cdecl b/src/mhash/mhash.cdecl new file mode 100644 index 000000000..f6aa75c36 --- /dev/null +++ b/src/mhash/mhash.cdecl @@ -0,0 +1,84 @@ +#| -*-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. + +(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 diff --git a/src/mhash/mhash.pkg b/src/mhash/mhash.pkg new file mode 100644 index 000000000..1a248dd40 --- /dev/null +++ b/src/mhash/mhash.pkg @@ -0,0 +1,59 @@ +#| -*-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 diff --git a/src/mhash/mhash.scm b/src/mhash/mhash.scm new file mode 100644 index 000000000..376f79f05 --- /dev/null +++ b/src/mhash/mhash.scm @@ -0,0 +1,471 @@ +#| -*-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)) + +(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)))) + +(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)) + +(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))))) + +(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))) + +;;;; 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 diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 4c25bc6f8..291fd5331 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -927,6 +927,7 @@ AC_SUBST([INSTALL_INCLUDE]) AC_SUBST([CCLD]) AC_CONFIG_FILES([Makefile]) +AC_CONFIG_FILES([../ffi/build.scm]) AC_OUTPUT # Make custom compilation program for "makegen.scm". diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index 4a8f79b5b..94a89d14f 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -147,7 +147,7 @@ CLEAN_FILES = $(ALL_PROGRAMS) $(ALL_LIBS) $(ALL_DATA) $(EXTRA_PROGRAMS) 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 diff --git a/src/microcode/ntsig.c b/src/microcode/ntsig.c index 30303d5fc..d32585d30 100644 --- a/src/microcode/ntsig.c +++ b/src/microcode/ntsig.c @@ -190,6 +190,46 @@ update_interrupt_characters (void) } return; } + +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) diff --git a/src/microcode/os2ctty.c b/src/microcode/os2ctty.c index fb84587d3..e62edd2c2 100644 --- a/src/microcode/os2ctty.c +++ b/src/microcode/os2ctty.c @@ -94,11 +94,59 @@ OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask) 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 (); +} static char check_if_enabled (enum interrupt_handler handler) diff --git a/src/microcode/osctty.h b/src/microcode/osctty.h index 27889bb68..bb58a3ffb 100644 --- a/src/microcode/osctty.h +++ b/src/microcode/osctty.h @@ -37,4 +37,10 @@ typedef unsigned int Tinterrupt_enables; 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 */ diff --git a/src/microcode/osio.h b/src/microcode/osio.h index 7637f4387..c9599bd43 100644 --- a/src/microcode/osio.h +++ b/src/microcode/osio.h @@ -102,9 +102,6 @@ extern void OS_remove_from_select_registry (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); @@ -113,6 +110,5 @@ extern int OS_test_select_registry 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 */ diff --git a/src/microcode/prosio.c b/src/microcode/prosio.c index 769af21bf..e3e3ebb24 100644 --- a/src/microcode/prosio.c +++ b/src/microcode/prosio.c @@ -255,7 +255,7 @@ DEFINE_PRIMITIVE ("NEW-MAKE-PIPE", Prim_new_make_pipe, 2, 2, /* Select registry */ -select_registry_t +static select_registry_t arg_select_registry (int arg_number) { return ((select_registry_t) (arg_ulong_integer (arg_number))); diff --git a/src/microcode/prostty.c b/src/microcode/prostty.c index 59843da44..d98f092ab 100644 --- a/src/microcode/prostty.c +++ b/src/microcode/prostty.c @@ -104,3 +104,53 @@ DEFINE_PRIMITIVE ("TTY-SET-INTERRUPT-ENABLES", Prim_tty_set_interrupt_enables, 1 } 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); +} diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index f6900fa9a..146de8ba3 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -1085,3 +1085,13 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) 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); +} diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h index 920486818..017d64ac5 100644 --- a/src/microcode/pruxffi.h +++ b/src/microcode/pruxffi.h @@ -57,7 +57,6 @@ extern void callout_unseal (CalloutTrampIn expected); 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); @@ -97,4 +96,5 @@ extern SCM cons (SCM car, SCM cdr); /* 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 diff --git a/src/microcode/uxctty.c b/src/microcode/uxctty.c index d707e39ea..983ae4cfb 100644 --- a/src/microcode/uxctty.c +++ b/src/microcode/uxctty.c @@ -306,6 +306,75 @@ OS_ctty_fd (void) return (ctty_fildes); } +#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 */ + static void ctty_set_interrupt_chars (Tinterrupt_chars * ic) { @@ -385,7 +454,77 @@ OS_ctty_set_interrupt_enables (Tinterrupt_enables * mask) 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; +} +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) { diff --git a/src/microcode/uxenv.c b/src/microcode/uxenv.c index 4ff37518d..1de6808a7 100644 --- a/src/microcode/uxenv.c +++ b/src/microcode/uxenv.c @@ -182,7 +182,7 @@ OS_nanotime_since_utc_epoch (struct scheme_nanotime *t) #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 diff --git a/src/microcode/uxsig.c b/src/microcode/uxsig.c index ba7b4218c..7d8590789 100644 --- a/src/microcode/uxsig.c +++ b/src/microcode/uxsig.c @@ -879,6 +879,135 @@ interactive_interrupt_handler (SIGCONTEXT_T * scp) } } +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); + } +} + +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; + } +} + static void print_interrupt_chars (void) { @@ -886,24 +1015,20 @@ 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); diff --git a/src/microcode/uxsig.h b/src/microcode/uxsig.h index fe0baf094..f420a5f1a 100644 --- a/src/microcode/uxsig.h +++ b/src/microcode/uxsig.h @@ -146,6 +146,4 @@ extern void ta_abort_handler (void *); #define record_signal_delivery(signo) #endif -extern void foreach_async_signal (void(*func)(int signo)); - #endif /* SCM_UXSIG_H */ diff --git a/src/runtime/Makefile-fragment b/src/runtime/Makefile-fragment index 0d9854075..12885f821 100644 --- a/src/runtime/Makefile-fragment +++ b/src/runtime/Makefile-fragment @@ -5,8 +5,7 @@ RUNOPTS = chrsyn cpress format gdbm hashtb krypt mime-codec numint optiondb \ 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}";\ diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index a2b8097e2..d2c13ef31 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -245,9 +245,9 @@ USA. 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)))) @@ -521,6 +521,36 @@ USA. (vector-set! (get-fixed-objects-vector) #x41 callback-handler)) +;;; 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))))) + + (define calloutback-stack '()) (define %trace? #f) diff --git a/src/runtime/infutl.scm b/src/runtime/infutl.scm index 61bd7dc68..f32bf83fd 100644 --- a/src/runtime/infutl.scm +++ b/src/runtime/infutl.scm @@ -279,7 +279,20 @@ USA. (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))))))))) (define-integrable (dbg-block/layout-first-offset block) (let ((layout (dbg-block/layout block))) diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 120580769..6437bba8a 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -180,9 +180,12 @@ USA. (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) @@ -215,9 +218,12 @@ USA. (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) diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm index 25eae3f90..70a10f532 100644 --- a/src/runtime/packag.scm +++ b/src/runtime/packag.scm @@ -181,18 +181,28 @@ USA. (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"))) (define-integrable (make-package-file tag version descriptions loads) (vector tag version descriptions loads)) diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index d75ebdd29..8cddbb216 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -621,6 +621,22 @@ these rules: (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?) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 48eb1669f..1c054cf8e 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3126,6 +3126,7 @@ USA. pathname? system-library-directory-pathname system-library-pathname + with-system-library-directories uri->pathname user-homedir-pathname) (initialization (initialize-package!))) @@ -3333,7 +3334,11 @@ USA. 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) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index f59a09d60..25d86f0a0 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -302,7 +302,6 @@ USA. ;; 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) diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm index 8ee14b33d..1272b0ca2 100644 --- a/src/runtime/unxpth.scm +++ b/src/runtime/unxpth.scm @@ -115,9 +115,9 @@ USA. (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)) @@ -172,6 +172,7 @@ USA. (define (unparse-directory-component component) (cond ((eq? component 'UP) "..") + ((eq? component 'HERE) ".") ((string? component) component) (else (error:illegal-pathname-component component "directory component")))) @@ -204,7 +205,7 @@ USA. (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"))) @@ -314,17 +315,23 @@ USA. (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)) @@ -334,6 +341,12 @@ USA. (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 diff --git a/src/sf/Makefile-fragment b/src/sf/Makefile-fragment index 7374dd66a..a67c62c46 100644 --- a/src/sf/Makefile-fragment +++ b/src/sf/Makefile-fragment @@ -3,5 +3,4 @@ TARGET_DIR = $(AUXDIR)/sf 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)/. diff --git a/src/sos/Makefile-fragment b/src/sos/Makefile-fragment index 8e31527fe..03383e4ab 100644 --- a/src/sos/Makefile-fragment +++ b/src/sos/Makefile-fragment @@ -3,6 +3,5 @@ TARGET_DIR = $(AUXDIR)/sos 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)/. diff --git a/src/ssp/Makefile-fragment b/src/ssp/Makefile-fragment index 266833a0a..ee24ab54a 100644 --- a/src/ssp/Makefile-fragment +++ b/src/ssp/Makefile-fragment @@ -3,6 +3,5 @@ SSP_DIR = $(AUXDIR)/ssp 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)/. diff --git a/src/star-parser/Makefile-fragment b/src/star-parser/Makefile-fragment index c83ef9758..2bd4019d1 100644 --- a/src/star-parser/Makefile-fragment +++ b/src/star-parser/Makefile-fragment @@ -3,6 +3,5 @@ PARSER_DIR = $(AUXDIR)/star-parser 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)/. diff --git a/src/xdoc/Makefile-fragment b/src/xdoc/Makefile-fragment index 5767a3660..70cec20aa 100644 --- a/src/xdoc/Makefile-fragment +++ b/src/xdoc/Makefile-fragment @@ -3,6 +3,5 @@ XDOC_DIR = $(AUXDIR)/xdoc 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)/. diff --git a/src/xml/Makefile-fragment b/src/xml/Makefile-fragment index b00f49f2a..ed7c2a7dd 100644 --- a/src/xml/Makefile-fragment +++ b/src/xml/Makefile-fragment @@ -3,6 +3,5 @@ TARGET_DIR = $(AUXDIR)/xml 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)/. diff --git a/tests/check.scm b/tests/check.scm index eb55a901c..609db138f 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -54,8 +54,6 @@ USA. "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 diff --git a/tests/ffi/Makefile b/tests/ffi/Makefile new file mode 100644 index 000000000..fd6cd5ffe --- /dev/null +++ b/tests/ffi/Makefile @@ -0,0 +1,53 @@ +# 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 diff --git a/tests/ffi/ffi-test.c b/tests/ffi/ffi-test.c new file mode 100644 index 000000000..c2e4f1304 --- /dev/null +++ b/tests/ffi/ffi-test.c @@ -0,0 +1,74 @@ +/* -*-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 +#include +#include + +#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); +} diff --git a/src/ffi/ffi-test.cdecl b/tests/ffi/ffi-test.cdecl similarity index 100% rename from src/ffi/ffi-test.cdecl rename to tests/ffi/ffi-test.cdecl diff --git a/src/ffi/ffi-test.h b/tests/ffi/ffi-test.h similarity index 100% rename from src/ffi/ffi-test.h rename to tests/ffi/ffi-test.h diff --git a/tests/ffi/test-ffi-wrapper.scm b/tests/ffi/test-ffi-wrapper.scm index 59caba116..54e444b59 100644 --- a/tests/ffi/test-ffi-wrapper.scm +++ b/tests/ffi/test-ffi-wrapper.scm @@ -2,7 +2,14 @@ (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))) diff --git a/tests/ffi/test-ffi.scm b/tests/ffi/test-ffi.scm index 1240038c1..90d5d3c07 100644 --- a/tests/ffi/test-ffi.scm +++ b/tests/ffi/test-ffi.scm @@ -1,8 +1,47 @@ -;;;-*-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 diff --git a/tests/gtk/test-gtk.scm b/tests/gtk/test-gtk.scm deleted file mode 100644 index eb89591f3..000000000 --- a/tests/gtk/test-gtk.scm +++ /dev/null @@ -1,91 +0,0 @@ -#| -*-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