-# $Id: Makefile.in,v 1.39 2007/05/15 05:02:08 cph Exp $
+# $Id: Makefile.in,v 1.40 2007/06/06 19:42:38 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
INSTALLED_SUBDIRS = microcode runtime $(SUBDIRS_1) $(SUBDIRS_2)
LIARC_BOOT_BUNDLES = $(SUBDIRS_1) compiler
-LIARC_BUNDLES = $(LIARC_BOOT_BUNDLES) $(SUBDIRS_2)
+LIARC_INSTALLED_BUNDLES = $(SUBDIRS_1) $(SUBDIRS_2)
+LIARC_BUNDLES = $(LIARC_INSTALLED_BUNDLES) compiler
AUXDIR = @AUXDIR@
EDETC = $(AUXDIR)/edwin/etc
liarc-dist: liarc-stamp distclean
-c-boot-compiler.com:
- @$(top_srcdir)/etc/c-boot-compiler.sh mit-scheme $@
-
-liarc-stamp: c-boot-compiler.com
- @$(top_srcdir)/etc/c-prepare.sh mit-scheme --band $<
+liarc-stamp:
+ @$(top_srcdir)/etc/compile-boot-compiler.sh mit-scheme
+ @$(top_srcdir)/etc/c-prepare.sh mit-scheme
echo "done" > liarc.stamp
-
all-liarc: liarc-compile-scheme
$(MAKE) compile-microcode
$(MAKE) compile-liarc-bundles
rm -rf boot-lib
-liarc-compile-scheme: boot-lib/compiler.com c-clean
+liarc-compile-scheme: boot-lib/liarc-compiler.com c-clean
@$(top_srcdir)/etc/c-compile.sh boot-lib/scheme --library boot-lib \
- --band boot-lib/compiler.com
+ --band boot-lib/liarc-compiler.com
-boot-lib/compiler.com: compile-microcode compile-liarc-boot-bundles
- $(mkinstalldirs) boot-lib boot-lib/include boot-lib/lib
- $(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm boot-lib/.
- $(INSTALL_PROGRAM) microcode/scheme boot-lib/.
+boot-lib/liarc-compiler.com: boot-lib/scheme compile-liarc-boot-bundles
$(INSTALL_PROGRAM) microcode/liarc-cc boot-lib/.
$(INSTALL_PROGRAM) microcode/liarc-ld boot-lib/.
+ $(mkinstalldirs) boot-lib/include
$(INSTALL_DATA) microcode/*.h boot-lib/include/.
@for BN in $(LIARC_BOOT_BUNDLES); do \
CMD="$(INSTALL_DATA) $${BN}/$${BN}.so boot-lib/lib/.";\
echo "$${CMD}"; eval "$${CMD}";\
done
- @$(top_srcdir)/etc/c-boot-compiler-2.sh boot-lib boot-lib/compiler.com
+ @$(top_srcdir)/etc/build-boot-compiler.sh boot-lib liarc-compiler.com
+
+boot-lib/scheme: compile-microcode
+ $(mkinstalldirs) boot-lib boot-lib/lib
+ $(INSTALL_DATA) $(top_srcdir)/etc/optiondb.scm boot-lib/.
+ $(INSTALL_PROGRAM) microcode/scheme boot-lib/.
+ $(INSTALL_PROGRAM) microcode/gen-nonce boot-lib/.
+ $(INSTALL_DATA) microcode/*.so boot-lib/lib/.
+ rm -f boot-lib/star-parser; ln -s ../star-parser boot-lib/.
+ rm -f boot-lib/options; ln -s ../runtime boot-lib/options
compile-liarc-boot-bundles:
@for BN in $(LIARC_BOOT_BUNDLES); do \
done
install-liarc-bundles:
- @for BN in $(LIARC_BUNDLES); do \
+ @for BN in $(LIARC_INSTALLED_BUNDLES); do \
CMD="(cd $${BN} && $(MAKE) install-liarc-bundle)";\
echo "$${CMD}"; eval "$${CMD}";\
done
+native-from-liarc: boot-lib/native-compiler.com clean
+ $(MAKE) compile-microcode
+ @$(top_srcdir)/etc/compile.sh boot-lib/scheme --library boot-lib \
+ --band boot-lib/native-compiler.com
+ rm -rf boot-lib
+boot-lib/native-compiler.com: boot-lib/scheme native-prepare
+ @$(top_srcdir)/etc/build-boot-compiler.sh boot-lib native-compiler.com
-native: native-boot-compiler.com
- @$(top_srcdir)/etc/compile.sh mit-scheme-c --band $<
-
-native-boot-compiler.com:
- @$(top_srcdir)/etc/c-boot-compiler.sh mit-scheme-c $@
+native-prepare:
+ @$(top_srcdir)/etc/compile-boot-compiler.sh mit-scheme-c
+ (cd compiler && $(MAKE) compile-liarc-bundle)
+ @$(top_srcdir)/etc/native-prepare.sh mit-scheme-c
#!/bin/sh
#
-# $Id: Setup.sh,v 1.25 2007/05/14 16:50:34 cph Exp $
+# $Id: Setup.sh,v 1.26 2007/06/06 19:42:38 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
. etc/functions.sh
+INSTALLED_SUBDIRS="cref edwin imail sf sos ssp star-parser xml"
+OTHER_SUBDIRS="6001 compiler runtime win32 xdoc microcode"
+
# lib
maybe_mkdir lib
maybe_mkdir lib/lib
maybe_link lib/edwin/etc/mime.types ../../../etc/mime.types
maybe_link lib/edwin/autoload ../../edwin
-BUNDLES="6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml"
-
-for SUBDIR in ${BUNDLES} runtime win32 microcode; do
+for SUBDIR in ${INSTALLED_SUBDIRS} ${OTHER_SUBDIRS}; do
echo "setting up ${SUBDIR}"
maybe_link ${SUBDIR}/Setup.sh ../etc/Setup.sh
(cd ${SUBDIR} && ./Setup.sh "$@")
done
-
-maybe_link compiler/compiler.pkg machines/C/compiler.pkg
-mit-scheme --heap 4000 <<EOF
-(begin
- (load "etc/utilities")
- (generate-c-bundles (quote (${BUNDLES}))))
-EOF
-rm -f compiler/compiler.pkg
-
-for SUBDIR in ${BUNDLES} runtime win32; do
- echo "creating ${SUBDIR}/Makefile.in"
- rm -f ${SUBDIR}/Makefile.in
- cat etc/std-makefile-prefix > ${SUBDIR}/Makefile.in
- cat ${SUBDIR}/Makefile-fragment >> ${SUBDIR}/Makefile.in
- if [ -f ${SUBDIR}/Makefile-bundle ]; then
- cat ${SUBDIR}/Makefile-bundle >> ${SUBDIR}/Makefile.in
- rm -f ${SUBDIR}/Makefile-bundle
- fi
- cat etc/std-makefile-suffix >> ${SUBDIR}/Makefile.in
-done
--- /dev/null
+#!/bin/sh
+
+# $Id: choose-machine.sh,v 1.1 2007/06/06 19:42:38 cph Exp $
+#
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007 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.
+
+set -e
+
+if [ ${#} -eq 0 ]; then
+ MACHINE=
+elif [ ${#} -eq 1 ]; then
+ MACHINE=${1}
+else
+ echo "usage: ${0} [NATIVE-CODE-TYPE]"
+ exit 1
+fi
+
+DIR=`dirname ${0}`
+
+chosen ()
+{
+ if [ -d "${DIR}/machines/${1}" ]; then
+ echo "${1}"
+ exit 0
+ else
+ echo "Unknown machine type: ${1}" 1>&2
+ exit 1
+ fi
+}
+
+case "${MACHINE}" in
+"" | yes)
+ ;;
+c)
+ chosen C
+ ;;
+no)
+ chosen none
+ ;;
+*)
+ chosen "${MACHINE}"
+esac
+
+[ -f ../liarc.stamp ] && chosen C
+
+case `${DIR}/config.guess` in
+alpha-* | alphaev[56]-* | alphaev56-* | alphapca56-*)
+ chosen alpha
+ ;;
+m68k-*)
+ chosen bobcat
+ ;;
+i[3456]86-*)
+ chosen i386
+ ;;
+mips-* | mipsel-*)
+ chosen mips
+ ;;
+sparc-*)
+ chosen sparc
+ ;;
+hppa-* | hppa1.[01]-* | hppa2.?-*)
+ chosen spectrum
+ ;;
+vax-*)
+ chosen vax
+ ;;
+*)
+ chosen none
+ ;;
+esac
#!/bin/sh
-# $Id: configure,v 1.17 2007/05/04 01:24:31 cph Exp $
+# $Id: configure,v 1.18 2007/06/06 19:42:38 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
+set -e
+
MACHINE=
while test $# -gt 0; do
case "${1}" in
- --enable-native-code=c)
- MACHINE=C
- shift
- ;;
- --enable-native-code)
- MACHINE=
+ --enable-native-code=*)
+ MACHINE=`echo "${1}" | sed -e 's/--enable-native-code=//'`
shift
;;
- --disable-native-code | --enable-native-code=no)
- MACHINE=none
+ --disable-native-code)
+ MACHINE=no
shift
;;
*)
;;
esac
done
+MACHINE=`./choose-machine.sh "${MACHINE}"`
-if test x${MACHINE} = x && test -f ../liarc.stamp; then
- MACHINE=C
-fi
-
-if test x${MACHINE} = x; then
- case `./config.guess` in
- alpha-* | alphaev[56]-* | alphaev56-* | alphapca56-*)
- MACHINE=alpha
- ;;
- m68k-*)
- MACHINE=bobcat
- ;;
- i[3456]86-*)
- MACHINE=i386
- ;;
- mips-* | mipsel-*)
- MACHINE=mips
- ;;
- sparc-*)
- MACHINE=sparc
- ;;
- hppa-* | hppa1.[01]-* | hppa2.?-*)
- MACHINE=spectrum
- ;;
- vax-*)
- MACHINE=vax
- ;;
- *)
- MACHINE=none
- ;;
- esac
-fi
-
-if test ${MACHINE} = none; then
- exit 0
-fi
+CMD="rm -f machine"
+echo "${CMD}"; eval "${CMD}"
-echo "rm -f machine"
-rm -f machine
-echo "ln -s machines/${MACHINE} machine"
-ln -s machines/${MACHINE} machine
+CMD="ln -s machines/${MACHINE} machine"
+echo "${CMD}"; eval "${CMD}"
LINKS="compiler.cbf compiler.pkg compiler.sf make.com"
if test "${MACHINE}" = C; then
fi
for FN in ${LINKS}; do
- echo "ln -s machine/${FN} ."
- ln -s machine/${FN} .
+ if [ ! -e ${FN} ]; then
+ CMD="ln -s machine/${FN} ."
+ echo "${CMD}"; eval "${CMD}"
+ fi
done
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.27 2007/05/14 16:49:15 cph Exp $
+$Id: compiler.pkg,v 1.28 2007/06/06 19:42:38 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
make-dbg-info-vector
split-inf-structure!)
(import (runtime unparser)
- *unparse-uninterned-symbols-by-name?*))
+ *unparse-uninterned-symbols-by-name?*)
+ (import (runtime load)
+ fasload-object-file))
\f
(define-package (compiler debug)
(files "base/debug")
#| -*-Scheme-*-
-$Id: cout.scm,v 1.40 2007/05/14 16:49:16 cph Exp $
+$Id: cout.scm,v 1.41 2007/06/06 19:42:38 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare-dynamic-object-initialization handle)))
(define (default-file-handle)
- (or (liarc-object-pathname->handle
- (pathname-new-type *compiler-output-pathname*
- (let ((t (pathname-type *compiler-input-pathname*)))
- (if (equal? t "bin")
- (c-output-extension)
- t))))
- "handle"))
+ (file-namestring
+ (pathname-new-type *compiler-output-pathname*
+ (let ((t (pathname-type *compiler-input-pathname*)))
+ (if (equal? t "bin")
+ (c-output-extension)
+ t)))))
\f
(define (stringify suffix initial-label lap-code info-output-pathname)
;; returns <code-name data-name ntags symbol-table code proxy>
(c:line (c:call "DECLARE_DATA_OBJECT" (c:string handle) proc)))
(define (declare-dynamic-initialization handle)
- (c:line (c:call "DECLARE_DYNAMIC_INITIALIZATION" (c:string handle))))
+ (c:line (c:call "DECLARE_DYNAMIC_INITIALIZATION"
+ (c:string handle)
+ (vector-8b->hexadecimal (random-byte-vector 8)))))
(define (declare-dynamic-object-initialization handle)
- (c:line (c:call "DECLARE_DYNAMIC_OBJECT_INITIALIZATION" (c:string handle))))
+ (c:line (c:call "DECLARE_DYNAMIC_OBJECT_INITIALIZATION"
+ (c:string handle)
+ (vector-8b->hexadecimal (random-byte-vector 8)))))
(define (declare-subcodes decl-name blocks)
(if (and (pair? blocks)
#| -*-Scheme-*-
-$Id: ctop.scm,v 1.29 2007/05/20 01:51:27 cph Exp $
+$Id: ctop.scm,v 1.30 2007/06/06 19:42:38 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load shared-library-pathname environment))))
(define (compiler-output->compiled-expression compiler-output)
- (finish-c-compilation compiler-output fasload-liarc-object-file))
+ (finish-c-compilation compiler-output fasload-object-file))
(define (compile-scode/internal/hook action)
(if (not (eq? *info-output-filename* 'KEEP))
#| -*-Scheme-*-
-$Id: make.scm,v 1.10 2007/04/14 03:54:42 cph Exp $
+$Id: make.scm,v 1.11 2007/06/06 19:42:38 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load-option 'SYNCHRONOUS-SUBPROCESS)
-(declare-shared-library "compiler" (lambda () #t))
(let ((value ((load "base/make")
(string-append "C/" microcode-id/machine-type))))
(set! (access compiler:compress-top-level?
dnl Process this file with autoconf to produce a configure script.
AC_INIT([MIT/GNU Scheme], [7.7.91], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.14 2007/05/15 05:02:02 cph Exp $])
+AC_REVISION([$Id: configure.ac,v 1.15 2007/06/06 19:42:38 cph Exp $])
AC_CONFIG_SRCDIR([microcode/boot.c])
AC_PROG_MAKE_SET
INSTALL="${INSTALL} --preserve-timestamps"
fi
+etc/create-makefiles.sh "${enable_native_code}"
+
AC_CONFIG_SUBDIRS([microcode compiler])
AC_CONFIG_FILES([
Makefile
#| -*-Scheme-*-
-$Id: make.scm,v 1.31 2007/04/14 03:54:46 cph Exp $
+$Id: make.scm,v 1.32 2007/06/06 19:42:38 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
(load-option 'RB-TREE)
-(declare-shared-library "cref" (lambda () #t))
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
((access with-directory-rewriting-rule
#| -*-Scheme-*-
-$Id: make.scm,v 3.123 2007/01/05 21:19:23 cph Exp $
+$Id: make.scm,v 3.124 2007/06/06 19:42:39 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
+(with-loader-base-uri (system-library-uri "edwin/")
(lambda ()
- ((access with-directory-rewriting-rule
- (->environment '(RUNTIME COMPILER-INFO)))
- (working-directory-pathname)
- (pathname-as-directory "edwin")
- (lambda ()
- (declare-shared-library "edwin" (lambda () #t))
- (load-package-set "edwin"
- `((alternate-package-loader
- . ,(load "edwin.bld" system-global-environment))))))))
+ (load-package-set "edwin"
+ `((alternate-package-loader
+ . ,(load "edwin.bld" system-global-environment))))))
(add-subsystem-identification! "Edwin" '(3 116))
\ No newline at end of file
#!/bin/sh
#
-# $Id: build-bands.sh,v 1.11 2007/05/14 16:50:40 cph Exp $
+# $Id: build-bands.sh,v 1.12 2007/06/06 19:42:39 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
cd runtime
if [ -f make.o ]; then
- FASL=runtime_make.so
+ FASL=http://www.gnu.org/software/mit-scheme/lib/runtime/make.so
elif [ -f make.com ]; then
FASL=make.com
else
#!/bin/sh
#
-# $Id: c-boot-compiler-2.sh,v 1.1 2007/05/14 16:50:41 cph Exp $
+# $Id: build-boot-compiler.sh,v 1.1 2007/06/06 19:42:39 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
LIB=${1}
BAND=${2}
else
- echo "usage: ${0} <library-dir> <band>"
+ echo "usage: ${0} <lib-dir> <band>"
exit 1
fi
-CMD="microcode/scheme --library ${LIB} --fasl runtime_make.so --heap 6000"
+cd runtime
+
+if [ -f make.o ]; then
+ FASL=http://www.gnu.org/software/mit-scheme/lib/runtime/make.so
+elif [ -f make.com ]; then
+ FASL=make.com
+else
+ echo "Can't find argument for --fasl."
+ exit 1
+fi
+
+CMD="../microcode/scheme --library ../${LIB} --fasl ${FASL} --heap 6000"
echo "${CMD}"
eval "${CMD}" <<EOF
(begin
(load-option (quote compiler))
(load-option (quote cref))
(load-option (quote *parser))
- (disk-save "${BAND}"))
+ (disk-save "../${LIB}/${BAND}"))
EOF
#!/bin/sh
#
-# $Id: c-bundle.sh,v 1.5 2007/05/14 16:50:42 cph Exp $
+# $Id: c-bundle.sh,v 1.6 2007/06/06 19:42:39 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
usage ()
{
- echo "usage: ${0} TYPE SYSTEM FILES ..."
+ echo "usage: ${0} AUXDIR TYPE SYSTEM FILES ..."
echo " TYPE must be \`library' or \`static'."
exit 1
}
-if [ ! ${#} -gt 2 ]; then
+if [ ${#} -lt 4 ]; then
usage
fi
-TYPE=${1}
-SYSTEM=${2}
-shift 2
+AUXDIR=${1}
+TYPE=${2}
+SYSTEM=${3}
+shift 3
-(grep '^DECLARE_COMPILED_CODE' "${@}" && \
- grep '^DECLARE_COMPILED_DATA' "${@}" && \
- grep '^DECLARE_DATA_OBJECT' "${@}") \
-| sed -e 's/.*:/ /' > "${SYSTEM}.h"
+GEN_NONCE=${AUXDIR}/gen-nonce
+EXTRACT_DECLS=${AUXDIR}/extract-liarc-decls
+
+"${EXTRACT_DECLS}" "${@}" > "${SYSTEM}.h"
cat <<EOF > "${SYSTEM}.c"
EOF
;;
library)
+ NONCE=`"${GEN_NONCE}" 8`
cat <<EOF >> "${SYSTEM}.c"
#define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \\
#include "${SYSTEM}.h"
return (0);
}
+
+const char dload_nonce [] = "${NONCE}";
EOF
;;
*)
#!/bin/sh
#
-# $Id: c-prepare.sh,v 1.6 2007/05/08 12:54:52 cph Exp $
+# $Id: c-prepare.sh,v 1.7 2007/06/06 19:42:39 cph Exp $
#
-# Copyright 2007 Massachusetts Institute of Technology
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007 Massachusetts Institute of Technology
#
# This file is part of MIT/GNU Scheme.
#
set -e
-if [ ${#} -eq 0 ]; then
- SCHEME_COMPILER="mit-scheme-c --compiler"
+if [ ${#} -eq 1 ]; then
+ EXE=${1}
else
- SCHEME_COMPILER=${1}
- shift
- while [ ${#} -gt 0 ]; do
- SCHEME_COMPILER="${SCHEME_COMPILER} ${1}"
- shift
- done
+ echo "usage: ${0} <executable>"
+ exit 1
fi
+CMD="${EXE} --heap 6000"
-SCHEME_COMPILER="${SCHEME_COMPILER} --heap 6000"
-
-echo "${SCHEME_COMPILER}"
-${SCHEME_COMPILER} <<EOF
+echo "${CMD}"
+${CMD} <<EOF
(begin
(load "etc/compile.scm")
+ (compile-bootstrap-3)
(c-prepare))
EOF
#!/bin/sh
#
-# $Id: c-boot-compiler.sh,v 1.7 2007/05/10 16:44:11 cph Exp $
+# $Id: compile-boot-compiler.sh,v 1.1 2007/06/06 19:42:39 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
set -e
-if [ ${#} -eq 2 ]; then
+if [ ${#} -eq 1 ]; then
EXE=${1}
- OUT=${2}
else
- echo "usage: ${0} <executable> <output-file>"
+ echo "usage: ${0} <executable>"
exit 1
fi
CMD="${EXE} --heap 6000"
-# Step 1: Load CREF and SF, and syntax the compiler configured with
-# the C back end.
-
echo "${CMD}"
${CMD} <<EOF
(begin
(compile-bootstrap-1))
EOF
-# Step 2: Now that the compiler with the C back end is syntaxed and
-# packaged, use the native compiler to compile the bootstrap C
-# compiler natively.
-
echo "${CMD} --compiler"
${CMD} --compiler <<EOF
(begin
(load "etc/compile.scm")
(compile-bootstrap-2))
EOF
-
-# Step 3: Load up the natively compiled compiler with the C back end,
-# and save a band.
-
-echo "${CMD}"
-${CMD} <<EOF
-(begin
- (load "etc/compile.scm")
- (compile-bootstrap-3)
- (disk-save "${OUT}"))
-EOF
#| -*-Scheme-*-
-$Id: compile.scm,v 1.19 2007/05/14 16:50:45 cph Exp $
+$Id: compile.scm,v 1.20 2007/06/06 19:42:39 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (compile-cref compile-dir)
(compile-dir "cref")
(if (not (name->package '(cross-reference)))
- (load-dir "cref")))
+ (with-working-directory-pathname "cref"
+ (lambda ()
+ (load "make")))))
(define (compile-dir name)
(with-working-directory-pathname name
(load (pathname-new-type name "sf"))
(load (pathname-new-type name "cbf")))
(load "compile")))))
-
-(define (load-dir name)
- (with-working-directory-pathname name
- (lambda ()
- (cond ((and (string=? name "compiler")
- (eq? microcode-id/compiled-code-type 'C))
- (load "machines/C/make"))
- ((file-exists? (pathname-new-type name "sf"))
- (load "make"))
- (else
- (load "load"))))))
\f
(define (compile-bootstrap-1)
(load-option 'SF)
(load "compiler.sf"))))
(define (compile-bootstrap-2)
- (if (eq? microcode-id/compiled-code-type 'C)
- (fluid-let ((compiler:invoke-c-compiler? #f))
- (with-working-directory-pathname "compiler"
- (lambda ()
- (load "compiler.cbf")))
- (c-compile-pkgs "compiler"))
- (with-working-directory-pathname "compiler"
- (lambda ()
- (load "compiler.cbf")))))
+ (let ((action
+ (lambda ()
+ (with-working-directory-pathname "compiler"
+ (lambda ()
+ (load "compiler.cbf")))
+ (c-compile-pkgs "compiler"))))
+ (if (eq? microcode-id/compiled-code-type 'C)
+ (in-liarc action)
+ (action))))
(define (compile-bootstrap-3)
(load-option 'SF)
- (load-dir "compiler"))
+ (with-working-directory-pathname "compiler"
+ (lambda ()
+ (if (and (eq? microcode-id/compiled-code-type 'C)
+ (file-exists? "compiler.so"))
+ (load "compiler.so"))
+ (load
+ (string-append (or (file-symbolic-link? "machine")
+ (error "Missing compiler/machine link."))
+ "/make")))))
(define (c-prepare)
- (fluid-let ((compiler:invoke-c-compiler? #f))
- (compile-boot-dirs c-compile-dir)
- (cf "microcode/utabmd")))
+ (in-liarc
+ (lambda ()
+ (compile-boot-dirs c-compile-dir)
+ (cf "microcode/utabmd"))))
+
+(define (native-prepare)
+ (compile-boot-dirs compile-dir)
+ (sf "microcode/utabmd"))
(define (c-compile)
- (fluid-let ((compiler:invoke-c-compiler? #f))
- (compile-all-dirs c-compile-dir)
- (cf "microcode/utabmd")
- (cbf "edwin/edwin.bld")))
+ (in-liarc
+ (lambda ()
+ (compile-all-dirs c-compile-dir)
+ (cf "microcode/utabmd")
+ (cbf "edwin/edwin.bld"))))
+(define (in-liarc thunk)
+ (fluid-let ((compiler:invoke-c-compiler? #f))
+ (thunk)))
+
(define (c-compile-dir name)
(compile-dir name)
(c-compile-pkgs name))
--- /dev/null
+#!/bin/sh
+
+# $Id: create-makefiles.sh,v 1.1 2007/06/06 19:42:39 cph Exp $
+#
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007 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.
+
+set -e
+
+if [ ${#} -eq 1 ]; then
+ NATIVE_CODE=${1}
+else
+ echo "usage: ${0} NATIVE-CODE-TYPE"
+ exit 1
+fi
+
+MDIR=`compiler/choose-machine.sh "${NATIVE_CODE}"`
+
+CMD="rm -f compiler/machine"
+echo "${CMD}"; eval "${CMD}"
+
+CMD="ln -s machines/${MDIR} compiler/machine"
+echo "${CMD}"; eval "${CMD}"
+
+CMD="rm -f compiler/compiler.pkg"
+echo "${CMD}"; eval "${CMD}"
+
+CMD="ln -s machine/compiler.pkg compiler/."
+echo "${CMD}"; eval "${CMD}"
+
+BUNDLES="6001 compiler cref edwin imail sf sos ssp star-parser xdoc xml"
+
+mit-scheme --heap 4000 <<EOF
+(begin
+ (load "etc/utilities")
+ (generate-c-bundles (quote (${BUNDLES})) "${MDIR}"))
+EOF
+
+for SUBDIR in ${BUNDLES} runtime win32; do
+ echo "creating ${SUBDIR}/Makefile.in"
+ rm -f ${SUBDIR}/Makefile.in
+ cat etc/std-makefile-prefix > ${SUBDIR}/Makefile.in
+ cat ${SUBDIR}/Makefile-fragment >> ${SUBDIR}/Makefile.in
+ if test -f ${SUBDIR}/Makefile-bundle; then
+ cat ${SUBDIR}/Makefile-bundle >> ${SUBDIR}/Makefile.in
+ rm -f ${SUBDIR}/Makefile-bundle
+ fi
+ cat etc/std-makefile-suffix >> ${SUBDIR}/Makefile.in
+done
--- /dev/null
+#!/bin/sh
+#
+# $Id: native-prepare.sh,v 1.1 2007/06/06 19:42:39 cph Exp $
+#
+# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+# 2005, 2006, 2007 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.
+
+set -e
+
+if [ ${#} -eq 1 ]; then
+ EXE=${1}
+else
+ echo "usage: ${0} <executable>"
+ exit 1
+fi
+CMD="${EXE} --heap 6000"
+
+echo "${CMD}"
+${CMD} <<EOF
+(begin
+ (load "etc/compile.scm")
+ (compile-bootstrap-3)
+ (native-prepare))
+EOF
#| -*-Scheme-*-
-$Id: optiondb.scm,v 1.20 2007/05/02 13:51:03 cph Exp $
+$Id: optiondb.scm,v 1.21 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
,@(let ((d (get-environment-variable "MITSCHEME_INF_DIRECTORY")))
(if d
(list d)
- '()))
- "/usr/local/scheme/linux"
- "/scheme/v7/linux")))
+ '())))))
(files
(if (default-object? filename)
(list "make" "load")
- (list filename)))
- (test
- (lambda (name)
- (or (file-exists? name)
- (there-exists? load/default-types
- (lambda (type)
- (file-exists?
- (pathname-new-type name (car type)))))))))
- (lambda ()
- (if (not (name->package package-name))
- (begin
- (ignore-errors
- (lambda ()
- (load (merge-pathnames
- place
- (system-library-directory-pathname "lib")))))
- (let dir-loop ((dirs dirs))
- (if (pair? dirs)
- (let ((directory
- (merge-pathnames place
- (pathname-as-directory (car dirs)))))
- (if (file-directory? directory)
- (let file-loop ((files files))
- (if (pair? files)
- (if (test
- (merge-pathnames
- (car files)
- (pathname-as-directory directory)))
- (with-working-directory-pathname directory
- (lambda ()
- (load (car files) '(RUNTIME))))
- (file-loop (cdr files)))
- (dir-loop (cdr dirs))))
- (dir-loop (cdr dirs))))
- (error "Unable to find package directory:" place))))))))
+ (list filename))))
+ (let ((try-dir
+ (lambda (base-dir)
+ (let ((dir
+ (pathname-as-directory
+ (merge-pathnames place
+ (pathname-as-directory base-dir)))))
+ (let file-loop ((files files))
+ (if (pair? files)
+ (let ((pathname (merge-pathnames (car files) dir)))
+ (if (file-loadable? pathname)
+ (values dir pathname)
+ (file-loop (cdr files))))
+ (values #f #f))))))
+ (finish
+ (lambda (dir pathname)
+ (with-working-directory-pathname dir
+ (lambda ()
+ (load pathname '(RUNTIME))))))
+ (lose (lambda () (error "Unable to find package directory:" place))))
+ (lambda ()
+ (if (not (name->package package-name))
+ (if (condition?
+ (ignore-errors
+ (lambda ()
+ (load (merge-pathnames
+ place
+ (system-library-directory-pathname "lib"))))))
+ (let dir-loop ((dirs dirs))
+ (if (not (pair? dirs))
+ (lose))
+ (receive (dir pathname) (try-dir (car dirs))
+ (if dir
+ (finish dir pathname)
+ (dir-loop (cdr dirs)))))
+ (receive (dir pathname)
+ (try-dir (system-library-directory-pathname))
+ (if (not dir)
+ (lose))
+ (finish dir pathname))))))))
\f
(define-load-option 'EDWIN
(guarded-system-loader '(edwin) "edwin"))
-# $Id: std-makefile-prefix,v 1.2 2007/05/14 16:50:48 cph Exp $
+# $Id: std-makefile-prefix,v 1.3 2007/06/06 19:42:40 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
AUXDIR = @AUXDIR@
-.c.o:
- @$(top_builddir)/microcode/liarc-cc $*.o $*.c \
- -I$(top_builddir)/microcode
-
all:
echo "No ALL action"
#| -*-Scheme-*-
-$Id: utilities.scm,v 1.3 2007/05/15 05:23:22 cph Exp $
+$Id: utilities.scm,v 1.4 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load-option (quote CREF))
\f
-(define (generate-c-bundles bundles)
- (for-each
- (lambda (bundle)
- (with-notification (lambda (port)
- (write-string "Generating bundle rule for " port)
- (write-string bundle port))
- (lambda ()
- (let ((names (bundle-files bundle))
- (so-file (string-append bundle ".so")))
- (call-with-output-file (string-append bundle "/Makefile-bundle")
- (lambda (port)
- (newline port)
- (let ((init-root (string-append bundle "-init")))
- (write-rule port "compile-liarc-bundle" so-file)
- (newline port)
- (write-rule port
- (string-append bundle ".so")
- (string-append init-root ".o")
- (files+suffix names ".o"))
- (write-command port
- "@$(top_builddir)/microcode/liarc-ld"
- "$@"
- "$^")
- (newline port)
- (write-rule port
- (string-append init-root ".c")
- (files+suffix names ".c"))
- (write-command port
- "$(top_srcdir)/etc/c-bundle.sh"
- "library"
- init-root
- "$^")
- (newline port)
- (write-rule port "install-liarc-bundle" so-file)
- (write-command port
- "$(INSTALL_DATA)"
- "$^"
- "$(DESTDIR)$(AUXDIR)/lib/.")
- (newline port)
- (write-rule port
- ".PHONY"
- "compile-liarc-bundle"
- "install-liarc-bundle")
- )))))))
- (map write-to-string bundles)))
-
+(define (generate-c-bundles bundles cc-arch)
+ (for-each (lambda (bundle)
+ (generate-c-bundle bundle cc-arch))
+ (map write-to-string bundles)))
+
+(define (generate-c-bundle bundle cc-arch)
+ (with-notification (lambda (port)
+ (write-string "Generating bundle rule for " port)
+ (write-string bundle port))
+ (lambda ()
+ (let ((names (bundle-files bundle))
+ (so-file (string-append bundle ".so")))
+ (receive (script-dir include-dir)
+ (cond ((string=? cc-arch "C")
+ (values "$(top_builddir)/microcode"
+ "$(top_builddir)/microcode"))
+ ((eq? microcode-id/compiled-code-type 'C)
+ (let ((dir
+ (lambda (name)
+ (->namestring
+ (directory-pathname-as-file
+ (system-library-directory-pathname name))))))
+ (values (dir "")
+ (dir "include"))))
+ (else
+ (values #f #f)))
+ (call-with-output-file (string-append bundle "/Makefile-bundle")
+ (lambda (port)
+ (if script-dir
+ (begin
+ (newline port)
+ (write-rule port ".c.o")
+ (write-command port
+ (string-append "@" script-dir "/liarc-cc")
+ "$*.o"
+ "$*.c"
+ (string-append "-I" include-dir))
+ (newline port)
+ (let ((init-root (string-append bundle "-init")))
+ (write-rule port "compile-liarc-bundle" so-file)
+ (newline port)
+ (write-rule port
+ (string-append bundle ".so")
+ (string-append init-root ".o")
+ (files+suffix names ".o"))
+ (write-command port
+ (string-append "@" script-dir "/liarc-ld")
+ "$@"
+ "$^")
+ (newline port)
+ (write-rule port
+ (string-append init-root ".c")
+ (files+suffix names ".c"))
+ (write-command port
+ "$(top_srcdir)/etc/c-bundle.sh"
+ script-dir
+ "library"
+ init-root
+ "$^")
+ (newline port)
+ (write-rule port "install-liarc-bundle" so-file)
+ (let ((dir
+ (string-append "$(DESTDIR)$(AUXDIR)/" bundle)))
+ (write-command port "$(mkinstalldirs)" dir)
+ (write-command port
+ "$(INSTALL_DATA)"
+ "$^"
+ (string-append dir "/.")))
+ (newline port)
+ (write-rule port
+ ".PHONY"
+ "compile-liarc-bundle"
+ "install-liarc-bundle")
+ ))))))))))
+\f
(define (bundle-files bundle)
(let ((pkg-name (if (string=? bundle "star-parser") "parser" bundle)))
(cons (string-append pkg-name "-unx")
(string=? bundle "sf"))
(cons "make" names))
((string=? bundle "compiler")
- (cons* "machines/C/make"
+ (cons* (string-append
+ (or (file-symbolic-link? "compiler/machine")
+ (error "Missing compiler/machine link."))
+ "/make")
"base/make"
names))
((string=? bundle "edwin")
#| -*-Scheme-*-
-$Id: load.scm,v 1.48 2007/04/04 05:08:19 riastradh Exp $
+$Id: load.scm,v 1.49 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load-option 'WT-TREE)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (declare-shared-library "imail" (lambda () #t))
(fluid-let ((*allow-package-redefinition?* #t))
(load-package-set "imail"))))
(add-subsystem-identification! "IMAIL" '(1 21))
\ No newline at end of file
/* -*-C-*-
-$Id: c.c,v 1.22 2007/04/22 16:31:24 cph Exp $
+$Id: c.c,v 1.23 2007/06/06 19:42:41 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "bignum.h"
#include "bitstr.h"
#include "avltree.h"
+#include "os.h"
extern int initialize_compiled_code_blocks (void);
+extern const char * liarc_object_file_prefix (void);
\f
#ifdef BUG_GCC_LONG_CALLS
#define COMPILED_BLOCK_DATA_ONLY_P(block) (_CBFT (block, _CBF_DATA_ONLY))
#define COMPILED_BLOCK_DATA_INIT_P(block) (_CBFT (block, _CBF_DATA_INIT))
+static int declare_compiled_code_ns_1
+ (const char *, entry_count_t, liarc_code_proc_t *);
+static const char * compute_full_name (const char *);
static bool grow_compiled_blocks (void);
static bool grow_compiled_entries (entry_count_t);
static int declare_trampoline_block (entry_count_t);
}
SCHEME_OBJECT
-initialize_C_compiled_block (int argno, const char * name)
+initialize_C_compiled_block (const char * name)
{
compiled_block_t * block = (find_compiled_block (name));
return
}
}
-bool
-import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks)
+void
+reset_c_code_table (void)
{
- long dumped_initial_entry_number = (FIXNUM_TO_LONG (*table++));
- unsigned long count;
-
- if (dumped_initial_entry_number < max_trampoline)
- return (false);
- initial_entry_number = dumped_initial_entry_number;
-
if (compiled_entries != 0)
free (compiled_entries);
if (compiled_blocks != 0)
n_compiled_entries = 0;
compiled_entries_size = 0;
compiled_entries = 0;
+}
+
+bool
+import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks)
+{
+ long dumped_initial_entry_number = (FIXNUM_TO_LONG (*table++));
+ unsigned long count;
+
+ if (dumped_initial_entry_number < max_trampoline)
+ return (false);
+ initial_entry_number = dumped_initial_entry_number;
if ((declare_trampoline_block (initial_entry_number)) != 0)
return (false);
return (true);
}
\f
+int
+declare_compiled_code (const char * name,
+ entry_count_t n_block_entries,
+ liarc_decl_code_t * decl_code,
+ liarc_code_proc_t * code_proc)
+{
+ int rc = (declare_compiled_code_ns (name, n_block_entries, code_proc));
+ return ((rc == 0) ? ((*decl_code) ()) : rc);
+}
+
int
declare_compiled_code_ns (const char * name,
entry_count_t n_block_entries,
liarc_code_proc_t * code_proc)
+{
+ void * p = dstack_position;
+ int rc
+ = (declare_compiled_code_ns_1 ((compute_full_name (name)),
+ n_block_entries,
+ code_proc));
+ dstack_set_position (p);
+ return (rc);
+}
+
+static int
+declare_compiled_code_ns_1 (const char * name,
+ entry_count_t n_block_entries,
+ liarc_code_proc_t * code_proc)
{
compiled_block_t * block = (find_compiled_block (name));
if (block == 0)
{
entry_count_t entries_start = n_compiled_entries;
entry_count_t entries_end = (entries_start + n_block_entries);
+ char * cname;
tree_node new_tree;
if (! ((entries_start <= entries_end)
return (-1);
tree_error_message = 0;
- new_tree = (tree_insert (compiled_blocks_tree, name, n_compiled_blocks));
+ cname = (OS_malloc ((strlen (name)) + 1));
+ strcpy (cname, name);
+ new_tree
+ = (tree_insert (compiled_blocks_tree, cname, n_compiled_blocks));
if (tree_error_message != 0)
- return (-1);
+ {
+ OS_free ((void *) cname);
+ return (-1);
+ }
compiled_blocks_tree = new_tree;
block = (compiled_blocks + (n_compiled_blocks++));
- (COMPILED_BLOCK_NAME (block)) = name;
+ (COMPILED_BLOCK_NAME (block)) = cname;
(COMPILED_BLOCK_CODE_PROC (block)) = code_proc;
(_COMPILED_BLOCK_DATA_PROC (block)) = 0;
(COMPILED_BLOCK_FIRST_ENTRY (block)) = entries_start;
return (-1);
}
\f
+static const char *
+compute_full_name (const char * name)
+{
+ const char * prefix;
+ char * full;
+
+ prefix = (liarc_object_file_prefix ());
+ if (prefix == 0)
+ return (name);
+ full = (dstack_alloc ((strlen (prefix)) + (strlen (name)) + 1));
+ strcpy (full, prefix);
+ strcat (full, name);
+ return (full);
+}
+
static bool
grow_compiled_blocks (void)
{
compiled_entries = new_entries;
return (true);
}
-
+\f
int
-declare_compiled_code (const char * name,
- entry_count_t n_block_entries,
- liarc_decl_code_t * decl_code,
- liarc_code_proc_t * code_proc)
+declare_compiled_data (const char * name,
+ liarc_decl_data_t * decl_data,
+ liarc_data_proc_t * data_proc)
{
- int rc = (declare_compiled_code_ns (name, n_block_entries, code_proc));
- return ((rc == 0) ? ((*decl_code) ()) : rc);
+ int rc = (declare_compiled_data_ns (name, data_proc));
+ return ((rc == 0) ? ((*decl_data) ()) : rc);
}
-\f
+
int
declare_compiled_data_ns (const char * name, liarc_data_proc_t * data_proc)
{
- compiled_block_t * block = (find_compiled_block (name));
- if ((block == 0)
- || ((COMPILED_BLOCK_DATA_INIT_P (block))
- && ((COMPILED_BLOCK_DATA_PROC (block)) != data_proc)))
+ void * p = dstack_position;
+ const char * full = (compute_full_name (name));
+ compiled_block_t * block = (find_compiled_block (full));
+ dstack_set_position (p);
+ if (! ((block != 0)
+ && ((!COMPILED_BLOCK_DATA_INIT_P (block))
+ || ((COMPILED_BLOCK_DATA_PROC (block)) == data_proc))))
return (-1);
SET_COMPILED_BLOCK_DATA_PROC (block, data_proc);
return (0);
}
-int
-declare_compiled_data (const char * name,
- liarc_decl_data_t * decl_data,
- liarc_data_proc_t * data_proc)
-{
- int rc = (declare_compiled_data_ns (name, data_proc));
- return ((rc == 0) ? ((*decl_data) ()) : rc);
-}
-
int
declare_data_object (const char * name, liarc_object_proc_t * object_proc)
{
- compiled_block_t * block = (find_compiled_block (name));
+ void * p = dstack_position;
+ const char * full = (compute_full_name (name));
+ compiled_block_t * block = (find_compiled_block (full));
if (block == 0)
{
- declare_compiled_code_ns (name, 0, unspecified_code);
- block = (find_compiled_block (name));
+ declare_compiled_code_ns_1 (full, 0, unspecified_code);
+ block = (find_compiled_block (full));
if (block == 0)
- return (-1);
+ {
+ dstack_set_position (p);
+ return (-1);
+ }
}
-
- if ((COMPILED_BLOCK_DATA_INIT_P (block))
- && ((COMPILED_BLOCK_OBJECT_PROC (block)) != object_proc))
- return (-1);
+ dstack_set_position (p);
+ if (! ((!COMPILED_BLOCK_DATA_INIT_P (block))
+ || ((COMPILED_BLOCK_OBJECT_PROC (block)) == object_proc)))
+ return (-1);
SET_COMPILED_BLOCK_OBJECT_PROC (block, object_proc);
return (0);
}
static int
declare_trampoline_block (entry_count_t n_block_entries)
{
- return (declare_compiled_code_ns ("#trampoline_code_block",
- n_block_entries,
- trampoline_procedure));
+ return (declare_compiled_code_ns_1 ("#trampoline_code_block",
+ n_block_entries,
+ trampoline_procedure));
}
bool
{
return ((ptr == 0) ? (malloc (size)) : (realloc (ptr, size)));
}
+
+unsigned long
+liarc_n_compiled_blocks (void)
+{
+ return (n_compiled_blocks);
+}
+
+void
+get_liarc_compiled_block_data (unsigned long index,
+ const char ** name_r,
+ void ** code_proc_r,
+ void ** data_proc_r,
+ void ** object_proc_r)
+{
+ compiled_block_t * block;
+
+ assert (index < n_compiled_blocks);
+ block = (& (compiled_blocks[index]));
+ (*name_r) = (COMPILED_BLOCK_NAME (block));
+ if (COMPILED_BLOCK_DATA_ONLY_P (block))
+ {
+ (*code_proc_r) = 0;
+ (*data_proc_r) = 0;
+ (*object_proc_r) = (COMPILED_BLOCK_OBJECT_PROC (block));
+ }
+ else
+ {
+ (*code_proc_r) = (COMPILED_BLOCK_CODE_PROC (block));
+ (*data_proc_r)
+ = ((COMPILED_BLOCK_DATA_INIT_P (block))
+ ? (COMPILED_BLOCK_DATA_PROC (block))
+ : 0);
+ (*object_proc_r) = 0;
+ }
+}
\f
int
multiply_with_overflow (long x, long y, long * res)
/* -*-C-*-
-$Id: c.h,v 1.13 2007/04/22 16:31:24 cph Exp $
+$Id: c.h,v 1.14 2007/06/06 19:42:41 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#define READ_COMPILED_CLOSURE_TARGET(a, r) (read_compiled_closure_target (a))
extern void initialize_C_interface (void);
+extern SCHEME_OBJECT initialize_C_compiled_block (const char *);
extern insn_t * read_uuo_target (SCHEME_OBJECT *);
extern insn_t * read_compiled_closure_target (insn_t *);
extern unsigned long c_code_table_export_length (unsigned long *);
extern void export_c_code_table (SCHEME_OBJECT *);
+extern void reset_c_code_table (void);
extern bool import_c_code_table (SCHEME_OBJECT *, unsigned long);
#endif /* !SCM_CMPINTMD_H_INCLUDED */
/* -*-C-*-
-$Id: comutl.c,v 1.38 2007/04/22 16:31:22 cph Exp $
+$Id: comutl.c,v 1.39 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
/* Compiled Code Utilities */
#include "scheme.h"
+#include "osscheme.h"
#include "prims.h"
+#ifdef CC_IS_C
+extern unsigned long liarc_n_compiled_blocks (void);
+extern void get_liarc_compiled_block_data
+ (unsigned long, const char **, void **, void **, void **);
+#endif
+
DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block,
1, 1, "(ADDRESS)\n\
Given a compiled-code entry ADDRESS, return its block.")
}
}
-#ifdef CC_IS_C
- extern SCHEME_OBJECT initialize_C_compiled_block (int, const char *);
-#endif
-
DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK",
Prim_initialize_C_compiled_block, 1, 1,
"Given the tag of a compiled object, return the object.")
{
PRIMITIVE_HEADER (1);
#ifdef CC_IS_C
- PRIMITIVE_RETURN (initialize_C_compiled_block (1, (STRING_ARG (1))));
+ PRIMITIVE_RETURN (initialize_C_compiled_block (STRING_ARG (1)));
#else
PRIMITIVE_RETURN (SHARP_F);
#endif
}
+typedef unsigned long thunk_t (void);
+static const char * ilof_prefix = 0;
+
+DEFINE_PRIMITIVE ("INITIALIZE-LIARC-OBJECT-FILE", Prim_initialize_liarc_object_file, 2, 2,
+ "(ADDRESS PREFIX)\n\
+Run the object-file initialization thunk specified by ADDRESS,\n\
+using PREFIX as the rewriting prefix for the subparts.")
+{
+ PRIMITIVE_HEADER (2);
+ {
+ thunk_t * thunk = ((thunk_t *) (arg_ulong_integer (1)));
+ const char * prefix = (STRING_ARG (2));
+ void * p = dstack_position;
+ dstack_bind ((&ilof_prefix), ((void *) prefix));
+ {
+ unsigned long value = ((*thunk) ());
+ dstack_set_position (p);
+ PRIMITIVE_RETURN (ulong_to_integer (value));
+ }
+ }
+}
+
+const char *
+liarc_object_file_prefix (void)
+{
+ return (ilof_prefix);
+}
+
+
DEFINE_PRIMITIVE ("DECLARE-COMPILED-CODE-BLOCK",
Prim_declare_compiled_code_block, 1, 1,
"Ensure cache coherence for a compiled-code block newly constructed.")
PRIMITIVE_RETURN (SHARP_T);
}
}
+
+DEFINE_PRIMITIVE ("LIARC-COMPILED-BLOCKS", Prim_liarc_compiled_code_blocks,
+ 0, 0,
+ "Return a vector containing the names of registered compiled-code blocks.")
+{
+ PRIMITIVE_HEADER (0);
+#ifdef CC_IS_C
+ {
+ unsigned long n = (liarc_n_compiled_blocks ());
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, n, true));
+ unsigned long i;
+ const char * name;
+ void * code_proc;
+ void * data_proc;
+ void * object_proc;
+
+ for (i = 0; (i < n); i += 1)
+ VECTOR_SET (v, i, (allocate_marked_vector (TC_VECTOR, 4, true)));
+
+ for (i = 0; (i < n); i += 1)
+ {
+ SCHEME_OBJECT vi = (VECTOR_REF (v, i));
+ get_liarc_compiled_block_data
+ (i, (&name), (&code_proc), (&data_proc), (&object_proc));
+ VECTOR_SET (vi, 0, (char_pointer_to_string (name)));
+ VECTOR_SET (vi, 1,
+ ((code_proc == 0)
+ ? SHARP_F
+ : (ulong_to_integer ((unsigned long) code_proc))));
+ VECTOR_SET (vi, 2,
+ ((data_proc == 0)
+ ? SHARP_F
+ : (ulong_to_integer ((unsigned long) data_proc))));
+ VECTOR_SET (vi, 3,
+ ((object_proc == 0)
+ ? SHARP_F
+ : (ulong_to_integer ((unsigned long) object_proc))));
+ }
+
+ PRIMITIVE_RETURN (v);
+ }
+#else
+ error_unimplemented_primitive ();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+#endif
+}
\f
DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1,
"(compiled-entry-object)\n\
dnl Process this file with autoconf to produce a configure script.
AC_INIT([MIT/GNU Scheme microcode], [15.1], [bug-mit-scheme@gnu.org], [mit-scheme])
-AC_REVISION([$Id: configure.ac,v 1.47 2007/05/14 16:50:51 cph Exp $])
+AC_REVISION([$Id: configure.ac,v 1.48 2007/06/06 19:42:40 cph Exp $])
AC_CONFIG_SRCDIR([boot.c])
AC_CONFIG_HEADERS([config.h])
AC_PROG_MAKE_SET
MODULE_LDFLAGS=
LIARC_VARS=/dev/null
LIARC_RULES=/dev/null
+AUX_PROGRAMS=
SYSTEM_BASE_NAME=mit-scheme
INSTALL_INCLUDE=
else
STATIC_LIBS=
OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld"
+ AC_DEFINE([UX_DLD_ENABLED], [1],
+ [Define to 1 if unix dynamic loading support is enabled.])
fi
if test ${enable_valgrind_mode} != no; then
OPTIONAL_BASES="${OPTIONAL_BASES} cmpauxmd unstackify compinit"
LIARC_VARS=liarc-vars
LIARC_RULES=liarc-rules
+ AUX_PROGRAMS="gen-nonce extract-liarc-decls"
SYSTEM_BASE_NAME=mit-scheme-c
INSTALL_INCLUDE=install-include
;;
AC_SUBST([MODULE_LDFLAGS])
AC_SUBST_FILE([LIARC_VARS])
AC_SUBST_FILE([LIARC_RULES])
+AC_SUBST([AUX_PROGRAMS])
AC_SUBST([SYSTEM_BASE_NAME])
AC_SUBST([INSTALL_INCLUDE])
AC_SUBST([CCLD])
--- /dev/null
+/* -*-C-*-
+
+$Id: extract-liarc-decls.c,v 9.1 2007/06/06 19:42:40 cph Exp $
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007 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.
+
+*/
+
+/* Utility to extract LIARC declarations from source files. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+static void process_file (const char *);
+static const char * filename_prefix (const char *);
+static const char * apply_prefix_rules (const char *);
+static void mangle_line (const char *, const char *);
+static const char * skip_name (const char *);
+static const char * skip_lws (const char *);
+static const char * skip_fixed (const char *, char);
+static void write_string (const char *);
+static void write_char (char);
+static const char * read_line (FILE *);
+static void * xmalloc (size_t);
+static void * xrealloc (void *, size_t);
+
+typedef struct
+{
+ const char * pattern;
+ const char * replacement;
+} prefix_rule_t;
+
+static unsigned int n_prefix_rules;
+static unsigned int prefix_rules_size;
+static prefix_rule_t * prefix_rules;
+\f
+int
+main (int argc, const char ** argv)
+{
+ const char ** scan = (argv + 1);
+ const char ** end = (argv + argc);
+
+ n_prefix_rules = 0;
+ prefix_rules_size = 16;
+ prefix_rules = (xmalloc (prefix_rules_size * (sizeof (prefix_rule_t))));
+
+ while ((scan < end) && ((strcmp ((*scan), "--rewrite")) == 0))
+ {
+ if ((scan + 3) > end)
+ abort ();
+ if (n_prefix_rules == prefix_rules_size)
+ {
+ prefix_rules_size *= 2;
+ prefix_rules
+ = (xrealloc (prefix_rules,
+ (prefix_rules_size * (sizeof (prefix_rule_t)))));
+ }
+ ((prefix_rules[n_prefix_rules]) . pattern) = (scan[1]);
+ ((prefix_rules[n_prefix_rules]) . replacement) = (scan[2]);
+ n_prefix_rules += 1;
+ scan += 3;
+ }
+
+ while (scan < end)
+ {
+ if ((strcmp ((*scan), "--rewrite")) == 0)
+ abort ();
+ process_file (*scan++);
+ }
+
+ return (0);
+}
+
+static void
+process_file (const char * filename)
+{
+ const char * prefix_from_file;
+ const char * prefix_to_use;
+ FILE * s;
+
+ prefix_from_file = (filename_prefix (filename));
+ prefix_to_use
+ = (apply_prefix_rules ((prefix_from_file == 0)
+ ? ""
+ : prefix_from_file));
+
+ s = (fopen (filename, "r"));
+ if (s == 0)
+ abort ();
+
+ while (1)
+ {
+ const char * line = (read_line (s));
+ if (line == 0)
+ break;
+ if (((strncmp (line, "DECLARE_COMPILED_", 17)) == 0)
+ || ((strncmp (line, "DECLARE_DATA_OBJECT", 19)) == 0))
+ mangle_line (line, prefix_to_use);
+ free ((void *) line);
+ }
+
+ if (prefix_from_file != 0)
+ free ((void *) prefix_from_file);
+ fclose (s);
+}
+
+static const char *
+filename_prefix (const char * filename)
+{
+ const char * p = (strrchr (filename, '/'));
+ if (p == 0)
+ return (0);
+ {
+ unsigned int n = ((p + 1) - filename);
+ char * prefix = (xmalloc (n + 1));
+ strncpy (prefix, filename, n);
+ (prefix[n]) = '\0';
+ return (prefix);
+ }
+}
+
+static const char *
+apply_prefix_rules (const char * prefix)
+{
+ unsigned int index;
+
+ for (index = 0; (index < n_prefix_rules); index += 1)
+ if ((strcmp (((prefix_rules[index]) . pattern), prefix)) == 0)
+ return ((prefix_rules[index]) . replacement);
+ return (prefix);
+}
+
+static void
+mangle_line (const char * line, const char * prefix)
+{
+ const char * scan = (skip_name (line));
+ scan = (skip_lws (scan));
+ scan = (skip_fixed (scan, '('));
+ scan = (skip_lws (scan));
+ scan = (skip_fixed (scan, '"'));
+ write_string (prefix);
+ write_string (scan);
+ write_char ('\n');
+ fflush (stdout);
+}
+
+static const char *
+skip_name (const char * scan)
+{
+ while ((isalnum (*scan)) || ((*scan) == '_'))
+ write_char (*scan++);
+ return (scan);
+}
+
+static const char *
+skip_lws (const char * scan)
+{
+ while (((*scan) == ' ') || ((*scan) == '\t'))
+ write_char (*scan++);
+ return (scan);
+}
+
+static const char *
+skip_fixed (const char * scan, char c)
+{
+ if ((*scan) != c)
+ abort ();
+ write_char (*scan++);
+ return (scan);
+}
+
+static void
+write_string (const char * s)
+{
+ while (1)
+ {
+ char c = (*s++);
+ if (c == '\0')
+ break;
+ write_char (c);
+ }
+}
+
+static void
+write_char (char c)
+{
+ if ((putc (c, stdout)) == EOF)
+ abort ();
+}
+
+static const char *
+read_line (FILE * s)
+{
+ size_t index = 0;
+ size_t buffer_size = 16;
+ char * buffer = (xmalloc (buffer_size));
+
+ while (1)
+ {
+ int c = (getc (s));
+ if (c == EOF)
+ {
+ if (!feof (s))
+ abort ();
+ if (index == 0)
+ return (0);
+ break;
+ }
+ if (c == '\n')
+ break;
+ if (index == buffer_size)
+ {
+ buffer_size *= 2;
+ buffer = (xrealloc (buffer, buffer_size));
+ }
+ (buffer[index++]) = c;
+ }
+
+ if (index == buffer_size)
+ {
+ buffer_size += 1;
+ buffer = (xrealloc (buffer, buffer_size));
+ }
+ (buffer[index++]) = '\0';
+
+ if (index < buffer_size)
+ buffer = (xrealloc (buffer, index));
+
+ return (buffer);
+}
+
+static void *
+xmalloc (size_t n)
+{
+ void * p = (malloc (n));
+ if (p == 0)
+ abort ();
+ return (p);
+}
+
+static void *
+xrealloc (void * p, size_t n)
+{
+ void * p2 = (realloc (p, n));
+ if (p2 == 0)
+ abort ();
+ return (p2);
+}
/* -*-C-*-
-$Id: fasload.c,v 9.102 2007/04/22 16:40:08 cph Exp $
+$Id: fasload.c,v 9.103 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(raw_prim_table, (FASLHDR_N_PRIMITIVES (fh)), new_prim_table);
}
#ifdef CC_IS_C
- if ((FASLHDR_BAND_P (fh)) && ((FASLHDR_C_CODE_TABLE_SIZE (fh)) > 0))
+ if (FASLHDR_BAND_P (fh))
{
- SCHEME_OBJECT * raw_table = (Free + (FASLHDR_N_PRIMITIVES (fh)));
- read_from_file (raw_table, (FASLHDR_C_CODE_TABLE_SIZE (fh)), handle);
- if (!import_c_code_table (raw_table, (FASLHDR_N_C_CODE_BLOCKS (fh))))
- signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
+ reset_c_code_table ();
+ if ((FASLHDR_C_CODE_TABLE_SIZE (fh)) > 0)
+ {
+ SCHEME_OBJECT * raw_table = (Free + (FASLHDR_N_PRIMITIVES (fh)));
+ read_from_file (raw_table, (FASLHDR_C_CODE_TABLE_SIZE (fh)), handle);
+ if (!import_c_code_table (raw_table, (FASLHDR_N_C_CODE_BLOCKS (fh))))
+ signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
+ }
}
#endif
/* -*-C-*-
-$Id: liarc.h,v 1.30 2007/05/14 16:50:53 cph Exp $
+$Id: liarc.h,v 1.31 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
return (declare_data_object (name, data)); \
}
-#define DECLARE_DYNAMIC_INITIALIZATION(name) \
+#define DECLARE_DYNAMIC_INITIALIZATION(name, nonce) \
+const char dload_nonce [] = nonce; \
+ \
char * \
dload_initialize_file (void) \
{ \
: 0); \
}
-#define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name) \
+#define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name, nonce) \
+const char dload_nonce [] = nonce; \
+ \
char * \
dload_initialize_file (void) \
{ \
#define DECLARE_COMPILED_DATA(name, decl_data, data)
#define DECLARE_COMPILED_DATA_NS(name, data)
#define DECLARE_DATA_OBJECT(name, data)
-#define DECLARE_DYNAMIC_INITIALIZATION(name)
-#define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name)
+#define DECLARE_DYNAMIC_INITIALIZATION(name, nonce)
+#define DECLARE_DYNAMIC_OBJECT_INITIALIZATION(name, nonce)
#endif /* !ENABLE_LIARC_FILE_INIT */
\f
# -*- Makefile -*-
#
-# $Id: Makefile.in.in,v 1.57 2007/05/15 05:15:50 cph Exp $
+# $Id: Makefile.in.in,v 1.58 2007/06/06 19:42:41 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
# **** Program definitions ****
+aux_PROGRAMS = @AUX_PROGRAMS@
aux_LIBS = $(MODULE_TARGETS)
aux_DATA = utabmd.bin
EXTRA_PROGRAMS = findprim
findprim_LDFLAGS =
findprim_LIBS = $(LIBS)
-ALL_PROGRAMS = scheme
+ALL_PROGRAMS = $(aux_PROGRAMS) scheme
ALL_LIBS = $(aux_LIBS)
ALL_DATA = $(aux_DATA)
-rm -f $@
$(LINK) $(findprim_LDFLAGS) $(findprim_OBJECTS) $(findprim_LIBS)
+gen-nonce: gen-nonce.o
+ $(LINK) $^
+
+extract-liarc-decls: extract-liarc-decls.o
+ $(LINK) $^
+
utabmd.bin: utabmd.scm
./utabmd.sh
c-clean: clean
-rm -f $(C_CLEAN_FILES)
-install: install-auxLIBS install-auxDATA @INSTALL_INCLUDE@
+install: install-auxPROGRAMS install-auxLIBS install-auxDATA @INSTALL_INCLUDE@
$(mkinstalldirs) $(DESTDIR)$(bindir)
$(INSTALL_PROGRAM) scheme $(DESTDIR)$(bindir)/$(SYSTEM_BASE_NAME)
../etc/install-bin-symlinks.sh $(DESTDIR)$(bindir) $(SYSTEM_BASE_NAME)
+install-auxPROGRAMS: $(aux_PROGRAMS)
+ $(mkinstalldirs) $(DESTDIR)$(AUXDIR)
+ @list='$(aux_PROGRAMS)'; \
+ for p in $$list; do \
+ if test -f $$p; then \
+ echo "$(INSTALL_PROGRAM) $$p $(DESTDIR)$(AUXDIR)/."; \
+ $(INSTALL_PROGRAM) $$p $(DESTDIR)$(AUXDIR)/.; \
+ fi; \
+ done
+
install-auxLIBS: $(aux_LIBS)
$(mkinstalldirs) $(DESTDIR)$(AUXDIR)/lib
@list='$(aux_LIBS)'; \
.PHONY: default-target
.PHONY: all tags TAGS mostlyclean clean distclean maintainer-clean c-clean
-.PHONY: install install-auxLIBS install-auxDATA install-include
+.PHONY: install install-auxPROGRAMS install-auxLIBS install-auxDATA
+.PHONY: install-include
# **** File dependencies ****
# -*- Makefile -*-
#
-# $Id: liarc-base-rules,v 1.4 2007/05/14 16:50:55 cph Exp $
+# $Id: liarc-base-rules,v 1.5 2007/06/06 19:42:42 cph Exp $
#
# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
compinit.o: compinit.c compinit.h $(LIARC_HEAD_FILES)
unstackify.o: unstackify.c stackops.h $(LIARC_HEAD_FILES)
-compinit.c compinit.h: $(LIARC_SOURCES) Makefile
+SYS_LIB_URI = http://www.gnu.org/software/mit-scheme/lib/
+
+compinit.c compinit.h: $(LIARC_SOURCES) Makefile gen-nonce extract-liarc-decls
rm -f $@
- $(srcdir)/../etc/c-bundle.sh static compinit $(LIARC_SOURCES)
+ $(srcdir)/../etc/c-bundle.sh . static compinit \
+ --rewrite "" $(SYS_LIB_URI)microcode/ \
+ --rewrite ../runtime/ $(SYS_LIB_URI)runtime/ \
+ $(LIARC_SOURCES)
/* -*-C-*-
-$Id: pruxdld.c,v 1.24 2007/05/20 02:02:34 cph Exp $
+$Id: pruxdld.c,v 1.25 2007/06/06 19:42:40 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
#include "usrdef.h"
#include "syscall.h"
#include "os.h"
-\f
-#ifdef HAVE_DLFCN_H
-
#include <dlfcn.h>
-static unsigned long
-dld_load (const char * path)
-{
- void * handle = (dlopen (path, (RTLD_LAZY | RTLD_GLOBAL)));
- if (handle == 0)
- {
- SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
- VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
- VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
- VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
- error_with_argument (v);
- }
- return ((unsigned long) handle);
-}
-static unsigned long
-dld_lookup (unsigned long handle, char * symbol)
-{
- const char * old_error = (dlerror ());
- void * address = (dlsym (((void *) handle), symbol));
- const char * new_error = (dlerror ());
- if ((address == 0) && (new_error != old_error))
- {
- SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
- VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
- VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym")));
- VECTOR_SET (v, 2, (char_pointer_to_string (new_error)));
- error_with_argument (v);
- }
- return ((unsigned long) address);
-}
+static bool cleanup_registered_p = false;
+static unsigned int loaded_handles_size = 0;
+static unsigned int n_loaded_handles = 0;
+static void ** loaded_handles = 0;
-#endif /* HAVE_DLFCN_H */
-\f
-static const char * lof_name = 0;
+static void * dld_load (const char *);
+static void dld_unload (void *);
+static void dld_unload_all (void);
+static void * dld_lookup (void *, const char *);
-const char *
-load_object_file_name (void)
+#define ARG_HANDLE(n) ((void *) (arg_ulong_integer (n)))
+\f
+DEFINE_PRIMITIVE ("DLD-LOAD-FILE", Prim_dld_load_file, 2, 2,
+ "(FILENAME WEAK-PAIR)\n\
+Load the shared library FILENAME and store its handle\n\
+in the cdr of WEAK-PAIR.")
{
- return (lof_name);
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG (2, WEAK_PAIR_P);
+ SET_PAIR_CDR ((ARG_REF (2)),
+ (ulong_to_integer
+ ((unsigned long)
+ (dld_load (((ARG_REF (1)) == SHARP_F)
+ ? 0
+ : (STRING_ARG (1)))))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
-DEFINE_PRIMITIVE ("LOAD-OBJECT-FILE", Prim_load_object_file, 1, 1,
- "(FILENAME)\n\
-Load the shared library FILENAME and return a handle for it.")
+DEFINE_PRIMITIVE ("DLD-LOOKUP-SYMBOL", Prim_dld_lookup_symbol, 2, 2,
+ "(HANDLE STRING)\n\
+Look up the symbol named STRING in the shared library specified by HANDLE.\n\
+Return the symbol's address, or #F if no such symbol.")
{
- const char * name;
- void * p;
- unsigned long handle;
- PRIMITIVE_HEADER (1);
-
- name = (STRING_ARG (1));
- p = dstack_position;
- dstack_bind ((&lof_name), ((void *) name));
- handle = (dld_load (name));
- dstack_set_position (p);
- PRIMITIVE_RETURN (ulong_to_integer (handle));
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (ulong_to_integer
+ ((unsigned long) (dld_lookup ((ARG_HANDLE (1)), (STRING_ARG (2))))));
}
-DEFINE_PRIMITIVE ("OBJECT-LOOKUP-SYMBOL", Prim_object_lookup_symbol, 3, 3,
- "(HANDLE SYMBOL TYPE)\n\
-Look up SYMBOL, a Scheme string, in the dynamically-loaded file\n\
-referenced by HANDLE. TYPE is obsolete and must be specified as zero.\n\
-Returns the symbol's address, or signals an error if no such symbol.")
+DEFINE_PRIMITIVE ("DLD-UNLOAD-FILE", Prim_dld_unload_file, 1, 1,
+ "(HANDLE)\n\
+Unload the shared library specified by HANDLE.\n\
+The file is unmapped from memory, and its symbols become unbound.")
{
- PRIMITIVE_HEADER (3);
- if ((ARG_REF (3)) != FIXNUM_ZERO)
- error_wrong_type_arg (3);
- PRIMITIVE_RETURN
- (ulong_to_integer
- (dld_lookup ((arg_ulong_integer (1)), (STRING_ARG (2)))));
+ PRIMITIVE_HEADER (1);
+ dld_unload (ARG_HANDLE (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("INVOKE-C-THUNK", Prim_invoke_C_thunk, 1, 1,
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (char_pointer_to_string ((char *) (arg_ulong_integer (1))));
}
+\f
+static void *
+dld_load (const char * path)
+{
+ void * handle;
+
+ if (!cleanup_registered_p)
+ {
+ add_reload_cleanup (dld_unload_all);
+ cleanup_registered_p = true;
+ }
+
+ handle = (dlopen (path, (RTLD_LAZY | RTLD_GLOBAL)));
+ if (handle == 0)
+ {
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
+ VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+ VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
+ VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
+ error_with_argument (v);
+ }
+ if (n_loaded_handles == loaded_handles_size)
+ {
+ if (loaded_handles_size == 0)
+ {
+ loaded_handles_size = 16;
+ loaded_handles
+ = (OS_malloc (loaded_handles_size * (sizeof (void *))));
+ }
+ else
+ {
+ loaded_handles_size *= 2;
+ loaded_handles
+ = (OS_realloc (loaded_handles,
+ (loaded_handles_size * (sizeof (void *)))));
+ }
+ }
+ (loaded_handles[n_loaded_handles++]) = handle;
+ return (handle);
+}
+
+static void
+dld_unload (void * handle)
+{
+ if ((dlclose (handle)) != 0)
+ {
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
+ VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+ VECTOR_SET (v, 1, (char_pointer_to_string ("dlclose")));
+ VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
+ error_with_argument (v);
+ }
+ {
+ void ** scan = loaded_handles;
+ void ** end = (scan + n_loaded_handles);
+ for (; (scan < end); scan += 1)
+ if ((*scan) == handle)
+ {
+ (*scan) = (* (end - 1));
+ n_loaded_handles -= 1;
+ break;
+ }
+ }
+}
+
+static void
+dld_unload_all (void)
+{
+ if (loaded_handles_size > 0)
+ {
+ void ** scan = loaded_handles;
+ void ** end = (scan + n_loaded_handles);
+ while (scan < end)
+ dlclose (*scan++);
+
+ OS_free (loaded_handles);
+ loaded_handles_size = 0;
+ n_loaded_handles = 0;
+ loaded_handles = 0;
+ }
+}
+
+static void *
+dld_lookup (void * handle, const char * symbol)
+{
+ void * address;
+ const char * error_string;
+
+ dlerror (); /* discard any outstanding errors */
+ address = (dlsym (handle, symbol));
+ error_string = (dlerror ());
+ if (error_string != 0)
+ {
+ SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
+ VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+ VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
+ VECTOR_SET (v, 2, (char_pointer_to_string (error_string)));
+ error_with_argument (v);
+ }
+ return (address);
+}
#| -*-Scheme-*-
-$Id: input.scm,v 14.34 2007/01/09 06:16:45 cph Exp $
+$Id: input.scm,v 14.35 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (read #!optional port environment)
(parse-object (optional-input-port port 'READ) environment))
+(define (read-file pathname #!optional environment)
+ (call-with-input-file (pathname-default-version pathname 'NEWEST)
+ (lambda (port)
+ (let ((environment
+ (if (default-object? environment)
+ (nearest-repl/environment)
+ environment)))
+ (let loop ((sexps '()))
+ (let ((sexp (read port environment)))
+ (if (eof-object? sexp)
+ (reverse! sexps)
+ (loop (cons sexp sexps)))))))))
+
(define (read-line #!optional port)
(input-port/read-line (optional-input-port port 'READ-LINE)))
#| -*-Scheme-*-
-$Id: io.scm,v 14.86 2007/01/05 21:19:28 cph Exp $
+$Id: io.scm,v 14.87 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
directory-channel?
directory-channel/descriptor
set-directory-channel/descriptor!))
- (initialize-select-registry!))
+ (initialize-select-registry!)
+ (set! dld-handles '())
+ unspecific)
(define-structure (channel (constructor %make-channel))
;; This structure serves two purposes. First, because a descriptor
(type #f read-only #t)
port)
+(define-guarantee channel "I/O channel")
+
(define (make-channel d)
(open-channel (lambda (p) (system-pair-set-cdr! p d))))
(define-structure (directory-channel (conc-name directory-channel/))
descriptor)
+(define-guarantee directory-channel "directory channel")
+
(define (directory-channel-open name)
(without-interrupts
(lambda ()
(set-cdr! (car rv) vmode)))
(set! select-registry-result-vectors
(cons (cons vfd vmode) select-registry-result-vectors))))
- (set-interrupt-enables! interrupt-mask)))
\ No newline at end of file
+ (set-interrupt-enables! interrupt-mask)))
+\f
+;;;; Interface to dynamic loader
+
+(define-structure dld-handle
+ (pathname #f read-only #t)
+ address)
+
+(define-guarantee dld-handle "dynamic-loader handle")
+
+(define (dld-handle-valid? handle)
+ (guarantee-dld-handle handle 'DLD-HANDLE-VALID?)
+ (if (dld-handle-address handle) #t #f))
+
+(define (guarantee-valid-dld-handle object #!optional caller)
+ (guarantee-dld-handle object caller)
+ (if (not (dld-handle-address object))
+ (error:bad-range-argument object
+ (if (default-object? caller) #f caller))))
+
+(define (dld-get-scheme-handle)
+ (dld-load-file #f))
+
+(define (dld-load-file pathname)
+ (let ((p (weak-cons #f #f)))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ ((ucode-primitive dld-load-file 2)
+ (and pathname (->namestring pathname))
+ p)
+ (let ((handle (make-dld-handle pathname (weak-cdr p))))
+ (without-interrupts
+ (lambda ()
+ (set! dld-handles (cons handle dld-handles))
+ (weak-set-car! p #t)
+ unspecific))
+ handle))
+ (lambda ()
+ (if (and (not (weak-pair/car? p)) (weak-cdr p))
+ (begin
+ ((ucode-primitive dld-unload-file 1) (weak-cdr p))
+ (weak-set-cdr! p #f)))))))
+\f
+(define dld-handles)
+
+(define (dld-unload-file handle)
+ (guarantee-dld-handle handle 'DLD-UNLOAD-FILE)
+ (without-interrupts
+ (lambda ()
+ (%dld-unload-file handle)
+ (set! dld-handles (delq! handle dld-handles))
+ unspecific)))
+
+(define (%dld-unload-file handle)
+ (let ((address (dld-handle-address handle)))
+ (if address
+ (begin
+ ((ucode-primitive dld-unload-file 1) address)
+ (set-dld-handle-address! handle #f)))))
+
+(define (dld-lookup-symbol handle name)
+ (guarantee-dld-handle handle 'DLD-LOOKUP-SYMBOL)
+ (guarantee-string name 'DLD-LOOKUP-SYMBOL)
+ ((ucode-primitive dld-lookup-symbol 2) (dld-handle-address handle) name))
+
+(define (dld-loaded-file? pathname)
+ (find-dld-handle
+ (lambda (handle)
+ (let ((pathname* (dld-handle-pathname handle)))
+ (and pathname*
+ (pathname=? pathname* pathname))))))
+
+(define (find-dld-handle predicate)
+ (find-matching-item dld-handles predicate))
+
+(define (all-dld-handles)
+ (list-copy dld-handles))
+
+(define (unload-all-dld-object-files)
+ (without-interrupts
+ (lambda ()
+ (let loop ()
+ (if (pair? dld-handles)
+ (let ((handle (car dld-handles)))
+ (set! dld-handles (cdr dld-handles))
+ (%dld-unload-file handle)
+ (loop)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 14.94 2007/05/20 01:55:52 cph Exp $
+$Id: load.scm,v 14.95 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(define (initialize-package!)
(set! *purification-root-marker* (intern "#[PURIFICATION-ROOT]"))
- (set! load-noisily? #f)
- (set! load/loading? #f)
- (set! load/suppress-loading-message? #f)
- (set! load/default-types
- `((#f ,wrapper/load/built-in)
- ("so" ,load-object-file)
- ("com" ,load/internal)
- ("bin" ,load/internal)
- ("scm" ,load/internal)))
- (set! fasload/default-types
- `((#f ,wrapper/fasload/built-in)
- ("so" ,fasload-object-file)
- ("com" ,fasload/internal)
- ("bin" ,fasload/internal)))
- (set! load/default-find-pathname-with-type search-types-in-order)
- (set! *eval-unit* #f)
- (set! *current-load-environment* 'NONE)
(set! condition-type:not-loading
(make-condition-type 'NOT-LOADING condition-type:error '()
"No file being loaded."))
- (reset-loaded-object-files!)
- (add-event-receiver! event:after-restart reset-loaded-object-files!)
(initialize-command-line-parsers)
(set! hook/process-command-line default/process-command-line)
(add-event-receiver! event:after-restart process-command-line))
-(define load-noisily?)
-(define load/loading?)
-(define load/suppress-loading-message?)
-(define load/default-types)
+(define load/loading? #f)
(define load/after-load-hooks)
-(define *eval-unit*)
-(define *current-load-environment*)
+(define load/suppress-loading-message? #f)
+(define *eval-unit* #f)
+(define *current-load-environment* 'NONE)
+(define *write-notifications?* #t)
+
+(define *purification-root-marker*)
(define condition-type:not-loading)
-(define load/default-find-pathname-with-type)
-(define fasload/default-types)
-(define loaded-object-files)
-\f
-;;; This is careful to do the minimum number of file existence probes
-;;; before opening the input file.
-(define (load filename/s #!optional environment syntax-table purify?)
+;; Obsolete and ignored:
+(define load-noisily? #f)
+\f
+(define (load pathname #!optional environment syntax-table purify?)
syntax-table ;ignored
(let ((environment
(if (default-object? environment)
(if (default-object? purify?)
#f
purify?)))
- (fluid-let ((*current-load-environment* environment))
- (handle-load-hooks
+ (handle-load-hooks
+ (lambda ()
+ (if (list? pathname)
+ (for-each (lambda (pathname)
+ (load-1 pathname environment purify?))
+ pathname)
+ (load-1 pathname environment purify?))))))
+
+(define (load-1 pathname environment purify?)
+ (receive (pathname* loader notifier) (choose-load-method pathname)
+ (if pathname*
+ (maybe-notify load/suppress-loading-message?
+ (loader environment purify?)
+ notifier)
+ (load-failure load-1 pathname environment purify?))))
+
+(define (file-loadable? pathname)
+ (receive (pathname* loader notifier) (choose-load-method pathname)
+ loader notifier
+ (if pathname* #t #f)))
+
+(define (choose-load-method pathname)
+ (let ((pathname (merge-pathnames pathname)))
+ (receive (pathname* loader notifier) (choose-fasload-method pathname)
+ (if pathname*
+ (values pathname*
+ (wrap-loader pathname (fasloader->loader loader))
+ notifier)
+ (let ((pathname*
+ (if (file-regular? pathname)
+ pathname
+ (let ((pathname (pathname-default-type pathname "scm")))
+ (and (file-regular? pathname)
+ pathname)))))
+ (if pathname*
+ (values pathname*
+ (wrap-loader pathname* (source-loader pathname*))
+ (loading-notifier pathname*))
+ (values #f #f #f)))))))
+
+(define (fasloader->loader loader)
+ (lambda (environment purify?)
+ (let ((scode (loader)))
+ (if purify? (purify (load/purification-root scode)))
+ (extended-scode-eval scode environment))))
+
+(define (source-loader pathname)
+ (lambda (environment purify?)
+ purify?
+ (call-with-input-file pathname
+ (lambda (port)
+ (let loop ((value unspecific))
+ (let ((sexp (read port environment)))
+ (if (eof-object? sexp)
+ value
+ (loop (repl-eval sexp environment)))))))))
+
+(define (wrap-loader pathname loader)
+ (lambda (environment purify?)
+ (lambda ()
+ (fluid-let ((*current-load-environment* environment))
+ (with-eval-unit (pathname->uri pathname)
+ (lambda ()
+ (loader environment purify?)))))))
+\f
+(define (fasload pathname #!optional suppress-notifications?)
+ (receive (pathname* loader notifier) (choose-fasload-method pathname)
+ (if pathname*
+ (maybe-notify suppress-notifications? loader notifier)
+ (load-failure fasload pathname suppress-notifications?))))
+
+(define (file-fasloadable? pathname)
+ (receive (pathname* loader notifier) (choose-fasload-method pathname)
+ loader notifier
+ (if pathname* #t #f)))
+
+(define (choose-fasload-method pathname)
+ (let* ((pathname (merge-pathnames pathname))
+ (thunk
+ (if (pathname-type pathname)
+ (or (try-fasl-file pathname)
+ (try-object-file pathname))
+ (or (try-fasl-file pathname)
+ (try-fasl-file (pathname-new-type pathname "com"))
+ (try-fasl-file (pathname-new-type pathname "bin"))
+ (try-object-file (pathname-new-type pathname "so"))))))
+ (if thunk
+ (receive (pathname loader notifier) (thunk)
+ (values pathname
+ (lambda ()
+ (let ((object (loader)))
+ (fasload/update-debugging-info! object pathname)
+ object))
+ notifier))
+ (values #f #f #f))))
+
+(define (try-fasl-file pathname)
+ (and (fasl-file? pathname)
(lambda ()
- (let ((kernel
- (lambda (filename last-file?)
- (receive (pathname loader)
- (find-pathname filename load/default-types)
- (with-eval-unit (pathname->uri pathname)
- (lambda ()
- (let ((load-it
- (lambda ()
- (loader pathname
- environment
- purify?
- load-noisily?))))
- (cond (last-file? (load-it))
- (load-noisily? (write-line (load-it)))
- (else (load-it) unspecific)))))))))
- (if (pair? filename/s)
- (let loop ((filenames filename/s))
- (if (pair? (cdr filenames))
- (begin
- (kernel (car filenames) #f)
- (loop (cdr filenames)))
- (kernel (car filenames) #t)))
- (kernel filename/s #t))))))))
-
-(define (fasload filename #!optional suppress-loading-message?)
- (receive (pathname loader)
- (find-pathname filename fasload/default-types)
- (loader pathname
- (if (default-object? suppress-loading-message?)
- load/suppress-loading-message?
- suppress-loading-message?))))
+ (values pathname
+ (lambda ()
+ ((ucode-primitive binary-fasload)
+ (->namestring pathname)))
+ (let ((notifier (loading-notifier pathname)))
+ (lambda (thunk)
+ (if (file-modification-time<?
+ pathname
+ (pathname-new-type pathname "scm"))
+ (warn "Source file newer than binary:" pathname))
+ (notifier thunk)))))))
+
+(define (try-object-file pathname)
+ (let ((object (built-in-object-file pathname)))
+ (if object
+ (lambda ()
+ (values pathname
+ (lambda () object)
+ (init-notifier pathname)))
+ (and (object-file? pathname)
+ (lambda ()
+ (values pathname
+ (lambda () (fasload-object-file pathname))
+ (loading-notifier pathname)))))))
+\f
+(define (fasl-file? pathname)
+ (and (file-regular? pathname)
+ (call-with-binary-input-file pathname
+ (lambda (port)
+ (let ((n (vector-ref (gc-space-status) 0)))
+ (let ((marker (make-string n)))
+ (and (eqv? (read-string! marker port) n)
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (fix:= (vector-8b-ref marker i) #xFA)
+ (loop (fix:+ i 1)))
+ #t)))))))))
+
+(define (object-file? pathname)
+ (and (let ((type (pathname-type pathname)))
+ (and (string? type)
+ (string=? type "so")))
+ (file-regular? pathname)))
-(define (current-eval-unit #!optional error?)
- (or *eval-unit*
- (begin
- (if error? (error condition-type:not-loading))
- #f)))
+(define (load/purification-root object)
+ (or (and (comment? object)
+ (let ((text (comment-text object)))
+ (and (dbg-info-vector? text)
+ (dbg-info-vector/purification-root text))))
+ (and (object-type? (ucode-type compiled-entry) object)
+ (let* ((block ((ucode-primitive compiled-code-address->block 1)
+ object))
+ (index (fix:- (system-vector-length block) 3)))
+ (and (fix:>= index 0)
+ (let ((frob (system-vector-ref block index)))
+ (and (pair? frob)
+ (eq? (car frob) *purification-root-marker*)
+ (cdr frob))))))
+ object))
+(define (maybe-notify suppress-notifications? loader notifier)
+ (let ((notify?
+ (if (if (default-object? suppress-notifications?)
+ load/suppress-loading-message?
+ suppress-notifications?)
+ #f
+ *write-notifications?*)))
+ (fluid-let ((*write-notifications?* notify?))
+ (if notify?
+ (notifier loader)
+ (loader)))))
+
+(define (loading-notifier pathname)
+ (lambda (thunk)
+ (with-notification (lambda (port)
+ (write-string "Loading " port)
+ (write (enough-namestring pathname) port))
+ thunk)))
+
+(define (init-notifier pathname)
+ (lambda (thunk)
+ (write-notification-line
+ (lambda (port)
+ (write-string "Initialized " port)
+ (write (enough-namestring pathname) port)))
+ (thunk)))
+\f
(define (with-eval-unit uri thunk)
(fluid-let ((*eval-unit* (->absolute-uri uri 'WITH-EVAL-UNIT)))
(thunk)))
+(define (current-eval-unit #!optional error?)
+ (let ((unit *eval-unit*))
+ (if (and (not unit)
+ (if (default-object? error?) #t error?))
+ (error condition-type:not-loading))
+ unit))
+
(define (current-load-pathname)
(or (uri->pathname (current-eval-unit) #f)
(error condition-type:not-loading)))
-\f
+
(define (load/push-hook! hook)
(if (not load/loading?) (error condition-type:not-loading))
(set! load/after-load-hooks (cons hook load/after-load-hooks))
(for-each (lambda (hook) (hook)) hooks)
result))
-(define (load-noisily filename #!optional environment syntax-table purify?)
- (fluid-let ((load-noisily? #t))
- (load filename environment syntax-table purify?)))
-
-(define (load-latest . args)
- (fluid-let ((load/default-find-pathname-with-type find-latest-file))
- (apply load args)))
-
-(define (fasload-latest . args)
- (fluid-let ((load/default-find-pathname-with-type find-latest-file))
- (apply fasload args)))
-
-(define (find-pathname filename default-types)
- (let ((pathname (merge-pathnames filename))
- (find-loader
- (lambda (extension)
- (let ((place (assoc extension default-types)))
- (and place
- (cadr place)))))
- (fail
- (lambda ()
- (find-pathname (error:file-operation filename
- "find"
- "file"
- "file does not exist"
- find-pathname
- (list filename default-types))
- default-types))))
- (cond ((and (pathname-type pathname)
- (built-in-object-file pathname))
- => (lambda (value)
- (values pathname
- ((find-loader #f) value))))
- ((file-regular? pathname)
- (values pathname
- (or (and (pathname-type pathname)
- (find-loader (pathname-type pathname)))
- (and (fasl-file? pathname)
- (find-loader "bin"))
- (find-loader "scm"))))
- ((pathname-type pathname)
- (fail))
- (else
- (receive (pathname loader)
- (load/default-find-pathname-with-type pathname default-types)
- (if (not pathname)
- (fail)
- (values pathname loader)))))))
+(define (load-failure procedure pathname . arguments)
+ (apply procedure
+ (error:file-operation pathname
+ "find" "file" "file does not exist"
+ procedure
+ (cons pathname arguments))
+ arguments))
\f
-(define (search-types-in-order pathname default-types)
- (let loop ((types default-types))
- (cond ((not (pair? types))
- (values #f #f))
- ((not (caar types))
- (let ((value (built-in-object-file pathname)))
- (if value
- (values pathname ((cadar types) value))
- (loop (cdr types)))))
- (else
- (let ((pathname (pathname-new-type pathname (caar types))))
- (if (file-regular? pathname)
- (values pathname (cadar types))
- (loop (cdr types))))))))
-
-;; This always considers a built-in to be the newest.
-
-(define (find-latest-file pathname default-types)
- (let loop ((types default-types)
- (latest-pathname #f)
- (latest-loader #f)
- (latest-time 0))
- (cond ((not (pair? types))
- (values latest-pathname latest-loader))
- ((not (caar types))
- (let ((value (built-in-object-file pathname)))
- (if value
- (values pathname ((cadar types) value))
- (loop (cdr types)
- latest-pathname
- latest-loader
- latest-time))))
- (else
- (let ((pathname (pathname-new-type pathname (caar types))))
- (let ((time (file-modification-time-indirect pathname)))
- (if (and time (> time latest-time))
- (loop (cdr types) pathname (cadar types) time)
- (loop (cdr types)
- latest-pathname
- latest-loader
- latest-time))))))))
+(define (fasload-object-file pathname)
+ (let ((pathname (object-file-pathname pathname)))
+ (let ((handle (dld-load-file pathname))
+ (uri (pathname->standard-uri pathname)))
+ (let ((nonce (liarc-object-file-nonce handle)))
+ (if nonce
+ (register-liarc-object-file uri nonce)))
+ (initialize-object-file handle uri))))
+
+(define (register-liarc-object-file uri nonce)
+ (add-event-receiver!
+ event:after-restore
+ (lambda ()
+ (let ((handle (dld-load-file (standard-uri->pathname uri))))
+ (let ((nonce* (liarc-object-file-nonce handle)))
+ (if (not (and nonce* (string=? nonce* nonce)))
+ (begin
+ (dld-unload-file handle)
+ (error "Can't restore liarc object file:" uri))))
+ (initialize-object-file handle uri)))))
+
+(define (liarc-object-file-nonce handle)
+ (let ((nonce
+ (ignore-errors
+ (lambda ()
+ ((ucode-primitive address-to-string 1)
+ (dld-lookup-symbol handle "dload_nonce"))))))
+ (and (string? nonce)
+ nonce)))
+
+(define (initialize-object-file handle uri)
+ ((ucode-primitive initialize-c-compiled-block 1)
+ ((ucode-primitive address-to-string 1)
+ ((ucode-primitive initialize-liarc-object-file 2)
+ (dld-lookup-symbol handle "dload_initialize_file")
+ (object-file-prefix uri)))))
+
+(define (object-file-prefix uri)
+ (let ((pathname (uri->pathname uri #f)))
+ (if pathname
+ (directory-namestring pathname)
+ (uri->string
+ ;; This kludge has far too much knowledge of the URI
+ ;; argument. It's an expedient to work around the lack of
+ ;; URI comparison operations.
+ (make-uri (uri-scheme uri)
+ (uri-authority uri)
+ (let ((path (uri-path uri)))
+ (let ((p (except-last-pair path))
+ (s (last path)))
+ (append
+ (except-last-pair p)
+ (if (and (equal? p
+ '("" "software" "mit-scheme"
+ "lib" "lib"))
+ (string-suffix? ".so" s))
+ (list (string-head s (fix:- (string-length s) 3)))
+ '())
+ (list ""))))
+ #f
+ #f)))))
\f
-(define (load/internal pathname environment purify? load-noisily?)
- (if (fasl-file? pathname)
- (load-scode-end (fasload/internal pathname
- load/suppress-loading-message?)
- environment
- purify?)
- (call-with-input-file pathname
- (lambda (port)
- (let ((value-stream
- (lambda ()
- (eval-stream (read-stream port environment) environment))))
- (if load-noisily?
- (write-stream (value-stream)
- (lambda (exp&value)
- (repl-write (cdr exp&value) (car exp&value))))
- (with-loading-message pathname
- (lambda ()
- (write-stream (value-stream)
- (lambda (exp&value) exp&value #f))))))))))
-
-(define (fasload/internal pathname suppress-loading-message?)
- (let ((namestring (->namestring pathname)))
- (if (and (not suppress-loading-message?)
- (file-modification-time<? pathname
- (pathname-new-type pathname "scm")))
- (warn "Source file newer than binary:" namestring))
- (let ((value
- (with-loading-message pathname
- (lambda ()
- ((ucode-primitive binary-fasload) namestring))
- suppress-loading-message?)))
- (fasload/update-debugging-info! value pathname)
- value)))
-
-(define (fasload-object-file pathname suppress-loading-message?)
- (with-loading-message pathname
- (lambda ()
- (let ((scode (fasload-liarc-object-file pathname)))
- (fasload/update-debugging-info! scode pathname)
- scode))
- suppress-loading-message?))
-
-(define (fasload-liarc-object-file pathname)
- (let* ((handle ((ucode-primitive load-object-file 1)
- (->namestring pathname)))
- (cth ((ucode-primitive object-lookup-symbol 3)
- handle "dload_initialize_file" 0)))
- (if (not cth)
- (error "Cannot find init procedure:" pathname))
- ((ucode-primitive initialize-c-compiled-block 1)
- ((ucode-primitive address-to-string 1)
- ((ucode-primitive invoke-c-thunk 1)
- cth)))))
-
(define (built-in-object-file pathname)
- (let ((handle (liarc-object-pathname->handle pathname)))
- (and handle
- ((ucode-primitive initialize-c-compiled-block 1) handle))))
-
-(define (liarc-object-pathname->handle pathname)
- (let ((pathname (pathname-simplify (merge-pathnames pathname))))
- (let ((d (pathname-directory pathname))
- (n (pathname-name pathname))
- (t (pathname-type pathname)))
- (and (pair? d)
- (let ((tail (last d)))
- (and (string? tail) ;Doesn't handle UP ("..").
- (string-append tail "_" n
- (cond ((not t) ".so")
- ((string? t) (string-append "." t))
- (else "")))))))))
-
-(define (wrapper/fasload/built-in value)
- (lambda (pathname suppress-loading-message?)
- (fasload/update-debugging-info! value pathname)
- (write-init-message pathname suppress-loading-message?)
- value))
-\f
-(define (load-object-file pathname environment purify? load-noisily?)
- load-noisily? ; ignored
- (load-scode-end
- (fasload-object-file pathname load/suppress-loading-message?)
- environment
- purify?))
-
-(define (wrapper/load/built-in scode)
- (lambda (pathname environment purify? load-noisily?)
- load-noisily? ; ignored
- (fasload/update-debugging-info! scode pathname)
- (let ((value (load-scode-end scode environment purify?)))
- (write-init-message pathname)
- value)))
-
-(define (load-scode-end scode environment purify?)
- (if purify? (purify (load/purification-root scode)))
- (extended-scode-eval scode
- (if (default-object? environment)
- (nearest-repl/environment)
- environment)))
-
-(define (load-library-object-file name errors? #!optional noisy?)
- (let ((directory (system-library-directory-pathname "lib"))
- (nsf
- (lambda ()
- (and errors?
- (error "No library object file of this name:" name)))))
- (if (not directory)
- (nsf))
- (let ((pathname (merge-pathnames name directory)))
- (if (there-exists? loaded-object-files
- (lambda (pathname*)
- (pathname=? pathname* pathname)))
- #t
- (let ((pathname* (pathname-new-type pathname "so")))
- (if (not (file-regular? pathname*))
- (nsf))
- (let ((condition
- (ignore-errors
- (lambda ()
- (fluid-let ((load/suppress-loading-message?
- (if (default-object? noisy?) #f noisy?)))
- (load pathname*))))))
- (if condition
- (if errors?
- (signal-condition condition)
- condition)
- (begin
- (set! loaded-object-files
- (cons pathname loaded-object-files))
- #t))))))))
-
-(define (reset-loaded-object-files!)
- (set! loaded-object-files '())
- unspecific)
-\f
-(define (with-loading-message pathname thunk #!optional suppress-message?)
- (if (if (default-object? suppress-message?)
- load/suppress-loading-message?
- suppress-message?)
- (thunk)
- (with-notification (lambda (port)
- (write-string "Loading " port)
- (write (enough-namestring pathname) port))
- thunk)))
-
-(define (write-init-message pathname #!optional suppress-message?)
- (if (not (if (default-object? suppress-message?)
- load/suppress-loading-message?
- suppress-message?))
- (write-notification-line
- (lambda (port)
- (write-string "Initialized " port)
- (write (enough-namestring pathname) port)))))
+ ((ucode-primitive initialize-c-compiled-block 1)
+ (uri->string (pathname->standard-uri (object-file-pathname pathname)))))
+
+(define (object-file-pathname pathname)
+ (pathname-default-type (pathname-simplify (merge-pathnames pathname))
+ "so"))
+
+(define (load-library-object-file name errors?)
+ (let ((pathname
+ (merge-pathnames (pathname-new-type name "so")
+ (system-library-directory-pathname "lib"))))
+ (if (and errors? (not (file-regular? pathname)))
+ (error "No library object file of this name:" name))
+ (if (dld-loaded-file? pathname)
+ #t
+ (let ((load-it (lambda () (load pathname))))
+ (if errors?
+ (load-it)
+ (ignore-errors load-it))))))
+
+(define (with-loader-base-uri uri thunk)
+ (let ((directory (directory-pathname (current-load-pathname))))
+ (with-working-directory-pathname directory
+ (lambda ()
+ (with-directory-rewriting-rule directory
+ (pathname-as-directory (last (uri-path uri)))
+ thunk)))))
+
+(define (pathname->standard-uri pathname)
+ (let ((uri
+ (pathname->uri
+ (enough-pathname pathname (system-library-directory-pathname)))))
+ (if (uri-absolute? uri)
+ uri
+ (system-library-uri uri))))
+
+(define (standard-uri->pathname uri)
+ (or (uri->pathname uri #f)
+ (merge-pathnames
+ (uri->pathname (make-uri #f #f (list-tail (uri-path uri) 4) #f #f))
+ (system-library-directory-pathname))))
+
+(define (system-uri #!optional rel-uri)
+ (if (string? system-base-uri)
+ (begin
+ (set! system-base-uri (string->uri system-base-uri))
+ unspecific))
+ (maybe-merge rel-uri system-base-uri 'SYSTEM-URI))
-(define *purification-root-marker*)
+(define system-base-uri "http://www.gnu.org/software/mit-scheme/")
-(define (load/purification-root object)
- (or (and (comment? object)
- (let ((text (comment-text object)))
- (and (dbg-info-vector? text)
- (dbg-info-vector/purification-root text))))
- (and (object-type? (ucode-type compiled-entry) object)
- (let* ((block ((ucode-primitive compiled-code-address->block 1)
- object))
- (index (- (system-vector-length block) 3)))
- (and (not (negative? index))
- (let ((frob (system-vector-ref block index)))
- (and (pair? frob)
- (eq? (car frob) *purification-root-marker*)
- (cdr frob))))))
- object))
+(define (system-library-uri #!optional rel-uri)
+ (maybe-merge rel-uri (system-uri "lib/") 'SYSTEM-LIBRARY-URI))
-(define (read-file filename #!optional environment)
- (call-with-input-file (pathname-default-version filename 'NEWEST)
- (lambda (port)
- (stream->list (read-stream port environment)))))
-
-(define (read-stream port environment)
- (parse-objects port
- environment
- (lambda (object)
- (and (eof-object? object)
- (begin
- (close-input-port port)
- #t)))))
-
-(define (eval-stream stream environment)
- (stream-map stream
- (lambda (s-expression)
- (cons s-expression
- (repl-eval s-expression environment)))))
-
-(define (write-stream stream write)
- (if (stream-pair? stream)
- (let loop ((exp&value (stream-car stream)) (stream (stream-cdr stream)))
- (if (stream-pair? stream)
- (begin
- (write exp&value)
- (loop (stream-car stream) (stream-cdr stream)))
- (cdr exp&value)))
- unspecific))
-
-(define (fasl-file? pathname)
- (call-with-binary-input-file pathname
- (lambda (port)
- (let ((n (vector-ref (gc-space-status) 0)))
- (let ((marker (make-string n)))
- (and (eqv? (read-string! marker port) n)
- (let loop ((i 0))
- (if (fix:< i n)
- (and (fix:= (vector-8b-ref marker i) #xFA)
- (loop (fix:+ i 1)))
- #t))))))))
+(define (maybe-merge rel-uri base-uri caller)
+ (if (default-object? rel-uri)
+ base-uri
+ (merge-uris (->relative-uri rel-uri caller) base-uri)))
\f
;;;; Command Line Parser
#| -*-Scheme-*-
-$Id: make.scm,v 14.110 2007/04/15 15:50:38 cph Exp $
+$Id: make.scm,v 14.111 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(and (file-exists? bin-file)
bin-file)))))
-(define (file->object filename purify? optional?)
- (let* ((block-name (string-append "runtime_" filename ".so"))
+(define runtime-prefix
+ "http://www.gnu.org/software/mit-scheme/lib/runtime/")
+
+(define (file->object filename purify? required?)
+ (let* ((block-name (string-append runtime-prefix filename ".so"))
(value (initialize-c-compiled-block block-name)))
(cond (value
(tty-write-string newline-string)
((map-filename filename)
=> (lambda (mapped)
(fasload mapped purify?)))
- ((not optional?)
- (fatal-error (string-append "Could not find " filename)))
- (else
- #f))))
+ (required? (fatal-error (string-append "Could not find " filename)))
+ (else #f))))
(define (eval object environment)
(let ((value (scode-eval object environment)))
\f
;; Construct the package structure.
;; Lotta hair here to load the package code before its package is built.
-(eval (file->object "packag" #t #f) environment-for-package)
+(eval (file->object "packag" #t #t) environment-for-package)
((lexical-reference environment-for-package 'INITIALIZE-PACKAGE!))
(let ((export
(lambda (name)
((eq? os-name 'UNIX) "unx")
(else "unk"))
".pkd")))
- (or (initialize-c-compiled-block (string-append "runtime_" name))
+ (or (initialize-c-compiled-block (string-append runtime-prefix name))
(fasload name #f))))
((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE)
(lambda (files)
(do ((files files (cdr files)))
((null? files))
- (eval (file->object (car (car files)) #t #f)
+ (eval (file->object (car (car files)) #t #t)
(package-reference (cdr (car files))))))))
(load-files files1)
(package-initialize '(RUNTIME GC-DAEMONS) 'INITIALIZE-PACKAGE! #t)
(string=? filename "packag")
(file-member? filename files1)
(file-member? filename files2)))
- (eval (file->object filename #t #f)
+ (eval (file->object filename #t #t)
environment))
unspecific))))
\f
(if (eq? os-name 'NT)
(package-initialize '(RUNTIME WIN32-REGISTRY) 'INITIALIZE-PACKAGE! #f))
\f
-(let ((obj (file->object "site" #t #t)))
+(let ((obj (file->object "site" #t #f)))
(if obj
(eval obj system-global-environment)))
#| -*-Scheme-*-
-$Id: option.scm,v 14.55 2007/05/21 17:33:31 cph Exp $
+$Id: option.scm,v 14.56 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(set! loaded-options (cons name loaded-options))
name)
- (define (search-parent file)
+ (define (search-parent pathname)
(call-with-values
(lambda ()
(fluid-let ((*options* '())
(*parent* #f))
(fluid-let ((load/suppress-loading-message? #t))
- (load-latest (system-library-pathname file #f)
- (make-load-environment)
- 'DEFAULT
- #f))
+ (load pathname (make-load-environment)))
(values *options* *parent*)))
find-option))
"optiondb"))
(define (library-file? library-internal-path)
- (confirm-pathname
- (merge-pathnames library-internal-path
- (system-library-directory-pathname))))
+ (confirm-pathname (system-library-pathname library-internal-path #f)))
(define (confirm-pathname pathname)
- (receive (pathname* loader)
- (search-types-in-order pathname load/default-types)
- pathname*
- (and loader pathname)))
+ (and (file-loadable? pathname)
+ pathname))
(define loaded-options '())
(define *options* '()) ; Current options.
(flush-purification-queue!)
(eval init-expression environment))))
-(define (declare-shared-library shared-library thunk)
- (add-event-receiver!
- event:after-restore
- (lambda ()
- (if (condition? (ignore-errors thunk))
- (fluid-let ((load/suppress-loading-message? #t))
- (load
- (merge-pathnames
- shared-library
- (system-library-directory-pathname "lib" #t))))))))
-
(define (force* value)
(cond ((procedure? value) (force* (value)))
((promise? value) (force* (force value)))
#| -*-Scheme-*-
-$Id: packag.scm,v 14.54 2007/05/20 01:52:37 cph Exp $
+$Id: packag.scm,v 14.55 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(if (not (package-file? file))
(error "Malformed package-description file:" pkg))
(construct-packages-from-file file)
- (fluid-let
- ((load/default-types
- (if (and system-loader/enable-query?
- (prompt-for-confirmation "Load interpreted"))
- (list (assoc "bin" load/default-types)
- (assoc "scm" load/default-types))
- load/default-types)))
- (let ((alternate-loader
- (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
- (load-component
- (lambda (name environment)
- (let ((value (filename->compiled-object dir name)))
- (if value
- (begin
- (purify (load/purification-root value))
- (scode-eval value environment))
- (load name environment 'DEFAULT #t))))))
- (if alternate-loader
- (alternate-loader load-component options)
- (begin
- (load-packages-from-file file options load-component)
- (initialize-packages-from-file file))))))))))
+ (let ((alternate-loader
+ (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
+ (load-component
+ (lambda (name environment)
+ (let ((value (filename->compiled-object dir name)))
+ (if value
+ (begin
+ (purify (load/purification-root value))
+ (scode-eval value environment))
+ (load name environment 'DEFAULT #t))))))
+ (if alternate-loader
+ (alternate-loader load-component options)
+ (begin
+ (load-packages-from-file file options load-component)
+ (initialize-packages-from-file file)))))))))
;; Make sure that everything we just loaded is purified. If the
;; program runs before it gets purified, some of its run-time state
;; can end up being purified also.
(flush-purification-queue!))
+;; Obsolete and ignored:
(define system-loader/enable-query? #f)
(define (package-set-pathname pathname #!optional os-type)
#| -*-Scheme-*-
-$Id: pathnm.scm,v 14.52 2007/05/21 17:33:32 cph Exp $
+$Id: pathnm.scm,v 14.53 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(%find-library-directory)))
(define (%find-library-directory)
- (pathname-as-directory
+ (pathname-simplify
(or (find-matching-item library-directory-path file-directory?)
(error "Can't find library directory."))))
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.617 2007/05/02 00:11:05 cph Exp $
+$Id: runtime.pkg,v 14.618 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(export (runtime load)
dbg-info-vector/purification-root
dbg-info-vector?
- fasload/update-debugging-info!)
+ fasload/update-debugging-info!
+ with-directory-rewriting-rule)
(export (runtime program-copier)
dbg-info-vector?)
(export (runtime debugger-command-loop)
uncompress-internal)
(export (runtime options)
with-directory-rewriting-rule)
- (export (runtime continuation-parser)
- )
(initialization (initialize-package!)))
(define-package (runtime console-i/o-port)
read
read-char
read-char-no-hang
+ read-file
read-line
read-string
read-string!
(files "load")
(parent (runtime))
(export ()
+ (load-latest load)
+ (load-noisily load)
argument-command-line-parser
built-in-object-file
condition-type:not-loading
current-load-pathname
fasl-file?
fasload
- fasload-latest
- fasload-liarc-object-file
- fasload/default-types
- liarc-object-pathname->handle
+ file-fasloadable?
+ file-loadable?
load
- load-latest
load-library-object-file
- load-noisily
load-noisily?
- load/default-find-pathname-with-type
- load/default-types
load/loading?
load/purification-root
load/push-hook!
load/suppress-loading-message?
- read-file
set-command-line-parser!
simple-command-line-parser
- with-loading-message
- with-eval-unit)
- (export (runtime options)
- search-types-in-order)
+ system-library-uri
+ system-uri
+ with-eval-unit
+ with-loader-base-uri)
(initialization (initialize-package!)))
(define-package (runtime microcode-errors)
(parent (runtime))
(export ()
*initial-options-file*
- declare-shared-library
define-load-option
dummy-option-loader
further-load-options
(files "io")
(parent (runtime))
(export ()
+ all-dld-handles
all-open-channels
channel-blocking
channel-blocking?
directory-channel-read
directory-channel-read-matching
directory-channel?
+ dld-get-scheme-handle
+ dld-handle-pathname
+ dld-handle-valid?
+ dld-handle?
+ dld-load-file
+ dld-loaded-file?
+ dld-lookup-symbol
+ dld-unload-file
+ error:not-channel
+ error:not-directory-channel
+ error:not-dld-handle
file-open-append-channel
file-open-input-channel
file-open-io-channel
file-open-output-channel
+ find-dld-handle
+ guarantee-channel
+ guarantee-directory-channel
+ guarantee-dld-handle
+ guarantee-valid-dld-handle
make-pipe
open-pty-master
pty-master-continue
#| -*-Scheme-*-
-$Id: utabs.scm,v 14.25 2007/05/02 00:11:10 cph Exp $
+$Id: utabs.scm,v 14.26 2007/06/06 19:42:42 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(set! microcode-tables-identification
(scode-eval
(or ((ucode-primitive initialize-c-compiled-block 1)
- "microcode_utabmd.so")
+ "http://www.gnu.org/software/mit-scheme/lib/microcode/utabmd.so")
((ucode-primitive binary-fasload)
(if (default-object? filename)
((ucode-primitive microcode-tables-filename))
#| -*-Scheme-*-
-$Id: make.scm,v 4.47 2007/04/14 03:55:02 cph Exp $
+$Id: make.scm,v 4.48 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(declare (usual-integrations))
-(declare-shared-library "sf" (lambda () #t))
(with-working-directory-pathname
(directory-pathname (current-load-pathname))
(lambda ()
#| -*-Scheme-*-
-$Id: load.scm,v 1.19 2007/04/04 05:08:19 riastradh Exp $
+$Id: load.scm,v 1.20 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (declare-shared-library "sos" (lambda () #t))
(load-package-set "sos")))
(add-subsystem-identification! "SOS" '(1 8))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.9 2007/04/04 05:08:19 riastradh Exp $
+$Id: load.scm,v 1.10 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load-option 'mime-codec)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (declare-shared-library "ssp" (lambda () #t))
(load-package-set "ssp")))
(add-subsystem-identification! "SSP" '(0 4))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.21 2007/04/14 03:55:06 cph Exp $
+$Id: load.scm,v 1.22 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(pathname-as-directory "star-parser")
(lambda ()
(load-package-set "parser")))))
-(declare-shared-library "star-parser" (lambda () (global-parser-macros)))
(add-subsystem-identification! "*Parser" '(0 13))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.6 2007/04/04 05:08:19 riastradh Exp $
+$Id: load.scm,v 1.7 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(export 'xml-comment 'comment)))
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (declare-shared-library "xdoc" (lambda () #t))
(load-package-set "xdoc")))
(add-subsystem-identification! "XDOC" '(0 3))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: load.scm,v 1.20 2007/04/04 05:08:19 riastradh Exp $
+$Id: load.scm,v 1.21 2007/06/06 19:42:43 cph Exp $
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load-option 'SOS)
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
- (declare-shared-library "xml" (lambda () #t))
(load-package-set "xml")))
(add-subsystem-identification! "XML" '(1 0))
\ No newline at end of file
projects / mit-scheme.git / commitdiff