From: Chris Hanson Date: Wed, 6 Jun 2007 19:42:43 +0000 (+0000) Subject: Reorganize the Scheme loader to simplify it so that I can understand X-Git-Tag: 20090517-FFI~547 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cc397d6ffdf6a4ebac3a3669c40e0ffeb59e8306;p=mit-scheme.git Reorganize the Scheme loader to simplify it so that I can understand what it's doing. In the process, the LOAD-NOISILY and LOAD-NEWEST _features_ have been eliminated, although the procedures remain as aliases for LOAD. New procedures FILE-LOADABLE? and FILE-FASLOADABLE? test whether a particular file is one that LOAD or FASLOAD (respectively) knows how to handle. New procedures SYSTEM-URI, SYSTEM-LIBRARY-URI, and WITH-LOADER-BASE-URI provide a standard mechanism to refer to files in the system library directory. Eliminate DECLARE-SHARED-LIBRARY; register every .so file that's loaded, and reload it on disk-restore. Change the dynamic-loader interface to support unloading object files. Make sure that all loaded object files are unloaded on DISK-RESTORE. Implement low-level interface to the dynamic loader in "runtime/io.scm" and use that in "runtime/load.scm". Implement new primitive LIARC-COMPILED-BLOCKS, to simplify examination of the compiled_blocks table. Change registration of .so files to use URIs rather than ad-hoc abbreviations. Standard URIs refer to parts of the system, and are independent of the file-system details; file URIs refer to .so files stored in particular locations. Add an 8-byte random nonce to each .c file generated by liarc, so that the loader can tell if it's the same file as a previously loaded one. Write new program gen-nonce for use by c-bundle.sh. Move makefile creation from Setup.sh to configure, so that it can depend on the architecture. Rewrite parts of "Makefile.in" and "etc/compile.scm" to support compiling a native-code system using liarc. Change "etc/utilities.scm" to support liarc when it is installed as well as when it is being built. Write new program extract-liarc-decls for c-bundle.sh to use, in place of of grep. This program rewrites each declaration to specialize it for bundling. --- diff --git a/v7/src/Makefile.in b/v7/src/Makefile.in index 2ead8f90a..4d46b7136 100644 --- a/v7/src/Makefile.in +++ b/v7/src/Makefile.in @@ -1,4 +1,4 @@ -# $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, @@ -68,7 +68,8 @@ SUBDIRS = $(INSTALLED_SUBDIRS) 6001 compiler rcs win32 xdoc 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 @@ -87,35 +88,39 @@ all-native: 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 \ @@ -130,18 +135,24 @@ compile-liarc-bundles: 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 diff --git a/v7/src/Setup.sh b/v7/src/Setup.sh index ddd3d674c..5f6cf26bc 100755 --- a/v7/src/Setup.sh +++ b/v7/src/Setup.sh @@ -1,6 +1,6 @@ #!/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, @@ -35,6 +35,9 @@ fi . 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 @@ -51,30 +54,8 @@ maybe_link lib/edwin/etc/TUTORIAL ../../../etc/TUTORIAL 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 < ${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 diff --git a/v7/src/compiler/choose-machine.sh b/v7/src/compiler/choose-machine.sh new file mode 100755 index 000000000..e94295964 --- /dev/null +++ b/v7/src/compiler/choose-machine.sh @@ -0,0 +1,90 @@ +#!/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 diff --git a/v7/src/compiler/configure b/v7/src/compiler/configure index 4620f1b56..37cbdcc43 100755 --- a/v7/src/compiler/configure +++ b/v7/src/compiler/configure @@ -1,6 +1,6 @@ #!/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, @@ -23,19 +23,17 @@ # 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 ;; *) @@ -43,48 +41,13 @@ while test $# -gt 0; do ;; 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 @@ -92,6 +55,8 @@ 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 diff --git a/v7/src/compiler/machines/C/compiler.pkg b/v7/src/compiler/machines/C/compiler.pkg index 1cfdd036b..945604ca1 100644 --- a/v7/src/compiler/machines/C/compiler.pkg +++ b/v7/src/compiler/machines/C/compiler.pkg @@ -1,6 +1,6 @@ #| -*-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, @@ -283,7 +283,9 @@ USA. 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)) (define-package (compiler debug) (files "base/debug") diff --git a/v7/src/compiler/machines/C/cout.scm b/v7/src/compiler/machines/C/cout.scm index aa61f2ad0..50d1cb0a2 100644 --- a/v7/src/compiler/machines/C/cout.scm +++ b/v7/src/compiler/machines/C/cout.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -103,13 +103,12 @@ USA. (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))))) (define (stringify suffix initial-label lap-code info-output-pathname) ;; returns @@ -508,10 +507,14 @@ USA. (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) diff --git a/v7/src/compiler/machines/C/ctop.scm b/v7/src/compiler/machines/C/ctop.scm index 6483938b0..b05d9cfe7 100644 --- a/v7/src/compiler/machines/C/ctop.scm +++ b/v7/src/compiler/machines/C/ctop.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -55,7 +55,7 @@ USA. (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)) diff --git a/v7/src/compiler/machines/C/make.scm b/v7/src/compiler/machines/C/make.scm index 0611bc7e5..84257fa27 100644 --- a/v7/src/compiler/machines/C/make.scm +++ b/v7/src/compiler/machines/C/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -31,7 +31,6 @@ USA. (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? diff --git a/v7/src/configure.ac b/v7/src/configure.ac index 85bf2ed37..721fd973f 100644 --- a/v7/src/configure.ac +++ b/v7/src/configure.ac @@ -1,7 +1,7 @@ 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 @@ -65,6 +65,8 @@ then INSTALL="${INSTALL} --preserve-timestamps" fi +etc/create-makefiles.sh "${enable_native_code}" + AC_CONFIG_SUBDIRS([microcode compiler]) AC_CONFIG_FILES([ Makefile diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm index 66a6bab3a..ac81d669e 100644 --- a/v7/src/cref/make.scm +++ b/v7/src/cref/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -30,7 +30,6 @@ USA. (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 diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 679c10d3b..77b259f13 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -29,15 +29,9 @@ USA. (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 diff --git a/v7/src/etc/build-bands.sh b/v7/src/etc/build-bands.sh index 6c6e4bd40..c9bcfbf44 100755 --- a/v7/src/etc/build-bands.sh +++ b/v7/src/etc/build-bands.sh @@ -1,6 +1,6 @@ #!/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, @@ -30,7 +30,7 @@ echo "cd runtime" 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 diff --git a/v7/src/etc/c-boot-compiler-2.sh b/v7/src/etc/build-boot-compiler.sh similarity index 73% rename from v7/src/etc/c-boot-compiler-2.sh rename to v7/src/etc/build-boot-compiler.sh index f15ce1320..93da9d330 100755 --- a/v7/src/etc/c-boot-compiler-2.sh +++ b/v7/src/etc/build-boot-compiler.sh @@ -1,6 +1,6 @@ #!/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, @@ -29,16 +29,27 @@ if [ ${#} -eq 2 ]; then LIB=${1} BAND=${2} else - echo "usage: ${0} " + echo "usage: ${0} " 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}" < "${SYSTEM}.h" +GEN_NONCE=${AUXDIR}/gen-nonce +EXTRACT_DECLS=${AUXDIR}/extract-liarc-decls + +"${EXTRACT_DECLS}" "${@}" > "${SYSTEM}.h" cat < "${SYSTEM}.c" @@ -111,6 +112,7 @@ initialize_compiled_code_blocks (void) EOF ;; library) + NONCE=`"${GEN_NONCE}" 8` cat <> "${SYSTEM}.c" #define DECLARE_COMPILED_CODE(name, nentries, decl_code, code) \\ @@ -135,6 +137,8 @@ dload_initialize_file (void) #include "${SYSTEM}.h" return (0); } + +const char dload_nonce [] = "${NONCE}"; EOF ;; *) diff --git a/v7/src/etc/c-prepare.sh b/v7/src/etc/c-prepare.sh index 6c855f8b4..be90419c6 100755 --- a/v7/src/etc/c-prepare.sh +++ b/v7/src/etc/c-prepare.sh @@ -1,8 +1,10 @@ #!/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. # @@ -23,22 +25,18 @@ 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} " + exit 1 fi +CMD="${EXE} --heap 6000" -SCHEME_COMPILER="${SCHEME_COMPILER} --heap 6000" - -echo "${SCHEME_COMPILER}" -${SCHEME_COMPILER} < " + echo "usage: ${0} " 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} <package '(cross-reference))) - (load-dir "cref"))) + (with-working-directory-pathname "cref" + (lambda () + (load "make"))))) (define (compile-dir name) (with-working-directory-pathname name @@ -54,17 +56,6 @@ USA. (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")))))) (define (compile-bootstrap-1) (load-option 'SF) @@ -73,31 +64,49 @@ USA. (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)) diff --git a/v7/src/etc/create-makefiles.sh b/v7/src/etc/create-makefiles.sh new file mode 100755 index 000000000..cf260ee15 --- /dev/null +++ b/v7/src/etc/create-makefiles.sh @@ -0,0 +1,67 @@ +#!/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 < ${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 diff --git a/v7/src/etc/native-prepare.sh b/v7/src/etc/native-prepare.sh new file mode 100755 index 000000000..89e3a997a --- /dev/null +++ b/v7/src/etc/native-prepare.sh @@ -0,0 +1,42 @@ +#!/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} " + exit 1 +fi +CMD="${EXE} --heap 6000" + +echo "${CMD}" +${CMD} <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)))))))) (define-load-option 'EDWIN (guarded-system-loader '(edwin) "edwin")) diff --git a/v7/src/etc/std-makefile-prefix b/v7/src/etc/std-makefile-prefix index f19ebf394..cd13b7358 100644 --- a/v7/src/etc/std-makefile-prefix +++ b/v7/src/etc/std-makefile-prefix @@ -1,4 +1,4 @@ -# $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, @@ -69,10 +69,6 @@ mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs AUXDIR = @AUXDIR@ -.c.o: - @$(top_builddir)/microcode/liarc-cc $*.o $*.c \ - -I$(top_builddir)/microcode - all: echo "No ALL action" diff --git a/v7/src/etc/utilities.scm b/v7/src/etc/utilities.scm index 17af96b75..8bc85a3e6 100644 --- a/v7/src/etc/utilities.scm +++ b/v7/src/etc/utilities.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -31,52 +31,81 @@ USA. (load-option (quote CREF)) -(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") + )))))))))) + (define (bundle-files bundle) (let ((pkg-name (if (string=? bundle "star-parser") "parser" bundle))) (cons (string-append pkg-name "-unx") @@ -94,7 +123,10 @@ USA. (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") diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm index 6b0d65135..f0c9d9a5d 100644 --- a/v7/src/imail/load.scm +++ b/v7/src/imail/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -32,7 +32,6 @@ USA. (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 diff --git a/v7/src/microcode/cmpauxmd/c.c b/v7/src/microcode/cmpauxmd/c.c index 5738fa8d6..ff2d48a5a 100644 --- a/v7/src/microcode/cmpauxmd/c.c +++ b/v7/src/microcode/cmpauxmd/c.c @@ -1,6 +1,6 @@ /* -*-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, @@ -31,8 +31,10 @@ USA. #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); #ifdef BUG_GCC_LONG_CALLS @@ -127,6 +129,9 @@ static compiled_block_t ** compiled_entries = 0; #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); @@ -187,7 +192,7 @@ initialize_C_interface (void) } 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 @@ -245,16 +250,9 @@ export_c_code_table (SCHEME_OBJECT * start) } } -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) @@ -270,6 +268,17 @@ import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks) 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); @@ -291,16 +300,41 @@ import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks) return (true); } +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) @@ -311,13 +345,19 @@ declare_compiled_code_ns (const char * name, 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; @@ -340,6 +380,21 @@ declare_compiled_code_ns (const char * name, return (-1); } +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) { @@ -387,54 +442,52 @@ grow_compiled_entries (entry_count_t entries_end) compiled_entries = new_entries; return (true); } - + 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); } - + 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); } @@ -475,9 +528,9 @@ declare_compiled_data_mult (unsigned int nslots, 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 @@ -520,6 +573,41 @@ lrealloc (void * ptr, size_t size) { 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; + } +} int multiply_with_overflow (long x, long y, long * res) diff --git a/v7/src/microcode/cmpintmd/c.h b/v7/src/microcode/cmpintmd/c.h index 2d8df987f..810c62d44 100644 --- a/v7/src/microcode/cmpintmd/c.h +++ b/v7/src/microcode/cmpintmd/c.h @@ -1,6 +1,6 @@ /* -*-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, @@ -141,11 +141,13 @@ typedef SCHEME_OBJECT insn_t; #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 */ diff --git a/v7/src/microcode/comutl.c b/v7/src/microcode/comutl.c index 2e36dbf5b..41721074f 100644 --- a/v7/src/microcode/comutl.c +++ b/v7/src/microcode/comutl.c @@ -1,6 +1,6 @@ /* -*-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, @@ -28,8 +28,15 @@ USA. /* 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.") @@ -188,22 +195,47 @@ DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1, 0) } } -#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.") @@ -217,6 +249,52 @@ DEFINE_PRIMITIVE ("DECLARE-COMPILED-CODE-BLOCK", 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 +} DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1, "(compiled-entry-object)\n\ diff --git a/v7/src/microcode/configure.ac b/v7/src/microcode/configure.ac index 4ce02b7e1..5b6534046 100644 --- a/v7/src/microcode/configure.ac +++ b/v7/src/microcode/configure.ac @@ -1,7 +1,7 @@ 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 @@ -195,6 +195,7 @@ MODULE_CFLAGS= MODULE_LDFLAGS= LIARC_VARS=/dev/null LIARC_RULES=/dev/null +AUX_PROGRAMS= SYSTEM_BASE_NAME=mit-scheme INSTALL_INCLUDE= @@ -793,6 +794,8 @@ if test ${enable_static_libs} != no; then 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 @@ -930,6 +933,7 @@ c) 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 ;; @@ -990,6 +994,7 @@ AC_SUBST([MODULE_CFLAGS]) 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]) diff --git a/v7/src/microcode/extract-liarc-decls.c b/v7/src/microcode/extract-liarc-decls.c new file mode 100644 index 000000000..c68b282d8 --- /dev/null +++ b/v7/src/microcode/extract-liarc-decls.c @@ -0,0 +1,269 @@ +/* -*-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 +#include +#include +#include + +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; + +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); +} diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index e850d4268..d892e669d 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-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, @@ -382,12 +382,16 @@ load_file (fasl_file_handle_t handle) (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 diff --git a/v7/src/microcode/liarc.h b/v7/src/microcode/liarc.h index 5c4c5d2cf..0faf6f3fe 100644 --- a/v7/src/microcode/liarc.h +++ b/v7/src/microcode/liarc.h @@ -1,6 +1,6 @@ /* -*-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, @@ -401,7 +401,9 @@ dload_initialize_data (void) \ 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) \ { \ @@ -412,7 +414,9 @@ 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) \ { \ @@ -425,8 +429,8 @@ 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 */ diff --git a/v7/src/microcode/makegen/Makefile.in.in b/v7/src/microcode/makegen/Makefile.in.in index 89dbac322..fb2974427 100644 --- a/v7/src/microcode/makegen/Makefile.in.in +++ b/v7/src/microcode/makegen/Makefile.in.in @@ -1,6 +1,6 @@ # -*- 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, @@ -118,6 +118,7 @@ MODULE_LIBS = -lc # **** Program definitions **** +aux_PROGRAMS = @AUX_PROGRAMS@ aux_LIBS = $(MODULE_TARGETS) aux_DATA = utabmd.bin EXTRA_PROGRAMS = findprim @@ -134,7 +135,7 @@ findprim_DEPENDENCIES = findprim_LDFLAGS = findprim_LIBS = $(LIBS) -ALL_PROGRAMS = scheme +ALL_PROGRAMS = $(aux_PROGRAMS) scheme ALL_LIBS = $(aux_LIBS) ALL_DATA = $(aux_DATA) @@ -184,6 +185,12 @@ findprim: $(findprim_OBJECTS) $(findprim_DEPENDENCIES) -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 @@ -232,11 +239,21 @@ maintainer-clean: c-clean distclean 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)'; \ @@ -265,7 +282,8 @@ install-include: .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 **** diff --git a/v7/src/microcode/makegen/liarc-base-rules b/v7/src/microcode/makegen/liarc-base-rules index 0255a54a6..9fc310105 100644 --- a/v7/src/microcode/makegen/liarc-base-rules +++ b/v7/src/microcode/makegen/liarc-base-rules @@ -1,6 +1,6 @@ # -*- 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, @@ -30,6 +30,11 @@ cmpauxmd.o: cmpauxmd.c $(LIARC_HEAD_FILES) prims.h bignum.h bitstr.h avltree.h 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) diff --git a/v7/src/microcode/pruxdld.c b/v7/src/microcode/pruxdld.c index 3f9c17d9f..a8e6beebd 100644 --- a/v7/src/microcode/pruxdld.c +++ b/v7/src/microcode/pruxdld.c @@ -1,6 +1,6 @@ /* -*-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, @@ -32,82 +32,56 @@ USA. #include "usrdef.h" #include "syscall.h" #include "os.h" - -#ifdef HAVE_DLFCN_H - #include -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 */ - -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))) + +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, @@ -132,3 +106,104 @@ contents.") PRIMITIVE_HEADER (1); PRIMITIVE_RETURN (char_pointer_to_string ((char *) (arg_ulong_integer (1)))); } + +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); +} diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 618e83087..7e887ea86 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -186,6 +186,19 @@ USA. (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))) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index e0e105b7b..1762494c9 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -44,7 +44,9 @@ USA. 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 @@ -55,6 +57,8 @@ USA. (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)))) @@ -419,6 +423,8 @@ USA. (define-structure (directory-channel (conc-name directory-channel/)) descriptor) +(define-guarantee directory-channel "directory channel") + (define (directory-channel-open name) (without-interrupts (lambda () @@ -634,4 +640,91 @@ USA. (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))) + +;;;; 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))))))) + +(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 diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 380d9007d..9dcc11582 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -32,48 +32,27 @@ USA. (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) - -;;; 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) + +(define (load pathname #!optional environment syntax-table purify?) syntax-table ;ignored (let ((environment (if (default-object? environment) @@ -85,55 +64,207 @@ USA. (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?))))))) + +(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-timeblock 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))) + (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))) - + (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)) @@ -148,310 +279,135 @@ USA. (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)) -(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))))) -(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-timenamestring 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)) - -(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) - -(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))) ;;;; Command Line Parser diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 115c77184..4e9f501fd 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -242,8 +242,11 @@ USA. (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) @@ -253,10 +256,8 @@ USA. ((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))) @@ -314,7 +315,7 @@ USA. ;; 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) @@ -347,7 +348,7 @@ USA. ((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) @@ -379,7 +380,7 @@ USA. (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) @@ -418,7 +419,7 @@ USA. (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)))) @@ -529,7 +530,7 @@ USA. (if (eq? os-name 'NT) (package-initialize '(RUNTIME WIN32-REGISTRY) 'INITIALIZE-PACKAGE! #f)) -(let ((obj (file->object "site" #t #t))) +(let ((obj (file->object "site" #t #f))) (if obj (eval obj system-global-environment))) diff --git a/v7/src/runtime/option.scm b/v7/src/runtime/option.scm index f3fdeb607..f6d6d44a8 100644 --- a/v7/src/runtime/option.scm +++ b/v7/src/runtime/option.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -44,16 +44,13 @@ USA. (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)) @@ -92,15 +89,11 @@ USA. "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. @@ -138,17 +131,6 @@ USA. (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))) diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 31003b5e8..82ca27ca4 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -177,33 +177,27 @@ USA. (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) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 2f16951db..0ef3f2e4b 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -623,7 +623,7 @@ these rules: (%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.")))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 78770b51b..2561c5e5f 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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, @@ -1095,7 +1095,8 @@ USA. (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) @@ -1139,8 +1140,6 @@ USA. uncompress-internal) (export (runtime options) with-directory-rewriting-rule) - (export (runtime continuation-parser) - ) (initialization (initialize-package!))) (define-package (runtime console-i/o-port) @@ -2071,6 +2070,7 @@ USA. read read-char read-char-no-hang + read-file read-line read-string read-string! @@ -2406,6 +2406,8 @@ USA. (files "load") (parent (runtime)) (export () + (load-latest load) + (load-noisily load) argument-command-line-parser built-in-object-file condition-type:not-loading @@ -2413,28 +2415,21 @@ USA. 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) @@ -2650,7 +2645,6 @@ USA. (parent (runtime)) (export () *initial-options-file* - declare-shared-library define-load-option dummy-option-loader further-load-options @@ -2817,6 +2811,7 @@ USA. (files "io") (parent (runtime)) (export () + all-dld-handles all-open-channels channel-blocking channel-blocking? @@ -2849,10 +2844,26 @@ USA. 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 diff --git a/v7/src/runtime/utabs.scm b/v7/src/runtime/utabs.scm index 183815f68..641ad7963 100644 --- a/v7/src/runtime/utabs.scm +++ b/v7/src/runtime/utabs.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -57,7 +57,7 @@ USA. (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)) diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 051bd89fb..32e2c0def 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -29,7 +29,6 @@ USA. (declare (usual-integrations)) -(declare-shared-library "sf" (lambda () #t)) (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () diff --git a/v7/src/sos/load.scm b/v7/src/sos/load.scm index 168d1585d..84d7cc532 100644 --- a/v7/src/sos/load.scm +++ b/v7/src/sos/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -27,6 +27,5 @@ USA. (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 diff --git a/v7/src/ssp/load.scm b/v7/src/ssp/load.scm index b1e529672..b1a03bb5c 100644 --- a/v7/src/ssp/load.scm +++ b/v7/src/ssp/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -32,6 +32,5 @@ USA. (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 diff --git a/v7/src/star-parser/load.scm b/v7/src/star-parser/load.scm index b70adb508..cb117d27b 100644 --- a/v7/src/star-parser/load.scm +++ b/v7/src/star-parser/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -33,5 +33,4 @@ USA. (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 diff --git a/v7/src/xdoc/load.scm b/v7/src/xdoc/load.scm index 1c8d9d2b2..6c97d2d9c 100644 --- a/v7/src/xdoc/load.scm +++ b/v7/src/xdoc/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -47,6 +47,5 @@ USA. (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 diff --git a/v7/src/xml/load.scm b/v7/src/xml/load.scm index 63b6374c5..7e984ddcd 100644 --- a/v7/src/xml/load.scm +++ b/v7/src/xml/load.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -29,6 +29,5 @@ USA. (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